artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

core: String as array of bytes.

Browse source 
* src/strings.c: New file.
* src/mes.c: Use it.  Update users.
This commit is contained in:
Jan Nieuwenhuizen 2018-11-11 16:25:36 +01:00
parent 2e97dc1250
commit 149f2a3e51
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
60 changed files with 1792 additions and 913 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
build-aux/build-mes.sh
View file

@ -75,8 +75,8 @@ compile scaffold/argv
[ "$mes_p" ] && link scaffold/micro-mes
[ "$mes_p" ] && compile scaffold/tiny-mes
[ "$mes_p" ] && link scaffold/tiny-mes
[ "$mes_p" ] && compile scaffold/mini-mes
[ "$mes_p" ] && link scaffold/mini-mes
#[ "$mes_p" ] && compile scaffold/mini-mes
#[ "$mes_p" ] && link scaffold/mini-mes
compile src/mes
link src/mes

8
build-aux/check-boot.sh
View file

@ -46,6 +46,12 @@ tests="
16-if-eq-quote.scm
17-memq.scm
17-memq-keyword.scm
17-string-equal.scm
17-equal2.scm
17-open-input-string.scm
20-define.scm
20-define-quoted.scm
20-define-quote.scm
@ -99,6 +105,8 @@ tests="
4e-let-global.scm
4f-string-split.scm
50-string-append.scm
50-string-join.scm
50-primitive-load.scm
51-module.scm
52-define-module.scm

1
build-aux/check-mes.sh
View file

@ -52,6 +52,7 @@ tests/guile.test
tests/syntax.test
tests/let-syntax.test
tests/pmatch.test
tests/posix.test
tests/match.test
tests/psyntax.test
"

4
build-aux/config.sh
View file

@ -87,8 +87,7 @@ CPPFLAGS=${CPPFLAGS-"
-D 'VERSION=\"$VERSION\"'
-D 'MODULEDIR=\"$moduledir\"'
-D 'PREFIX=\"$prefix\"'
-I src
-I ${srcdest}src
-I ${srcdest}.
-I ${srcdest}lib
-I ${srcdest}include
"}
@ -97,6 +96,7 @@ CPPFLAGS=${CPPFLAGS-"
LDFLAGS=${LDFLAGS-"
-v
-g
-L lib/linux/$mes_arch
-L lib/linux
-L lib/$mes_arch

17
build-aux/mes-snarf.scm
View file

@ -110,8 +110,8 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
(define (symbol->names s i)
(if %gcc?
(format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.name);\n" s s)
(format #f "g_cells[cell_~a].car = cstring_to_list (scm_~a.car);\n" s s)))
(format #f "NAME_SYMBOL (cell_~a, scm_~a.name);\n" s s)
(format #f "NAME_SYMBOL (cell_~a, scm_~a.cdr);\n" s s)))
(define (function->header f i)
(let* ((arity (or (assoc-ref (function.annotation f) 'arity)
@ -132,7 +132,7 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
(string-append
(if %gcc?
(format #f "~a.function = g_function;\n" (function-builtin-name f))
(format #f "~a.cdr = g_function;\n" (function-builtin-name f)))
(format #f "~a.car = g_function;\n" (function-builtin-name f)))
(format #f "g_functions[g_function++] = fun_~a;\n" (function.name f))
(format #f "cell_~a = g_free++;\n" (function.name f))
(format #f "g_cells[cell_~a] = ~a;\n\n" (function.name f) (function-builtin-name f))))
@ -140,14 +140,11 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
(define (function->environment f i)
(string-append
(if %gcc?
(format #f "scm_~a.string = cstring_to_list (fun_~a.name);\n" (function.name f) (function.name f))
(format #f "scm_~a.car = cstring_to_list (fun_~a.name);\n" (function.name f) (function.name f)))
(format #f "scm_~a.string = MAKE_BYTES0 (fun_~a.name);\n" (function.name f) (function.name f))
(format #f "scm_~a.cdr = MAKE_BYTES0 (fun_~a.name);\n" (function.name f) (function.name f)))
(if %gcc?
(format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (function.name f) (function.name f))
(format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (function.name f) (function.name f)))
(if %gcc?
(format #f "a = acons (list_to_symbol (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f))
(format #f "a = acons (list_to_symbol (scm_~a.car), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
(format #f "a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_~a)), ~a, a);\n\n" (function.name f) (function-cell-name f))
(format #f "a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_~a)), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
(define (disjoin . predicates)
(lambda (. arguments)

21
build-aux/snarf.sh
View file

@ -27,13 +27,14 @@ snarf=" "
if [ -n "$1" ]; then
snarf=.mes
fi
trace "SNARF$snarf gc.c" ${srcdest}build-aux/mes-snarf.scm $1 src/gc.c
trace "SNARF$snarf hash.c" ${srcdest}build-aux/mes-snarf.scm $1 src/hash.c
trace "SNARF$snarf lib.c" ${srcdest}build-aux/mes-snarf.scm $1 src/lib.c
trace "SNARF$snarf math.c" ${srcdest}build-aux/mes-snarf.scm $1 src/math.c
trace "SNARF$snarf mes.c" ${srcdest}build-aux/mes-snarf.scm $1 src/mes.c
trace "SNARF$snarf module.c" ${srcdest}build-aux/mes-snarf.scm $1 src/module.c
trace "SNARF$snarf posix.c" ${srcdest}build-aux/mes-snarf.scm $1 src/posix.c
trace "SNARF$snarf reader.c" ${srcdest}build-aux/mes-snarf.scm $1 src/reader.c
trace "SNARF$snarf struct.c" ${srcdest}build-aux/mes-snarf.scm $1 src/struct.c
trace "SNARF$snarf vector.c" ${srcdest}build-aux/mes-snarf.scm $1 src/vector.c
trace "SNARF$snarf gc.c" ${srcdest}build-aux/mes-snarf.scm $1 src/gc.c
trace "SNARF$snarf hash.c" ${srcdest}build-aux/mes-snarf.scm $1 src/hash.c
trace "SNARF$snarf lib.c" ${srcdest}build-aux/mes-snarf.scm $1 src/lib.c
trace "SNARF$snarf math.c" ${srcdest}build-aux/mes-snarf.scm $1 src/math.c
trace "SNARF$snarf mes.c" ${srcdest}build-aux/mes-snarf.scm $1 src/mes.c
trace "SNARF$snarf module.c" ${srcdest}build-aux/mes-snarf.scm $1 src/module.c
trace "SNARF$snarf posix.c" ${srcdest}build-aux/mes-snarf.scm $1 src/posix.c
trace "SNARF$snarf reader.c" ${srcdest}build-aux/mes-snarf.scm $1 src/reader.c
trace "SNARF$snarf strings.c" ${srcdest}build-aux/mes-snarf.scm $1 src/strings.c
trace "SNARF$snarf struct.c" ${srcdest}build-aux/mes-snarf.scm $1 src/struct.c
trace "SNARF$snarf vector.c" ${srcdest}build-aux/mes-snarf.scm $1 src/vector.c

1
include/linux/x86_64/syscall.h
View file

@ -59,6 +59,7 @@
#define SYS_pipe 0x16
#define SYS_getgid 0x68
#define SYS_rt_sigaction 0x0d
#define SYS_rt_sigreturn 0x0f
#define SYS_fcntl 0x48
#define SYS_dup2 0x21
#define SYS_getrusage 0x62

1
include/signal.h
View file

@ -76,6 +76,7 @@ typedef long stack_t;
#define SA_NOCLDSTOP 0x00000001
#define SA_NOCLDWAIT 0x00000002
#define SA_SIGINFO 0x00000004
#define SA_RESTORER 0x04000000
#define SA_ONSTACK 0x08000000
#define SA_RESTART 0x10000000
#define SA_NODEFER 0x40000000

2
lib/linux/gettimeofday.c
View file

@ -18,7 +18,7 @@
* along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#include <time.h>
#include <sys/time.h>
int
gettimeofday (struct timeval *tv, struct timezone *tz)

10
lib/linux/gnu.c
View file

@ -63,19 +63,13 @@ getgid ()
return _sys_call (SYS_getgid);
}
// long _sys_call (long sys_call);
// long _sys_call4 (long sys_call, long one, long two, long three, long four);
#define SA_SIGINFO 4
#define SA_RESTORER 0x04000000
#define SYS_rt_sigreturn 15
#if __x86_64__
void
_restorer (void)
{
_sys_call (SYS_rt_sigreturn);
}
#endif
# define __sigmask(sig) \
(((unsigned long int) 1) << (((sig) - 1) % (8 * sizeof (unsigned long int))))

18
mes/module/mes/base.mes
View file

@ -101,6 +101,24 @@
(or (null? x)
(and (pair? x) (list? (cdr x)))))
(define-macro (cond . clauses)
(list 'if (pair? clauses)
(list (cons
'lambda
(cons
'(test)
(list (list 'if 'test
(if (pair? (cdr (car clauses)))
(if (eq? (car (cdr (car clauses))) '=>)
(append2 (cdr (cdr (car clauses))) '(test))
(list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
(list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
(if (pair? (cdr clauses))
(cons 'cond (cdr clauses)))))))
(car (car clauses)))))
(define else #t)
(define (procedure? p)
(cond ((builtin? p) #t)
((and (pair? p) (eq? (car p) 'lambda)))

52
mes/module/mes/boot-0.scm.in
View file

@ -52,18 +52,12 @@
(if (null? rest) (core:write x)
(core:write-port x (car rest))))
(define (list->string lst)
(core:make-cell <cell:string> lst 0))
(define (integer->char x)
(core:make-cell <cell:char> 0 x))
(define (newline . rest)
(core:display (list->string (list (integer->char 10)))))
(define (string->list s)
(core:car s))
(define (cadr x) (car (cdr x)))
(define (map1 f lst)
@ -107,7 +101,9 @@
#t)
;; end boot-02.scm
;; boot-0.scm
;; boot-03.scm
(define guile? #f)
(define mes? #t)
(define (primitive-eval e) (core:eval e (current-module)))
(define eval core:eval)
@ -125,24 +121,6 @@
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define-macro (cond . clauses)
(list 'if (pair? clauses)
(list (cons
'lambda
(cons
'(test)
(list (list 'if 'test
(if (pair? (cdr (car clauses)))
(if (eq? (car (cdr (car clauses))) '=>)
(append2 (cdr (cdr (car clauses))) '(test))
(list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
(list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
(if (pair? (cdr clauses))
(cons 'cond (cdr clauses)))))))
(car (car clauses)))))
(define else #t)
(define-macro (load file)
(list 'begin
(list 'if (list 'and (list getenv "MES_DEBUG")
@ -161,9 +139,6 @@
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define (string->list s)
(core:car s))
(define %prefix (getenv "MES_PREFIX"))
(define %moduledir
(if (not %prefix) "mes/module/"
@ -173,16 +148,9 @@
(include (list->string
(append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
(define (symbol->string s)
(apply string (symbol->list s)))
(define (string-append . rest)
(apply string (apply append (map1 string->list rest))))
(define %version (if (eq? (car (string->list "@VERSION@")) #\@) "git"
"@VERSION@"))
(define (effective-version) %version)
(if (and (getenv "MES_DEBUG")
(not (equal2? (getenv "MES_DEBUG") "0"))
(not (equal2? (getenv "MES_DEBUG") "1")))
@ -205,6 +173,20 @@
(mes-use-module (mes quasiquote))
(mes-use-module (mes let))
(mes-use-module (mes scm))
(define-macro (define-module module . rest)
`(if ,(and (pair? module)
(= 1 (length module))
(symbol? (car module)))
(define (,(car module) . arguments) (main (command-line)))))
(define-macro (use-modules . rest) #t)
;; end boot-03.scm
(define %version (if (eq? (car (string->list "@VERSION@")) #\@) "git"
"@VERSION@"))
(define (effective-version) %version)
(mes-use-module (srfi srfi-1))
(mes-use-module (srfi srfi-13))
(mes-use-module (mes fluids))

6
mes/module/mes/boot-01.scm
View file

@ -42,18 +42,12 @@
(if (null? rest) (core:write x)
(core:write-port x (car rest))))
(define (list->string lst)
(core:make-cell <cell:string> lst 0))
(define (integer->char x)
(core:make-cell <cell:char> 0 x))
(define (newline . rest)
(core:display (list->string (list (integer->char 10)))))
(define (string->list s)
(core:car s))
(define (cadr x) (car (cdr x)))
(define (map1 f lst)

6
mes/module/mes/boot-02.scm
View file

@ -52,18 +52,12 @@
(if (null? rest) (core:write x)
(core:write-port x (car rest))))
(define (list->string lst)
(core:make-cell <cell:string> lst 0))
(define (integer->char x)
(core:make-cell <cell:char> 0 x))
(define (newline . rest)
(core:display (list->string (list (integer->char 10)))))
(define (string->list s)
(core:car s))
(define (cadr x) (car (cdr x)))
(define (map1 f lst)

186
mes/module/mes/boot-03.scm Normal file
View file

@ -0,0 +1,186 @@
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; read-0.mes - bootstrap reader. This file is read by a minimal
;;; core reader. It only supports s-exps and line-comments; quotes,
;;; character literals, string literals cannot be used here.
;;; Code:
;; boot-00.scm
(define mes %version)
(define (defined? x)
(module-variable (current-module) x))
(define (cond-expand-expander clauses)
(if (defined? (car (car clauses)))
(cdr (car clauses))
(cond-expand-expander (cdr clauses))))
(define-macro (cond-expand . clauses)
(cons 'begin (cond-expand-expander clauses)))
;; end boot-00.scm
;; boot-01.scm
(define (not x) (if x #f #t))
(define (display x . rest)
(if (null? rest) (core:display x)
(core:display-port x (car rest))))
(define (write x . rest)
(if (null? rest) (core:write x)
(core:write-port x (car rest))))
(define (integer->char x)
(core:make-cell <cell:char> 0 x))
(define (newline . rest)
(core:display (list->string (list (integer->char 10)))))
(define (cadr x) (car (cdr x)))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define (map f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map f (cdr lst)))))
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
;; end boot-01.scm
;; boot-02.scm
(define-macro (and . x)
(if (null? x) #t
(if (null? (cdr x)) (car x)
(list (quote if) (car x) (cons (quote and) (cdr x))
#f))))
(define-macro (or . x)
(if (null? x) #f
(if (null? (cdr x)) (car x)
(list (list (quote lambda) (list (quote r))
(list (quote if) (quote r) (quote r)
(cons (quote or) (cdr x))))
(car x)))))
(define-macro (mes-use-module module)
#t)
;; end boot-02.scm
;; boot-03.scm
(define guile? #f)
(define mes? #t)
(define (primitive-eval e) (core:eval e (current-module)))
(define eval core:eval)
(define (port-filename port) "<stdin>")
(define (port-line port) 0)
(define (port-column port) 0)
(define (ftell port) 0)
(define (false-if-exception x) x)
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define-macro (load file)
(list 'begin
(list 'if (list 'and (list getenv "MES_DEBUG")
(list not (list equal2? (list getenv "MES_DEBUG") "0"))
(list not (list equal2? (list getenv "MES_DEBUG") "1")))
(list 'begin
(list core:display-error ";;; read ")
(list core:display-error file)
(list core:display-error "\n")))
(list 'primitive-load file)))
(define-macro (include file) (list 'load file))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define %prefix (getenv "MES_PREFIX"))
(define %moduledir
(if (not %prefix) "boe /share/mes/module/"
(list->string
(append (string->list %prefix) (string->list "/module/" )))))
(include (list->string
(append2 (string->list %moduledir) (string->list "mes/type-0.mes"))))
(define (string-append . rest)
(apply string (apply append (map1 string->list rest))))
(if (and (getenv "MES_DEBUG")
(not (equal2? (getenv "MES_DEBUG") "0"))
(not (equal2? (getenv "MES_DEBUG") "1")))
(begin
(core:display-error ";;; %moduledir=")
(core:display-error %moduledir)
(core:display-error "\n")))
(define-macro (include-from-path file)
(list 'load (list string-append %moduledir file)))
(define (string-join lst infix)
(if (null? lst) ""
(if (null? (cdr lst)) (car lst)
(string-append (car lst) infix (string-join (cdr lst) infix)))))
(include-from-path "mes/module.mes")
(mes-use-module (mes base))
(mes-use-module (mes quasiquote))
(mes-use-module (mes let))
(mes-use-module (mes scm))
(define-macro (define-module module . rest)
`(if ,(and (pair? module)
(= 1 (length module))
(symbol? (car module)))
(define (,(car module) . arguments) (main (command-line)))))
(define-macro (use-modules . rest) #t)
;; end boot-03.scm
(primitive-load 0)
(primitive-load 0)

59
mes/module/mes/display.mes
View file

@ -50,31 +50,33 @@
(write? (and (pair? rest) (pair? (cdr rest)) (cadr rest))))
(define (display-char x port write?)
(cond ((and write? (or (eq? x #\") (eq? x #\\)))
(write-char #\\ port)
(write-char x port))
((and write? (eq? x #\nul))
(write-char #\\ port)
(write-char #\0 port))
((and write? (eq? x #\alarm))
(write-char #\\ port)
(write-char #\a port))
((and write? (eq? x #\backspace))
(write-char #\\ port)
(write-char #\b port))
((and write? (eq? x #\tab))
(write-char #\\ port)
(write-char #\t port))
((and write? (eq? x #\newline))
(write-char #\\ port)
(write-char #\n port))
((and write? (eq? x #\vtab))
(write-char #\\ port)
(write-char #\v port))
((and write? (eq? x #\page))
(write-char #\\ port)
(write-char #\f port))
(#t (write-char x port))))
(if write?
(cond ((or (eq? x #\") (eq? x #\\))
(write-char #\\ port)
(write-char x port))
((eq? x #\nul)
(write-char #\\ port)
(write-char #\0 port))
((eq? x #\alarm)
(write-char #\\ port)
(write-char #\a port))
((eq? x #\backspace)
(write-char #\\ port)
(write-char #\b port))
((eq? x #\tab)
(write-char #\\ port)
(write-char #\t port))
((eq? x #\newline)
(write-char #\\ port)
(write-char #\n port))
((eq? x #\vtab)
(write-char #\\ port)
(write-char #\v port))
((eq? x #\page)
(write-char #\\ port)
(write-char #\f port))
(#t (write-char x port)))
(write-char x port)))
(define (d x cont? sep)
(for-each (display-cut write-char <> port) (string->list sep))
@ -94,7 +96,10 @@
(#\space . space)))
cdr)))
(write-char #\# port)
(write-char #\\ port)
(when (or name
(and (>= (char->integer 32))
(<= (char->integer 127))))
(write-char #\\ port))
(if name (display name port)
(write-char x port)))))
((closure? x)
@ -163,7 +168,7 @@
(display ")" port))
((function? x)
(display "#<procedure " port)
(display (core:car x) port)
(display (core:procedure-name x) port)
(display " " port)
(display
(case (core:arity x)

2
mes/module/mes/scm.mes
View file

@ -284,7 +284,7 @@
;;; Keywords
(define (keyword->symbol s)
(list->symbol (keyword->list s)))
(string->symbol (keyword->string s)))
;;; Characters

29
mes/module/mes/type-0.mes
View file

@ -26,7 +26,8 @@
;;; Code:
(define cell:type-alist
(list (cons <cell:char> (quote <cell:char>))
(list (cons <cell:bytes> (quote <cell:bytes>))
(cons <cell:char> (quote <cell:char>))
(cons <cell:closure> (quote <cell:closure>))
(cons <cell:continuation> (quote <cell:continuation>))
(cons <cell:function> (quote <cell:function>))
@ -47,6 +48,9 @@
(define (cell:type-name x)
(cond ((assq (core:type x) cell:type-alist) => cdr)))
(define (bytes? x)
(eq? (core:type x) <cell:bytes>))
(define (char? x)
(and (eq? (core:type x) <cell:char>)
(> (char->integer x) -1)))
@ -102,10 +106,8 @@
(define (vector? x)
(eq? (core:type x) <cell:vector>))
;; Non-types
;; In core
;; (define (null? x)
;; (eq? x '()))
(define (broken-heart? x)
(eq? (core:type x) <cell:broken-heart>))
(define (atom? x)
(not (pair? x)))
@ -116,20 +118,13 @@
;;; core: accessors
(define (string . lst)
(core:make-cell <cell:string> lst 0))
(define (string->symbol s)
(if (not (pair? (core:car s))) '()
(list->symbol (core:car s))))
(define (symbol->keyword s)
(core:make-cell <cell:keyword> (symbol->list s) 0))
(define (symbol->list s)
(core:car s))
(list->string lst))
(define (keyword->list s)
(core:car s))
(string->list (keyword->string s)))
(define (symbol->list s)
(string->list (symbol->string s)))
(define (integer->char x)
(core:make-cell <cell:char> 0 x))

4
mes/module/srfi/srfi-13.mes
View file

@ -41,10 +41,6 @@
(define (string-copy s)
(list->string (string->list s)))
(define (string=? a b)
(eq? (string->symbol a)
(string->symbol b)))
(define (string= a b . rest)
(let* ((start1 (and (pair? rest) (car rest)))
(end1 (and start1 (pair? (cdr rest)) (cadr rest)))

31
module/mes/getopt-long.scm
View file

@ -1,24 +1,19 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright (C) 1998, 2001, 2006 Free Software Foundation, Inc.
;;; Copyright (C) 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
;;; From Guile-1.8
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
;;; (regexps removed by Jan (janneke) Nieuwenhuizen)

2
module/mes/guile.scm
View file

@ -45,6 +45,7 @@
core:write-error
core:write-port
core:type
equal2?
pmatch-car
pmatch-cdr
)
@ -66,6 +67,7 @@
(define (core:apply f a . m) (apply f a))
(define (core:car f a . m) (apply f a))
(define append2 append)
(define equal2? equal?)
(define guile:keyword? keyword?)
(define guile:number? number?)

3
module/mes/misc.scm
View file

@ -53,10 +53,11 @@
(car (last-pair stuff)))
(define (pke . stuff)
(display "\n" (current-error-port))
(newline (current-error-port))
(display ";;; " (current-error-port))
(write stuff (current-error-port))
(newline (current-error-port))
(display "\n" (current-error-port))
(car (last-pair stuff)))
(define warn pke)

11
mes/module/mes/optargs.scm → module/mes/optargs.scm
View file

@ -6,12 +6,12 @@
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
@ -57,7 +57,7 @@
;;; Code:
(define-module (ice-9 optargs)
(define-module (mes optargs)
#:use-module (system base pmatch)
#:replace (lambda*)
#:export-syntax (let-optional
@ -151,14 +151,13 @@
=> cdr)
(else
,(cadr key)))))))
`(let ((,kb-list-gensym (;;(@@ (ice-9 optargs) rest-arg->keyword-binding-list)
rest-arg->keyword-binding-list
`(let ((,kb-list-gensym ((if (not mes?) (@@ (mes optargs) rest-arg->keyword-binding-list)
rest-arg->keyword-binding-list)
,REST-ARG ',(map (lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
BINDINGS)
,ALLOW-OTHER-KEYS?)))
,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))
(define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
(if (null? rest-arg)
'()

4
module/mescc/M1.scm
View file

@ -111,6 +111,7 @@
(if (equal? o "%0") o ; FIXME: 64b
(error "no such string:" o)))))
(define (text->M1 o)
;;
(cond
((char? o) (text->M1 (char->integer o)))
((string? o) o)
@ -166,7 +167,8 @@
((#:immediate4 ,immediate4) (hex2:immediate4 immediate4))
((#:immediate8 ,immediate8) (hex2:immediate8 immediate8))
(_ (error "text->M1 no match o" o))))
((pair? o) (string-join (map text->M1 o)))))
((pair? o) (string-join (map text->M1 o)))
(#t (error "no such text:" o))))
(define (write-function o)
(let ((name (car o))
(text (function:text (cdr o))))

5
module/mescc/compile.scm
View file

@ -910,8 +910,7 @@
((p-expr (fixed ,value))
(let* ((value (cstring->int value))
(info (allocate-register info))
(info (append-text info (append (wrap-as (as info 'value->r value)))))
(reg-size (->size "*" info)))
(info (append-text info (wrap-as (as info 'value->r value)))))
(if (or #t (> value 0) (= reg-size 4)) info
(append-text info (wrap-as (as info 'long-signed-r))))))
@ -1208,7 +1207,7 @@
((rshift ,a ,b) ((binop->r info) a b 'r0>>r1))
((div ,a ,b)
((binop->r info) a b 'r0/r1
(or (signed? (ast->type a info)) (signed? (ast->type b info)))))
(or (signed? (ast->type a info)) (signed? (ast->type b info)))))
((mod ,a ,b) ((binop->r info) a b 'r0%r1
(or (signed? (ast->type a info)) (signed? (ast->type b info)))))
((mul ,a ,b) ((binop->r info) a b 'r0*r1))

25
scaffold/boot/17-equal2.scm Normal file
View file

@ -0,0 +1,25 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(core:write (if (equal2? "" "") #t (exit 1)))
(core:write "\n")
(core:write (if (equal2? '("foo" "") '("foo" "")) #t (exit 1)))
(core:write "\n")
(core:write (if (equal2? '("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "") '("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" "")) #t (exit 1)))
(core:write "\n")
(exit 0)

21
scaffold/boot/17-memq-keyword.scm Normal file
View file

@ -0,0 +1,21 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(if (memq '#:bar '(foo #:bar baz))
(exit 0))
(exit 1)

21
scaffold/boot/17-memq.scm Normal file
View file

@ -0,0 +1,21 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(if (memq 'bar '(foo bar baz))
(exit 0))
(exit 1)

36
scaffold/boot/17-open-input-string.scm Normal file
View file

@ -0,0 +1,36 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
((lambda (port)
(core:display-error "port:")
(core:write-error port)
(core:display-error "\n")
(set-current-input-port port)
(core:display-error "current:")
(core:write-error (current-input-port))
(core:display-error "\n")
(core:display-error "read:")
((lambda (string)
(core:write-error string)
(core:display-error "\n")
(core:display-error "empty:")
(core:write-error port)
(core:display-error "\n")
(exit (if (equal2? string "foo bar\n") 0 1)))
((if (pair? (current-module)) read-string (@ (ice-9 rdelim) read-string)) port)))
(open-input-string "foo bar\n"))

23
scaffold/boot/17-string-equal.scm Normal file
View file

@ -0,0 +1,23 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(core:write (if (string=? "" "") #t (exit 1)))
(core:write (if (string=? "foo" "foo") #t (exit 1)))
(core:write (if (string=? "" "foo") (exit 1)))
(core:write "\n")
(exit 0)

6
scaffold/boot/4f-string-split.scm
View file

@ -91,12 +91,6 @@
;; (if (= 0 n) '()
;; (foo (car x) (ss-list-head (cdr x) (- n 1)))))
(define (string->list s)
(core:car s))
(define (list->string lst)
(core:make-cell <cell:string> lst 0))
(define (not x) (if x #f #t))
(define (string-split s c)

23
scaffold/boot/50-keyword.scm Normal file
View file

@ -0,0 +1,23 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(core:display-error "symbol->keyword\n")
(core:write (symbol->keyword 'foo))
(core:display-error "\n")
(core:write (keyword->string #:bar))
(core:display-error "dun\n")

59
scaffold/boot/50-make-string.scm Normal file
View file

@ -0,0 +1,59 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(cond-expand
(guile)
(mes
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define (string . lst)
(list->string lst))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define map map1)
(define (string-append . rest)
(apply string (apply append (map string->list rest))))))
(define (make-list n . fill)
fill)
(define (make-string n . fill)
(list->string (apply make-list n fill)))
;;(make-string 1 (option-spec->single-char spec))
(core:write-error (make-string 1 #\a))
;;(core:write-error (list->string '(#\a #\b #\c)))
;; (if (string=? (string-append "foo" "/" "bar") "foo/bar")
;; (exit 0))
;; (exit 1)

49
scaffold/boot/50-string-append.scm Normal file
View file

@ -0,0 +1,49 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(cond-expand
(guile)
(mes
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define (string . lst)
(list->string lst))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define map map1)
(define (string-append . rest)
(apply string (apply append (map string->list rest))))))
(if (string=? (string-append "foo" "/" "bar") "foo/bar")
(exit 0))
(exit 1)

53
scaffold/boot/50-string-join.scm Normal file
View file

@ -0,0 +1,53 @@
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(cond-expand
(guile)
(mes
(define (cons* . rest)
(if (null? (cdr rest)) (car rest)
(cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
(define (apply f h . t)
(if (null? t) (core:apply f h (current-module))
(apply f (apply cons* (cons h t)))))
(define (append . rest)
(if (null? rest) '()
(if (null? (cdr rest)) (car rest)
(append2 (car rest) (apply append (cdr rest))))))
(define (string . lst)
(list->string lst))
(define (map1 f lst)
(if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst)))))
(define map map1)
(define (string-append . rest)
(apply string (apply append (map string->list rest))))))
(define (string-join lst infix)
(if (null? (cdr lst)) (car lst)
(string-append (car lst) infix (string-join (cdr lst) infix))))
(if (string=? (string-join '("foo" "bar") "/") "foo/bar")
(exit 0))
(exit 1)

23
scaffold/boot/51-module.scm
View file

@ -42,11 +42,8 @@
(list (quote if) (car x) (cons (quote and) (cdr x))
#f))))
(define (string->list s)
(core:car s))
(define (string . lst)
(core:make-cell <cell:string> lst 0))
(list->string lst))
(define (string-append . rest)
(apply string (apply append (map string->list rest))))
@ -60,9 +57,6 @@
(define map map1)
(define (list->string lst)
(core:make-cell <cell:string> lst 0))
(define %moduledir
(if (not %prefix ) "mes/module/"
(list->string
@ -80,24 +74,11 @@
(define-macro (include-from-path file)
(list 'load (list string-append %moduledir file)))
(define (string->symbol s)
(list->symbol (core:car s)))
(define (symbol->list s)
(core:car s))
(define (string . lst)
(core:make-cell <cell:string> lst 0))
(define (symbol->string s)
(apply string (symbol->list s)))
(define (getcwd) ".")
(define (display x . rest)
(if (null? rest) (core:display x)
(core:display-port x (car rest))))
))
(core:display-port x (car rest))))))
(define (memq x lst)
(if (null? lst) #f

21
scaffold/boot/52-define-module.scm
View file

@ -40,11 +40,8 @@
(list (quote if) (car x) (cons (quote and) (cdr x))
#f))))
(define (string->list s)
(core:car s))
(define (string . lst)
(core:make-cell <cell:string> lst 0))
(list->string lst))
(define (map1 f lst)
(if (null? lst) (list)
@ -54,23 +51,13 @@
(define (string-append . rest)
(apply string (apply append (map string->list rest))))
;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;
(define (symbol->list s)
(core:car s))
(define (symbol->string s)
(apply string (symbol->list s)))
(define (string-join lst infix)
(if (null? (cdr lst)) (car lst)
(string-append (car lst) infix (string-join (cdr lst) infix))))
;;;;;;;;;;;;;;;;;;
(define (string->symbol s)
(list->symbol (core:car s)))
(define-macro (load file)
(list 'primitive-load file))
@ -83,5 +70,11 @@
))
(define %moduledir "./")
(core:display-error "reading...\n")
(primitive-load "mes/module/mes/module.mes")
(core:display-error "dun\n")
(core:write-error (map symbol->string '(scaffold boot data bar)))
(core:display-error "\n")
(core:write-error (string-join (map symbol->string '(scaffold boot data bar)) "/"))
(core:display-error "\n")
(mes-use-module (scaffold boot data bar))

9
scaffold/boot/60-let-syntax-expanded.scm
View file

@ -46,9 +46,6 @@
(if (null? rest) (core:write x)
(core:write-port x (car rest))))
(define (list->string lst)
(core:make-cell <cell:string> lst 0))
(define (integer->char x)
(core:make-cell <cell:character> 0 x))
@ -142,10 +139,6 @@
(define (symbol? x)
(eq? (core:type x) <cell:symbol>))
(define (string->symbol s)
(if (not (pair? (core:car s))) '()
(list->symbol (core:car s))))
(define <cell:string> 10)
(define (string? x)
(eq? (core:type x) <cell:string>))
@ -232,7 +225,7 @@
(and (equal2? (car a) (car b))
(equal2? (cdr a) (cdr b)))
(if (and (string? a) (string? b))
(eq? (string->symbol a) (string->symbol b))
(string=? a b)
(if (and (vector? a) (vector? b))
(equal2? (vector->list a) (vector->list b))
(eq? a b))))))

4
scaffold/boot/60-let-syntax.scm
View file

@ -55,10 +55,6 @@
(define (symbol? x)
(eq? (core:type x) <cell:symbol>))
(define (string->symbol s)
(if (not (pair? (core:car s))) '()
(list->symbol (core:car s))))
(define (string? x)
(eq? (core:type x) <cell:string>))

61
scaffold/mini-mes.c
View file

@ -218,7 +218,7 @@ struct scm scm_symbol_arch = {TSYMBOL, "%arch",0};
struct scm scm_test = {TSYMBOL, "test",0};
#include "mes.mes.symbols.h"
#include "src/mes.mes.symbols.h"
SCM tmp;
SCM tmp_num;
@ -227,19 +227,19 @@ SCM tmp_num2;
struct function g_functions[200];
int g_function = 0;
#include "gc.mes.h"
#include "lib.mes.h"
#include "src/gc.mes.h"
#include "src/lib.mes.h"
#if !MES_MINI
#include "math.mes.h"
#include "src/math.mes.h"
#endif
#include "mes.mes.h"
#include "src/mes.mes.h"
SCM gc_init_news ();
// #if !MES_MINI
// #include "posix.mes.h"
// #include "src/posix.mes.h"
// #ndif
//#include "vector.mes.h"
//#include "src/vector.mes.h"
#define TYPE(x) g_cells[x].type
#define CAR(x) g_cells[x].car
@ -273,7 +273,7 @@ SCM gc_init_news ();
#define MAKE_CONTINUATION(n) make_cell_ (tmp_num_ (TCONTINUATION), n, g_stack)
#define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n))
#define MAKE_REF(n) make_cell_ (tmp_num_ (TREF), n, 0)
#define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0)
#define MAKE_STRING0(x) make_string (x, strlen (x))
#define CAAR(x) CAR (CAR (x))
#define CADR(x) CAR (CDR (x))
@ -809,10 +809,11 @@ make_tmps (struct scm* cells)
}
#if !MES_MINI
#include "posix.c"
#include "math.c"
#include "src/posix.c"
#include "src/math.c"
#endif
#include "lib.c"
#include "src/lib.c"
#include "src/strings.c"
SCM frame_printer (SCM frame)
{
@ -861,7 +862,7 @@ mes_symbols () ///((internal))
gc_init_cells ();
gc_init_news ();
#include "mes.mes.symbols.i"
#include "src/mes.mes.symbols.i"
g_symbol_max = g_free;
make_tmps (g_cells);
@ -872,7 +873,7 @@ mes_symbols () ///((internal))
SCM a = cell_nil;
#include "mes.mes.symbol-names.i"
#include "src/mes.mes.symbol-names.i"
a = acons (cell_symbol_mes_version, MAKE_STRING (cstring_to_list (VERSION)), a);
a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
@ -913,33 +914,35 @@ mes_environment () ///((internal))
SCM
mes_builtins (SCM a) ///((internal))
{
#include "mes.mes.i"
#include "src/mes.mes.i"
// Do not sort: Order of these includes define builtins
#if !MES_MINI
#include "posix.mes.i"
#include "math.mes.i"
#include "src/posix.mes.i"
#include "src/math.mes.i"
#endif
#include "lib.mes.i"
#include "src/lib.mes.i"
#if !MES_MINI
#include "vector.mes.i"
#include "src/vector.mes.i"
#endif
#include "gc.mes.i"
#include "src/gc.mes.i"
#if !MES_MINI
//#include "reader.mes.i"
//#include "src/reader.mes.i"
#endif
#include "src/strings.mes.i"
#include "gc.mes.environment.i"
#include "lib.mes.environment.i"
#include "src/gc.mes.environment.i"
#include "src/lib.mes.environment.i"
#if !MES_MINI
#include "math.mes.environment.i"
#include "src/math.mes.environment.i"
#endif
#include "mes.mes.environment.i"
#include "src/mes.mes.environment.i"
#if !MES_MINI
#include "posix.mes.environment.i"
//#include "reader.mes.environment.i"
#include "vector.mes.environment.i"
#include "src/posix.mes.environment.i"
//#include "src/reader.mes.environment.i"
#include "src/vector.mes.environment.i"
#endif
#include "src/strings.mes.i"
return a;
}
@ -1012,9 +1015,9 @@ bload_env (SCM a) ///((internal))
}
#if !MES_MINI
#include "vector.c"
#include "src/vector.c"
#endif
#include "gc.c"
#include "src/gc.c"
int
main (int argc, char *argv[])

4
scripts/mescc.in
View file

@ -5,6 +5,10 @@ if [ "$V" = 2 ]; then
fi
prefix=${prefix-@prefix@}
program_prefix=${program_prefix-@program_prefix@}
MES_ARENA=${MES_ARENA-100000000}
export MES_ARENA
MES_STACK=${MES_STACK-500000}
export MES_STACK
MES_PREFIX=${MES_PREFIX-$prefix/share/mes}
export MES_PREFIX
mes_p=$(command -v mes)

35
src/gc.c
View file

@ -20,6 +20,8 @@
#include <errno.h>
size_t bytes_cells (size_t length);
SCM
gc_up_arena () ///((internal))
{
@ -79,6 +81,22 @@ gc_copy (SCM old) ///((internal))
for (long i=0; i<LENGTH (old); i++)
g_news[g_free++] = g_cells[VECTOR (old)+i];
}
else if (NTYPE (new) == TBYTES)
{
char const *src = CBYTES (old);
char *dest = NCBYTES (new);
size_t length = NLENGTH (new);
memcpy (dest, src, length + 1);
g_free += bytes_cells (length) - 1;
if (g_debug > 4)
{
eputs ("gc copy bytes: "); eputs (src); eputs ("\n");
eputs (" length: "); eputs (itoa (LENGTH (old))); eputs ("\n");
eputs (" nlength: "); eputs (itoa (NLENGTH (new))); eputs ("\n");
eputs (" ==> "); eputs (dest); eputs ("\n");
}
}
TYPE (old) = TBROKEN_HEART;
CAR (old) = new;
return new;
@ -107,16 +125,10 @@ gc_loop (SCM scan) ///((internal))
{
if (NTYPE (scan) == TBROKEN_HEART)
error (cell_symbol_system_error, cell_gc);
if (NTYPE (scan) == TFUNCTION
|| NTYPE (scan) == TKEYWORD
|| NTYPE (scan) == TMACRO
if (NTYPE (scan) == TMACRO
|| NTYPE (scan) == TPAIR
|| NTYPE (scan) == TPORT
|| NTYPE (scan) == TREF
|| scan == 1 // null
|| NTYPE (scan) == TSPECIAL
|| NTYPE (scan) == TSTRING
|| NTYPE (scan) == TSYMBOL
|| NTYPE (scan) == TVARIABLE)
{
car = gc_copy (g_news[scan].car);
@ -124,14 +136,23 @@ gc_loop (SCM scan) ///((internal))
}
if ((NTYPE (scan) == TCLOSURE
|| NTYPE (scan) == TCONTINUATION
|| NTYPE (scan) == TFUNCTION
|| NTYPE (scan) == TKEYWORD
|| NTYPE (scan) == TMACRO
|| NTYPE (scan) == TPAIR
|| NTYPE (scan) == TPORT
|| NTYPE (scan) == TSPECIAL
|| NTYPE (scan) == TSTRING
|| NTYPE (scan) == TSYMBOL
|| scan == 1 // null
|| NTYPE (scan) == TVALUES)
&& g_news[scan].cdr) // allow for 0 terminated list of symbols
{
cdr = gc_copy (g_news[scan].cdr);
gc_relocate_cdr (scan, cdr);
}
if (NTYPE (scan) == TBYTES)
scan += bytes_cells (NLENGTH (scan)) - 1;
scan++;
}
gc_flip ();

14
src/hash.c
View file

@ -23,11 +23,11 @@ SCM vector_ref_ (SCM x, long i);
SCM vector_set_x_ (SCM x, long i, SCM e);
int
hash_list_of_char (SCM lst, long size)
hash_cstring (char const* s, long size)
{
int hash = VALUE (CAR (lst)) * 37;
if (TYPE (CDR (lst)) == TPAIR && TYPE (CADR (lst)) == TCHAR)
hash = hash + VALUE (CADR (lst)) * 43;
int hash = s[0] * 37;
if (s[0] && s[1])
hash = hash + s[1] * 43;
assert (size);
hash = hash % size;
return hash;
@ -38,15 +38,15 @@ hashq_ (SCM x, long size)
{
if (TYPE (x) == TSPECIAL
|| TYPE (x) == TSYMBOL)
return hash_list_of_char (STRING (x), size); // FIXME: hash x directly
error (cell_symbol_system_error, cons (MAKE_STRING (cstring_to_list ("hashq_: not a symbol")), x));
return hash_cstring (CSTRING (x), size); // FIXME: hash x directly
error (cell_symbol_system_error, cons (MAKE_STRING0 ("hashq_: not a symbol"), x));
}
int
hash_ (SCM x, long size)
{
if (TYPE (x) == TSTRING)
return hash_list_of_char (STRING (x), size);
return hash_cstring (CSTRING (x), size);
assert (0);
return hashq_ (x, size);
}

81
src/lib.c
View file

@ -36,20 +36,25 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
fdputc (VALUE (x), fd);
else
{
fdputs ("#\\", fd);
fdputs ("#", fd);
long v = VALUE (x);
if (v == '\0') fdputs ("nul", fd);
else if (v == '\a') fdputs ("alarm", fd);
else if (v == '\b') fdputs ("backspace", fd);
else if (v == '\t') fdputs ("tab", fd);
else if (v == '\n') fdputs ("newline", fd);
else if (v == '\v') fdputs ("vtab", fd);
else if (v == '\f') fdputs ("page", fd);
if (v == '\0') fdputs ("\\nul", fd);
else if (v == '\a') fdputs ("\\alarm", fd);
else if (v == '\b') fdputs ("\\backspace", fd);
else if (v == '\t') fdputs ("\\tab", fd);
else if (v == '\n') fdputs ("\\newline", fd);
else if (v == '\v') fdputs ("\\vtab", fd);
else if (v == '\f') fdputs ("\\page", fd);
//Nyacc bug
// else if (v == '\r') fdputs ("return", fd);
else if (v == 13) fdputs ("return", fd);
else if (v == ' ') fdputs ("space", fd);
else fdputc (VALUE (x), fd);
else if (v == 13) fdputs ("\\return", fd);
else if (v == ' ') fdputs ("\\space", fd);
else
{
if (v >= 32 && v <= 127)
fdputc ('\\', fd);
fdputc (VALUE (x), fd);
}
}
}
else if (t == TCLOSURE)
@ -131,20 +136,27 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
|| t == TSTRING
|| t == TSYMBOL)
{
if (TYPE (x) == TPORT)
if (t == TPORT)
{
fdputs ("#<port ", fd);
fdputs (itoa (PORT (x)), fd);
fdputs (" " ,fd);
x = STRING (x);
}
if (TYPE (x) == TKEYWORD)
if (t == TKEYWORD)
fdputs ("#:", fd);
if ((write_p && TYPE (x) == TSTRING) || TYPE (x) == TPORT)
if ((write_p && t == TSTRING) || t == TPORT)
fdputc ('"', fd);
SCM t = CAR (x);
while (t && t != cell_nil)
char const *s = CSTRING (x);
#if 0
s += START (x);
size_t length = LEN (x);
#else
size_t length = LENGTH (x);
#endif
for (size_t i=0; i < length; i++)
{
long v = write_p ? VALUE (CAR (t)) : -1;
long v = write_p ? s[i] : -1;
if (v == '\0') fdputs ("\\0", fd);
else if (v == '\a') fdputs ("\\a", fd);
else if (v == '\b') fdputs ("\\b", fd);
@ -163,12 +175,11 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
#endif
else if (v == '\\') fdputs ("\\\\", fd);
else if (v == '"') fdputs ("\\\"", fd);
else fdputc (VALUE (CAR (t)), fd);
t = CDR (t);
else fdputc (s[i], fd);
}
if ((write_p && TYPE (x) == TSTRING) || TYPE (x) == TPORT)
if ((write_p && t == TSTRING) || t == TPORT)
fdputc ('"', fd);
if (TYPE (x) == TPORT)
if (t == TPORT)
fdputs (">", fd);
}
else if (t == TREF)
@ -178,7 +189,8 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
SCM printer = STRUCT (x) + 1;
if (TYPE (printer) == TREF)
printer = REF (printer);
if (printer != cell_unspecified)
if (TYPE (printer) == TCLOSURE
|| TYPE (printer) == TFUNCTION)
apply (printer, cons (x, cell_nil), r0);
else
{
@ -209,7 +221,7 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
else
{
fdputs ("<", fd);
fdputs (itoa (TYPE (x)), fd);
fdputs (itoa (t), fd);
fdputs (":", fd);
fdputs (itoa (x), fd);
fdputs (">", fd);
@ -217,6 +229,16 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
return 0;
}
SCM
procedure_name_ (SCM x)
{
assert (TYPE (x) == TFUNCTION);
char const *p = "?";
if (FUNCTION (x).name != 0)
p = FUNCTION (x).name;
return MAKE_STRING0 (p);
}
SCM
display_ (SCM x)
{
@ -273,7 +295,6 @@ exit_ (SCM x) ///((name . "exit"))
exit (VALUE (x));
}
#if !MES_MINI
SCM
frame_printer (SCM frame)
{
@ -349,7 +370,6 @@ stack_ref (SCM stack, SCM index)
SCM frames = struct_ref_ (stack, 3);
return vector_ref (frames, index);
}
#endif // !MES_MINI
SCM
xassq (SCM x, SCM a) ///for speed in core only
@ -372,8 +392,9 @@ memq (SCM x, SCM a)
}
else if (t == TKEYWORD)
{
SCM v = STRING (x);
while (a != cell_nil && v != STRING (CAR (a)))
while (a != cell_nil
&& (TYPE (CAR (a)) != TKEYWORD
|| string_equal_p (x, CAR (a)) == cell_f))
a = CDR (a);
}
else
@ -399,11 +420,7 @@ equal2_p (SCM a, SCM b)
return cell_f;
}
if (TYPE (a) == TSTRING && TYPE (b) == TSTRING)
{
a = STRING (a);
b = STRING (b);
goto equal2;
}
return string_equal_p (a, b);
if (TYPE (a) == TVECTOR && TYPE (b) == TVECTOR)
{
if (LENGTH (a) != LENGTH (b))

1044
src/mes.c
View file

File diff suppressed because it is too large Load diff

3
src/module.c
View file

@ -20,6 +20,7 @@
SCM struct_ref_ (SCM x, long i);
SCM struct_set_x_ (SCM x, long i, SCM e);
SCM cstring_to_symbol (char const *s);
SCM
make_module_type () ///(internal))
@ -101,7 +102,7 @@ module_variable (SCM module, SCM name)
SCM
module_ref (SCM module, SCM name)
{
if (g_debug > 4)
if (g_debug > 3)
{
eputs ("module_ref: "); display_error_ (name); eputs ("\n");
}

105
src/posix.c
View file

@ -40,7 +40,12 @@ peekchar ()
return c;
}
SCM port = current_input_port ();
return VALUE (CAR (STRING (port)));
SCM string = STRING (port);
size_t length = LENGTH (string);
if (!length)
return -1;
char const *p = CSTRING (string);
return p[0];
}
int
@ -50,10 +55,12 @@ readchar ()
return fdgetc (g_stdin);
SCM port = current_input_port ();
SCM string = STRING (port);
if (string == cell_nil)
size_t length = LENGTH (string);
if (!length)
return -1;
int c = VALUE (CAR (string));
STRING (port) = CDR (string);
char const *p = CSTRING (string);
int c = *p++;
STRING (port) = make_string (p, length-1);
return c;
}
@ -63,7 +70,14 @@ unreadchar (int c)
if (g_stdin >= 0)
return fdungetc (c, g_stdin);
SCM port = current_input_port ();
STRING (port) = cons (MAKE_CHAR (c), STRING (port));
SCM string = STRING (port);
size_t length = LENGTH (string);
char *p = CSTRING (string);
p--;
string = make_string (p, length+1);
p = CSTRING (string);
p[0] = c;
STRING (port) = string;
return c;
}
@ -117,27 +131,6 @@ write_char (SCM i) ///((arity . n))
return i;
}
SCM
read_string (SCM port) ///((arity . n))
{
int fd = g_stdin;
if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
g_stdin = VALUE (CAR (port));
gc_push_frame ();
r0 = cell_nil;
r1 = read_char (cell_nil);
while (VALUE (r1) != -1)
{
r0 = cons (r1, r0);
r1 = read_char (cell_nil);
gc_check ();
}
g_stdin = fd;
SCM lst = MAKE_STRING (reverse_x_ (r0, cell_nil));
gc_pop_frame ();
return lst;
}
SCM
write_byte (SCM x) ///((arity . n))
{
@ -156,48 +149,27 @@ write_byte (SCM x) ///((arity . n))
return c;
}
char string_to_cstring_buf[4096];
char const*
string_to_cstring_ (SCM s, char *buf)
{
char *p = buf;
s = STRING(s);
while (s != cell_nil)
{
*p++ = VALUE (car (s));
s = cdr (s);
}
*p = 0;
return buf;
}
char const*
string_to_cstring (SCM s)
{
return string_to_cstring_ (s, string_to_cstring_buf);
}
SCM
getenv_ (SCM s) ///((name . "getenv"))
{
char *p;
p = getenv (string_to_cstring (s));
return p ? MAKE_STRING (cstring_to_list (p)) : cell_f;
p = getenv (CSTRING (s));
return p ? MAKE_STRING0 (p) : cell_f;
}
SCM
setenv_ (SCM s, SCM v) ///((name . "setenv"))
{
char buf[1024];
strcpy (buf, string_to_cstring (s));
setenv (buf, string_to_cstring (v), 1);
strcpy (buf, CSTRING (s));
setenv (buf, CSTRING (v), 1);
return cell_unspecified;
}
SCM
access_p (SCM file_name, SCM mode)
{
return access (string_to_cstring (file_name), VALUE (mode)) == 0 ? cell_t : cell_f;
return access (CSTRING (file_name), VALUE (mode)) == 0 ? cell_t : cell_f;
}
SCM
@ -206,6 +178,10 @@ current_input_port ()
if (g_stdin >= 0)
return MAKE_NUMBER (g_stdin);
SCM x = g_ports;
if (g_debug > 2)
{
eputs ("ports:"); write_error_ (g_ports); eputs ("\n");
}
while (x && PORT (CAR (x)) != g_stdin)
x = CDR (x);
return CAR (x);
@ -214,13 +190,17 @@ current_input_port ()
SCM
open_input_file (SCM file_name)
{
return MAKE_NUMBER (open (string_to_cstring (file_name), O_RDONLY));
return MAKE_NUMBER (open (CSTRING (file_name), O_RDONLY));
}
SCM
open_input_string (SCM string)
{
SCM port = MAKE_STRING_PORT (STRING (string));
SCM port = MAKE_STRING_PORT (string);
if (g_debug > 2)
{
eputs ("new port:"); write_error_ (port); eputs ("\n");
}
g_ports = cons (port, g_ports);
return port;
}
@ -256,7 +236,7 @@ open_output_file (SCM x) ///((arity . n))
int mode = S_IRUSR|S_IWUSR;
if (TYPE (x) == TPAIR && TYPE (car (x)) == TNUMBER)
mode = VALUE (car (x));
return MAKE_NUMBER (open (string_to_cstring (file_name), O_WRONLY|O_CREAT|O_TRUNC,mode));
return MAKE_NUMBER (open (CSTRING (file_name), O_WRONLY|O_CREAT|O_TRUNC,mode));
}
SCM
@ -282,7 +262,7 @@ force_output (SCM p) ///((arity . n))
SCM
chmod_ (SCM file_name, SCM mode) ///((name . "chmod"))
{
chmod (string_to_cstring (file_name), VALUE (mode));
chmod (CSTRING (file_name), VALUE (mode));
return cell_unspecified;
}
@ -303,20 +283,17 @@ execl_ (SCM file_name, SCM args) ///((name . "execl"))
{
char *c_argv[1000]; // POSIX minimum 4096
int i = 0;
int n = 0;
if (length__ (args) > 1000)
error (cell_symbol_system_error,
cons (file_name,
cons (MAKE_STRING (cstring_to_list ("too many arguments")),
cons (MAKE_STRING0 ("too many arguments"),
cons (file_name, args))));
c_argv[i++] = (char*)string_to_cstring_ (file_name, string_to_cstring_buf+n);
n += length__ (STRING (file_name)) + 1;
c_argv[i++] = CSTRING (file_name);
while (args != cell_nil)
{
assert (TYPE (CAR (args)) == TSTRING);
c_argv[i++] = (char*)string_to_cstring_ (CAR (args), string_to_cstring_buf+n);
n += length__ (STRING (CAR (args))) + 1;
c_argv[i++] = CSTRING (CAR (args));
args = CDR (args);
if (g_debug > 2)
{
@ -386,7 +363,7 @@ SCM
getcwd_ () ///((name . "getcwd"))
{
char buf[PATH_MAX];
return MAKE_STRING (cstring_to_list (getcwd (buf, PATH_MAX)));
return MAKE_STRING0 (getcwd (buf, PATH_MAX));
}
SCM
@ -405,6 +382,6 @@ dup2_ (SCM old, SCM new) ///((name . "dup2"))
SCM
delete_file (SCM file_name)
{
unlink (string_to_cstring (file_name));
unlink (CSTRING (file_name));
return cell_unspecified;
}

66
src/reader.c
View file

@ -21,8 +21,6 @@
#include <ctype.h>
#define MAX_STRING 4096
SCM
read_input_file_env_ (SCM e, SCM a)
{
@ -49,7 +47,7 @@ reader_read_line_comment (int c)
c = readchar ();
}
error (cell_symbol_system_error,
MAKE_STRING (cstring_to_list ("reader_read_line_comment")));
MAKE_STRING0 ("reader_read_line_comment"));
}
SCM reader_read_block_comment (int s, int c);
@ -176,7 +174,7 @@ reader_read_list (int c, SCM a)
if (c == ')')
return cell_nil;
if (c == EOF)
error (cell_symbol_not_a_pair, MAKE_STRING (cstring_to_list ("EOF in list")));
error (cell_symbol_not_a_pair, MAKE_STRING0 ("EOF in list"));
//return cell_nil;
SCM s = reader_read_sexp_ (c, a);
if (s == cell_dot)
@ -233,7 +231,14 @@ reader_read_hash (int c, SCM a)
return cons (cell_symbol_quasisyntax,
cons (reader_read_sexp_ (readchar (), a), cell_nil));
if (c == ':')
return MAKE_KEYWORD (CAR (reader_read_sexp_ (readchar (), a)));
{
SCM x = reader_read_identifier_or_number (readchar ());
if (TYPE (x) == TNUMBER)
error (cell_symbol_system_error, // READ error
cons (MAKE_STRING0 ("keyword perifx ':' not followed by a symbol: "),
x));
return symbol_to_keyword (x);
}
if (c == 'b')
return reader_read_binary ();
if (c == 'o')
@ -275,6 +280,16 @@ reader_read_character ()
p = peekchar ();
}
}
else if (c == 'x'
&& ((p >= '0' && p <= '9')
|| (p >= 'a' && p <= 'f')
|| (p >= 'F' && p <= 'F')))
{
c = VALUE (reader_read_hex ());
eputs ("reading hex c=");
eputs (itoa (c));
eputs ("\n");
}
else if (((c >= 'a' && c <= 'z')
|| c == '*')
&& ((p >= 'a' && p <= 'z')
@ -330,7 +345,7 @@ reader_read_character ()
eputs (buf);
eputs ("\n");
error (cell_symbol_system_error,
MAKE_STRING (cstring_to_list ("char not supported")));
MAKE_STRING0 ("char not supported"));
}
}
return MAKE_CHAR (c);
@ -418,10 +433,12 @@ reader_read_hex ()
SCM
reader_read_string ()
{
SCM lst = cell_nil;
char buf[MAX_STRING];
size_t i = 0;
int c;
do
{
assert (i < MAX_STRING);
c = readchar ();
if (c == '"')
break;
@ -429,40 +446,37 @@ reader_read_string ()
{
c = readchar ();
if (c == '\\' || c == '"')
lst = cons (MAKE_CHAR (c), lst);
;
else if (c == '0')
lst = cons (MAKE_CHAR ('\0'), lst);
c = '\0';
else if (c == 'a')
lst = cons (MAKE_CHAR ('\a'), lst);
c = '\a';
else if (c == 'b')
lst = cons (MAKE_CHAR ('\b'), lst);
c = '\b';
else if (c == 't')
lst = cons (MAKE_CHAR ('\t'), lst);
c = '\t';
else if (c == 'n')
lst = cons (MAKE_CHAR ('\n'), lst);
c = '\n';
else if (c == 'v')
lst = cons (MAKE_CHAR ('\v'), lst);
c = '\v';
else if (c == 'f')
lst = cons (MAKE_CHAR ('\f'), lst);
c = '\f';
else if (c == 'r')
// Nyacc bug
// lst = cons (MAKE_CHAR ('\r'), lst);
lst = cons (MAKE_CHAR (13), lst);
// c = '\r';
c = 13;
else if (c == 'e')
// Nyacc bug
// lst = cons (MAKE_CHAR ('\e'), lst);
lst = cons (MAKE_CHAR (27), lst);
// c = '\e';
c = 27;
else if (c == 'x')
{
SCM x = reader_read_hex ();
lst = cons (MAKE_CHAR (VALUE (x)), lst);
}
c = VALUE (reader_read_hex ());
}
else
lst = cons (MAKE_CHAR (c), lst);
buf[i++] = c;
}
while (1);
return MAKE_STRING (reverse_x_ (lst, cell_nil));
buf[i] = 0;
return make_string (buf, i);
}
int g_tiny = 0;

242
src/strings.c Normal file
View file

@ -0,0 +1,242 @@
/* -*-comment-start: "//";comment-end:""-*-
* GNU Mes --- Maxwell Equations of Software
* Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
*
* This file is part of GNU Mes.
*
* GNU Mes is free software; you can redistribute it and/or modify it
* under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 3 of the License, or (at
* your option) any later version.
*
* GNU Mes is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
*/
#define MAX_STRING 4096
char const*
list_to_cstring (SCM list, size_t* size)
{
static char buf[MAX_STRING];
size_t i = 0;
char *p = buf;
while (list != cell_nil)
{
assert (i < MAX_STRING);
buf[i++] = VALUE (car (list));
list = cdr (list);
}
buf[i] = 0;
*size = i;
return buf;
}
size_t
bytes_cells (size_t length)
{
return (1 + sizeof (long) + sizeof (long) + length + sizeof (SCM)) / sizeof (SCM);
}
SCM
make_bytes (char const* s, size_t length)
{
size_t size = bytes_cells (length);
SCM x = alloc (size);
TYPE (x) = TBYTES;
LENGTH (x) = length;
char *p = &g_cells[x].cdr;
if (!length)
*(char*)p = 0;
else
memcpy (p, s, length + 1);
if (g_debug > 2)
{
eputs ("make bytes: "); eputs (s); eputs ("\n");
eputs (" bytes: "); eputs (CBYTES (x)); eputs ("\n");
eputs (" length: "); eputs (itoa (length)); eputs ("\n");
eputs (" ==> "); write_error_ (x);
eputs ("\n");
}
return x;
}
SCM
make_string (char const* s, size_t length)
{
assert (length < HALFLONG_MAX);
SCM x = make_cell__ (TSTRING, length, 0);
SCM v = make_bytes (s, length);
CDR (x) = v;
return x;
}
SCM
string_equal_p (SCM a, SCM b) ///((name . "string=?"))
{
if (! ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
|| (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD)))
{
eputs ("type a: "); eputs (itoa (TYPE (a))); eputs ("\n");
eputs ("type b: "); eputs (itoa (TYPE (b))); eputs ("\n");
eputs ("a= "); write_error_ (a); eputs ("\n");
eputs ("b= "); write_error_ (b); eputs ("\n");
assert ((TYPE (a) == TSTRING && TYPE (b) == TSTRING)
|| (TYPE (a) == TKEYWORD || TYPE (b) == TKEYWORD));
}
if (g_debug == -1)
{
eputs ("string=?: "); eputs (CSTRING (a));
eputs (" =? "); eputs (CSTRING (b));
}
if (a == b
|| STRING (a) == STRING (b)
|| (!LENGTH (a) && !LENGTH (b))
|| (LENGTH (a) == LENGTH (b)
&& !memcmp (CSTRING (a), CSTRING (b), LENGTH (a))))
{
if (g_debug == -1)
eputs (" => #t\n");
return cell_t;
}
if (g_debug == -1)
eputs (" => #f\n");
return cell_f;
}
SCM
symbol_to_string (SCM symbol)
{
SCM x = make_cell__ (TSTRING, CAR (symbol), CDR (symbol));
if (g_debug > 2)
{
eputs ("symbol->string: "); eputs (CSTRING (x)); eputs ("\n");
eputs (" was: "); write_error_ (symbol);
eputs ("==> "); write_error_ (x);
eputs ("\n");
}
return x;
}
SCM
symbol_to_keyword (SCM symbol)
{
SCM x = make_cell__ (TKEYWORD, CAR (symbol), CDR (symbol));
if (g_debug > 2)
{
eputs ("symbol->keyword: "); eputs (CSTRING (x)); eputs ("\n");
eputs (" was: "); write_error_ (symbol);
eputs ("==> "); write_error_ (x);
eputs ("\n");
}
return x;
}
SCM
keyword_to_string (SCM keyword)
{
SCM x = make_cell__ (TSTRING, CAR (keyword), CDR (keyword));
if (g_debug > 2)
{
eputs ("keyword->string: "); eputs (CSTRING (x)); eputs ("\n");
eputs (" was: "); write_error_ (keyword);
eputs ("==> "); write_error_ (x);
eputs ("\n");
}
return x;
}
SCM
string_to_symbol (SCM string)
{
SCM x = hash_ref (g_symbols, string, cell_f);
if (x == cell_f)
x = make_symbol (string);
return x;
}
SCM
make_symbol (SCM string)
{
SCM x = make_cell__ (TSYMBOL, LENGTH (string), STRING (string));
hash_set_x (g_symbols, string, x);
if (g_debug > 3)
hash_table_printer (g_symbols);
if (g_debug > 2)
{
eputs ("make_symbol: "); eputs (CSTRING (string)); eputs ("\n");
eputs ("==> "); write_error_ (x);
eputs ("\n");
}
return x;
}
SCM
bytes_to_list (char const* s, size_t i)
{
SCM p = cell_nil;
while (i--)
{
int c = (0x100 + s[i]) % 0x100;
p = cons (MAKE_CHAR (c), p);
}
return p;
}
SCM
cstring_to_list (char const* s)
{
return bytes_to_list (s, strlen (s));
}
SCM
cstring_to_symbol (char const *s)
{
SCM string = MAKE_STRING0 (s);
return string_to_symbol (string);
}
SCM
string_to_list (SCM string)
{
return bytes_to_list (CSTRING (string), LENGTH (string));
}
SCM
list_to_string (SCM list)
{
size_t size;
char const *s = list_to_cstring (list, &size);
return make_string (s, size);
}
SCM
read_string (SCM port) ///((arity . n))
{
int fd = g_stdin;
if (TYPE (port) == TPAIR && TYPE (car (port)) == TNUMBER)
g_stdin = VALUE (CAR (port));
int c = readchar ();
static char buf[MAX_STRING];
size_t i = 0;
while (c != -1)
{
assert (i < MAX_STRING);
buf[i++] = c;
c = readchar ();
}
buf[i] = 0;
g_stdin = fd;
return make_string (buf, i);
}

12
tests/base.test
View file

@ -1,6 +1,9 @@
#! /bin/sh
# -*-scheme-*-
exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests base)' -s "$0" "$@"
if [ "$MES" != guile ]; then
MES_BOOT=boot-03.scm exec ${MES-mes} < $0
fi
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
!#
;;; -*-scheme-*-
@ -27,7 +30,12 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes test))
(cond-expand
(mes
(primitive-load "module/mes/test.scm"))
(guile-2)
(guile
(use-modules (ice-9 syncase))))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

5
tests/boot.test
View file

@ -1,10 +1,7 @@
#! /bin/sh
# -*-scheme-*-
if [ "$MES" != guile ]; then
export MES_BOOT=boot-02.scm
MES=${MES-$(dirname $0)/../src/mes}
$MES < $0
exit $?
MES_BOOT=boot-02.scm exec ${MES-mes} < $0
fi
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
!#

12
tests/macro.test
View file

@ -57,19 +57,9 @@ exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests macr
;; type-0.mes
(define (string . lst)
(core:make-cell <cell:string> lst 0))
(define (string->symbol s)
(if (not (pair? (core:car s))) '()
(list->symbol (core:car s))))
(define (symbol->list s)
(core:car s))
(list->string lst))
;; boot-0.scm
(define (symbol->string s)
(apply string (symbol->list s)))
(define (string-append . rest)
(apply string (apply append (map1 string->list rest))))

28
tests/optargs.test
View file

@ -24,7 +24,7 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests optargs)
#:use-module (ice-9 optargs)
#:use-module (mes optargs)
#:use-module (mes mes-0)
#:use-module (mes test))
@ -71,15 +71,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
(cons <locals> locals)
(cons <text> text)))
;; (define* (make o #:key (functions '()) (globals '()) (locals '()) (text '()))
;; (format (current-error-port) "make\n")
;; ((cond ((info? o)
;; (list <info>
;; (cons <functions> functions)
;; (cons <globals> globals)
;; (cons <locals> locals)
;; (cons <text> text))))))
(define (.functions o)
(assq-ref (cdr o) <functions>))
@ -95,23 +86,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
(define (info? o)
(and (pair? o) (eq? (car o) <info>)))
;; FIXME: psyntax+pmatch+optarg is broken; BINDINGS-> (g1234 g1234)
;; iso (function function)
;; (define (clone o . rest)
;; (pmatch o
;; ((<info>
;; (<functions> . ,functions)
;; (<globals> . ,globals)
;; (<locals> . ,locals)
;; (<text> . ,text))
;; (let-keywords rest
;; #f
;; ((functions functions)
;; (globals globals)
;; (locals locals)
;; (text text))
;; (make <info> #:functions functions #:globals globals #:locals locals #:text text)))))
(define (clone o . rest)
(cond ((info? o)
(let ((functions (.functions o))

3
tests/perform.test
View file

@ -1,9 +1,8 @@
#! /bin/sh
# -*-scheme-*-
if [ "$MES" != guile ]; then
export MES_BOOT=boot-02.scm
MES=${MES-$(dirname $0)/../src/mes}
$MES < $0
MES_BOOT=boot-02.scm exec $MES < $0
exit $?
fi
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests perform)' -s "$0" "$@"

40
tests/posix.test Executable file
View file

@ -0,0 +1,40 @@
#! /bin/sh
# -*-scheme-*-
exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests srfi-13)' -s "$0" "$@"
!#
;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests srfi-13)
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (srfi srfi-13))
(mes-use-module (mes test))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)
(pass-if-eq "system*" 0 (system* "true"))
(pass-if-eq "system*" 256 (system* "false"))
(result 'report)

14
tests/quasiquote.test
View file

@ -1,6 +1,9 @@
#! /bin/sh
# -*-scheme-*-
exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests quasiquote)' -s "$0" "$@"
if [ "$MES" != guile ]; then
MES_BOOT=boot-03.scm exec ${MES-mes} < $0
fi
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
!#
;;; -*-scheme-*-
@ -27,9 +30,12 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes base))
(mes-use-module (mes quasiquote))
(mes-use-module (mes test))
(cond-expand
(mes
(primitive-load "module/mes/test.scm"))
(guile-2)
(guile
(use-modules (ice-9 syncase))))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)

7
tests/read.test
View file

@ -22,9 +22,12 @@
# You should have received a copy of the GNU General Public License
# along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
if [ "$MES" != guile ]; then
MES=${MES-$(dirname $0)/../src/mes}
MES_BOOT=boot-02.scm exec $MES < $0
fi
MES=${MES-$(dirname $0)/../src/mes}
exec $MES -s $0
exec ${MES-mes} --no-auto-compile -s $0
!#
0

30
tests/scm.test
View file

@ -1,6 +1,9 @@
#! /bin/sh
# -*-scheme-*-
exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests scm)' -s "$0" "$@"
if [ "$MES" != guile ]; then
MES_BOOT=boot-03.scm exec ${MES-mes} < $0
fi
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -s "$0" "$@"
!#
;;; -*-scheme-*-
@ -27,9 +30,12 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
#:use-module (mes mes-0)
#:use-module (mes test))
(mes-use-module (mes scm))
(mes-use-module (srfi srfi-0))
(mes-use-module (mes test))
(cond-expand
(mes
(primitive-load "module/mes/test.scm"))
(guile-2)
(guile
(use-modules (ice-9 syncase))))
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)
@ -125,22 +131,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
(pass-if-equal "iota -1"
'() (iota -1))
(pass-if-equal "reverse" '(3 2 1)
(reverse '(1 2 3)))
(pass-if-equal "reverse fresh" '(1 2 3)
(let ((list '(1 2 3)))
(reverse list)
list))
(pass-if-equal "reverse!" '(1)
(let ((list '(1 2 3)))
(reverse! list)
list))
(pass-if-equal "reverse! ()" '()
(reverse! '()))
(pass-if "cond-expand" (sequal? (cond-expand (foobar #f) (mes (display ": pass: *YAY*") 'mes) (guile (display ": pass: *GUILE*") 'mes)) 'mes))
(pass-if "apply identity" (seq? (apply identity '(0)) 0))

37
tests/srfi-13.test
View file

@ -33,9 +33,17 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
(pass-if "first dummy" #t)
(pass-if-not "second dummy" #f)
(pass-if "string=?"
(string=? "foo" "foo"))
(pass-if "string=?"
(let ((empty ""))
(string=? "" empty)))
(pass-if-equal "string-join"
"foo bar"
(string-join '("foo" "bar")))
"foo bar"
(string-join '("foo" "bar")))
(pass-if-equal "string-join infix"
"foo+bar"
@ -73,6 +81,15 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
(pass-if-equal "number->string INT-MIN" "-2147483648" (number->string -2147483648))
(pass-if-equal "number->string" "-4" (number->string -4))
(pass-if-eq "string->list" #\A
(car (string->list "A")))
(pass-if-eq "string->list high" #\xff
(car (string->list (list->string (list (integer->char 255))))))
(pass-if-eq "string->list high" #xff
(char->integer (car (string->list (list->string (list (integer->char 255)))))))
(pass-if-equal "string-fold"
"oof"
(list->string (string-fold cons '() "foo")))
@ -108,4 +125,20 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
(pass-if-equal "string-replace" "fubar"
(string-replace "foobar" "u" 1 3))
(pass-if-equal "reverse" '(3 2 1)
(reverse '(1 2 3)))
(pass-if-equal "reverse fresh" '(1 2 3)
(let ((list '(1 2 3)))
(reverse list)
list))
(pass-if-equal "reverse!" '(1)
(let ((list '(1 2 3)))
(reverse! list)
list))
(pass-if-equal "reverse! ()" '()
(reverse! '()))
(result 'report (if (and (or #t (equal? %compiler "gnuc")) (equal? %arch "x86")) 1 0))

2
tests/srfi-14.test
View file

@ -47,6 +47,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
(char-set= (char-set #\a #\b #\c) (list->char-set '(#\a #\b #\c))))
(pass-if "string->char-set!"
(char-set= (char-set #\a #\b #\c #\d) (string->char-set! "d" (string->char-set "abc"))))
(char-set= (char-set #\a #\b #\c #\d) (string->char-set! "d" (string->char-set "abc"))))
(result 'report)