Compare commits
23 Commits
master
...
wip-locals
Author | SHA1 | Date |
---|---|---|
Jan Nieuwenhuizen | 9e00b76011 | |
Jan Nieuwenhuizen | e915bcf3a2 | |
Jan Nieuwenhuizen | 7290fe113e | |
Jan Nieuwenhuizen | c88529c625 | |
Jan Nieuwenhuizen | 684199d107 | |
Jan Nieuwenhuizen | 3092efa8aa | |
Jan Nieuwenhuizen | 828d12b475 | |
Jan Nieuwenhuizen | d07cd96f58 | |
Jan Nieuwenhuizen | 45429e6c97 | |
Jan Nieuwenhuizen | 1e09a1593e | |
Jan Nieuwenhuizen | 6a4bc4f78d | |
Jan Nieuwenhuizen | 9980de20e2 | |
Jan Nieuwenhuizen | 235047116b | |
Jan Nieuwenhuizen | 97a7989616 | |
Jan Nieuwenhuizen | 28a373c80e | |
Jan Nieuwenhuizen | d8baeeb9f8 | |
Jan Nieuwenhuizen | 9c8f8d0179 | |
Jan Nieuwenhuizen | bcb58f0326 | |
Jan Nieuwenhuizen | 479624fc82 | |
Jan Nieuwenhuizen | e5df8c575d | |
Jan Nieuwenhuizen | 2a99d6b20a | |
Jan Nieuwenhuizen | e9c6db6e10 | |
Jan Nieuwenhuizen | a199d2c3a0 |
|
@ -24,13 +24,7 @@ set -e
|
|||
. ${srcdest}build-aux/trace.sh
|
||||
|
||||
# native
|
||||
trace "SNARF gc.c" ${srcdest}build-aux/mes-snarf.scm src/gc.c
|
||||
trace "SNARF lib.c" ${srcdest}build-aux/mes-snarf.scm src/lib.c
|
||||
trace "SNARF math.c" ${srcdest}build-aux/mes-snarf.scm src/math.c
|
||||
trace "SNARF mes.c" ${srcdest}build-aux/mes-snarf.scm src/mes.c
|
||||
trace "SNARF posix.c" ${srcdest}build-aux/mes-snarf.scm src/posix.c
|
||||
trace "SNARF reader.c" ${srcdest}build-aux/mes-snarf.scm src/reader.c
|
||||
trace "SNARF vector.c" ${srcdest}build-aux/mes-snarf.scm src/vector.c
|
||||
sh ${srcdest}build-aux/snarf.sh
|
||||
|
||||
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc.sh lib/libmes
|
||||
sh ${srcdest}build-aux/cc.sh src/mes
|
||||
|
|
|
@ -27,23 +27,7 @@ LIBC=${LIBC-c}
|
|||
|
||||
##moduledir=${moduledir-${datadir}${datadir:+/}module}
|
||||
|
||||
# native
|
||||
# trace "SNARF gc.c" ${srcdest}build-aux/mes-snarf.scm src/gc.c
|
||||
# trace "SNARF lib.c" ${srcdest}build-aux/mes-snarf.scm src/lib.c
|
||||
# trace "SNARF math.c" ${srcdest}build-aux/mes-snarf.scm src/math.c
|
||||
# trace "SNARF mes.c" ${srcdest}build-aux/mes-snarf.scm src/mes.c
|
||||
# trace "SNARF posix.c" ${srcdest}build-aux/mes-snarf.scm src/posix.c
|
||||
# trace "SNARF reader.c" ${srcdest}build-aux/mes-snarf.scm src/reader.c
|
||||
# trace "SNARF vector.c" ${srcdest}build-aux/mes-snarf.scm src/vector.c
|
||||
|
||||
# cc32-mes
|
||||
trace "SNARF.mes gc.c" ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
|
||||
trace "SNARF.mes lib.c" ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
|
||||
trace "SNARF.mes math.c" ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
|
||||
trace "SNARF.mes mes.c" ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
|
||||
trace "SNARF.mes posix.c" ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
|
||||
trace "SNARF.mes reader.c" ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
|
||||
trace "SNARF.mes vector.c" ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
|
||||
sh ${srcdest}build-aux/snarf.sh --mes
|
||||
|
||||
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc32-mes.sh lib/linux/x86-mes-gcc/crt0
|
||||
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc32-mes.sh lib/linux/x86-mes-gcc/crt1
|
||||
|
|
|
@ -26,13 +26,7 @@ set -e
|
|||
LIBC=${LIBC-c}
|
||||
|
||||
# cc64-mes
|
||||
trace "SNARF.mes gc.c" ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
|
||||
trace "SNARF.mes lib.c" ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
|
||||
trace "SNARF.mes math.c" ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
|
||||
trace "SNARF.mes mes.c" ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
|
||||
trace "SNARF.mes posix.c" ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
|
||||
trace "SNARF.mes reader.c" ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
|
||||
trace "SNARF.mes vector.c" ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
|
||||
sh ${srcdest}build-aux/snarf.sh --mes
|
||||
|
||||
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc64-mes.sh lib/linux/x86_64-mes-gcc/crt0
|
||||
ARCHDIR=1 NOLINK=1 sh ${srcdest}build-aux/cc64-mes.sh lib/linux/x86_64-mes-gcc/crt1
|
||||
|
|
|
@ -128,13 +128,7 @@ ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-mes.sh lib/libc+gnu
|
|||
ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-mes.sh lib/libgetopt
|
||||
|
||||
MES_ARENA=${MES_ARENA-100000000}
|
||||
trace "SNARF.mes gc.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
|
||||
trace "SNARF.mes lib.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
|
||||
trace "SNARF.mes math.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
|
||||
trace "SNARF.mes mes.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
|
||||
trace "SNARF.mes posix.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
|
||||
trace "SNARF.mes reader.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
|
||||
trace "SNARF.mes vector.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
|
||||
sh ${srcdest}build-aux/snarf.sh --mes
|
||||
|
||||
if [ -n "$SEED" ]; then
|
||||
bash ${srcdest}build-aux/cc-mes.sh src/mes
|
||||
|
|
|
@ -123,13 +123,7 @@ ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-x86_64-mes.sh lib/libc+gnu
|
|||
ARCHDIR=1 NOLINK=1 bash ${srcdest}build-aux/cc-x86_64-mes.sh lib/libgetopt
|
||||
|
||||
MES_ARENA=${MES_ARENA-100000000}
|
||||
trace "SNARF.mes gc.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/gc.c
|
||||
trace "SNARF.mes lib.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/lib.c
|
||||
trace "SNARF.mes math.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/math.c
|
||||
trace "SNARF.mes mes.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/mes.c
|
||||
trace "SNARF.mes posix.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/posix.c
|
||||
trace "SNARF.mes reader.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/reader.c
|
||||
trace "SNARF.mes vector.c" ./pre-inst-env bash ${srcdest}build-aux/mes-snarf.scm --mes src/vector.c
|
||||
sh ${srcdest}build-aux/snarf.sh --mes
|
||||
|
||||
if [ -n "$SEED" ]; then
|
||||
bash ${srcdest}build-aux/cc-mes.sh src/mes
|
||||
|
|
|
@ -75,6 +75,8 @@ tests="
|
|||
2f-define-second.scm
|
||||
2f-define-second-lambda.scm
|
||||
2g-vector.scm
|
||||
2h-recurse-twice.scm
|
||||
2h-recurse-twice-cond.scm
|
||||
|
||||
30-capture.scm
|
||||
31-capture-define.scm
|
||||
|
@ -101,10 +103,10 @@ tests="
|
|||
49-macro-override.scm
|
||||
4a-define-macro-define-macro.scm
|
||||
4b-define-macro-define.scm
|
||||
4f-string-split.scm
|
||||
4c-quasiquote.scm
|
||||
4d-let-map.scm
|
||||
4e-let-global.scm
|
||||
4f-string-split.scm
|
||||
|
||||
50-primitive-load.scm
|
||||
51-module.scm
|
||||
|
|
|
@ -34,6 +34,8 @@ MES_ARENA=${MES_ARENA-100000000}
|
|||
tests="
|
||||
tests/boot.test
|
||||
tests/read.test
|
||||
tests/srfi-0.test
|
||||
tests/macro.test
|
||||
tests/base.test
|
||||
tests/quasiquote.test
|
||||
tests/let.test
|
||||
|
|
|
@ -146,8 +146,8 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes
|
|||
(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 (lookup_symbol_ (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f))
|
||||
(format #f "a = acons (lookup_symbol_ (scm_~a.car), ~a, a);\n\n" (function.name f) (function-cell-name f)))))
|
||||
(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)))))
|
||||
|
||||
(define (disjoin . predicates)
|
||||
(lambda (. arguments)
|
||||
|
|
|
@ -0,0 +1,39 @@
|
|||
#! /bin/sh
|
||||
|
||||
# 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/>.
|
||||
|
||||
set -e
|
||||
|
||||
. ${srcdest}build-aux/config.sh
|
||||
. ${srcdest}build-aux/trace.sh
|
||||
|
||||
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
|
|
@ -43,6 +43,7 @@ int isspace (int c);
|
|||
int isxdigit (int c);
|
||||
int _open3 (char const *file_name, int flags, int mask);
|
||||
int _open2 (char const *file_name, int flags);
|
||||
int oputc (int c);
|
||||
int oputs (char const* s);
|
||||
ssize_t write (int filedes, void const *buffer, size_t size);
|
||||
char *search_path (char const *file_name);
|
||||
|
|
|
@ -47,3 +47,4 @@
|
|||
#endif // POSIX
|
||||
|
||||
#include <mes/eputc.c>
|
||||
#include <mes/oputc.c>
|
||||
|
|
|
@ -0,0 +1,27 @@
|
|||
/* -*-comment-start: "//";comment-end:""-*-
|
||||
* 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/>.
|
||||
*/
|
||||
|
||||
#include <libmes.h>
|
||||
|
||||
int
|
||||
oputc (int c)
|
||||
{
|
||||
return fdputc (c, STDOUT);
|
||||
}
|
|
@ -30,7 +30,7 @@
|
|||
(define mes %version)
|
||||
|
||||
(define (defined? x)
|
||||
(assq x (current-module)))
|
||||
(module-variable (current-module) x))
|
||||
|
||||
(define (cond-expand-expander clauses)
|
||||
(if (defined? (car (car clauses)))
|
||||
|
@ -104,10 +104,6 @@
|
|||
(cons (quote or) (cdr x))))
|
||||
(car x)))))
|
||||
|
||||
(define-macro (module-define! module name value)
|
||||
;;(list 'define name value)
|
||||
#t)
|
||||
|
||||
(define-macro (mes-use-module module)
|
||||
#t)
|
||||
;; end boot-02.scm
|
||||
|
|
|
@ -20,7 +20,7 @@
|
|||
(define mes %version)
|
||||
|
||||
(define (defined? x)
|
||||
(assq x (current-module)))
|
||||
(module-variable (current-module) x))
|
||||
|
||||
(define (cond-expand-expander clauses)
|
||||
(if (defined? (car (car clauses)))
|
||||
|
|
|
@ -20,7 +20,7 @@
|
|||
(define mes %version)
|
||||
|
||||
(define (defined? x)
|
||||
(assq x (current-module)))
|
||||
(module-variable (current-module) x))
|
||||
|
||||
(define (cond-expand-expander clauses)
|
||||
(if (defined? (car (car clauses)))
|
||||
|
|
|
@ -30,7 +30,7 @@
|
|||
(define mes %version)
|
||||
|
||||
(define (defined? x)
|
||||
(assq x (current-module)))
|
||||
(module-variable (current-module) x))
|
||||
|
||||
(define (cond-expand-expander clauses)
|
||||
(if (defined? (car (car clauses)))
|
||||
|
@ -104,10 +104,6 @@
|
|||
(cons (quote or) (cdr x))))
|
||||
(car x)))))
|
||||
|
||||
(define-macro (module-define! module name value)
|
||||
;;(list 'define name value)
|
||||
#t)
|
||||
|
||||
(define-macro (mes-use-module module)
|
||||
#t)
|
||||
|
||||
|
|
|
@ -115,10 +115,13 @@
|
|||
((port? x)
|
||||
(display "#<port " port)
|
||||
(display (core:cdr x) port)
|
||||
(display " ")
|
||||
(display (core:car x) port)
|
||||
(display ">" port))
|
||||
((variable? x)
|
||||
(display "#<variable " port)
|
||||
(when (not (zero? (core:cdr x)))
|
||||
(display "*local* " port))
|
||||
(write (list->string (car (core:car x))) port)
|
||||
(display ">" port))
|
||||
((number? x)
|
||||
|
@ -142,6 +145,13 @@
|
|||
(if (keyword? x) (display "#:" port))
|
||||
(for-each (display-cut2 display-char <> port write?) (string->list x))
|
||||
(if (and (string? x) write?) (write-char #\" port)))
|
||||
((struct? x)
|
||||
(display "#<" port)
|
||||
(for-each (lambda (i)
|
||||
(let ((x (strut-ref x i)))
|
||||
(d x #f (if (= i 0) "" " "))))
|
||||
(iota (struct-length x)))
|
||||
(display ")" port))
|
||||
((vector? x)
|
||||
(display "#(" port)
|
||||
(for-each (lambda (i)
|
||||
|
@ -214,7 +224,7 @@
|
|||
((#\s) (write (car args) port))
|
||||
(else (display (car args) port)))
|
||||
(simple-format (cddr lst) (cdr args)))))))
|
||||
|
||||
|
||||
(if destination (simple-format lst rest)
|
||||
(with-output-to-string
|
||||
(lambda () (simple-format lst rest))))))
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; GNU Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Mes.
|
||||
;;;
|
||||
|
@ -24,39 +24,19 @@
|
|||
|
||||
(mes-use-module (mes scm))
|
||||
|
||||
|
||||
(define (sexp:define e a)
|
||||
(if (atom? (car (cdr e))) (cons (car (cdr e))
|
||||
(core:eval (car (cdr (cdr e))) a))
|
||||
(cons (car (car (cdr e)))
|
||||
(core:eval (cons (quote lambda)
|
||||
(cons (cdr (car (cdr e))) (cdr (cdr e)))) a))))
|
||||
|
||||
(define (f:env:define a+ a)
|
||||
(set-cdr! a+ (cdr a))
|
||||
(set-cdr! a a+)
|
||||
;;(set-cdr! (assq '*closure* a) a+)
|
||||
)
|
||||
|
||||
(define (env:escape-closure a n)
|
||||
(if (eq? (caar a) '*closure*) (if (= 0 n) a
|
||||
(env:escape-closure (cdr a) (- n 1)))
|
||||
(env:escape-closure (cdr a) n)))
|
||||
|
||||
(define-macro (module-define! name value a)
|
||||
`(f:env:define (cons (sexp:define (cons 'define (cons ',name (cons ,value '()))) ,a) '()) (env:escape-closure ,a 1)))
|
||||
|
||||
(define-macro (make-fluid . default)
|
||||
`(begin
|
||||
,(let ((fluid (symbol-append 'fluid: (gensym)))
|
||||
(module (current-module)))
|
||||
`(begin
|
||||
(module-define! ,fluid
|
||||
(let ((v ,(and (pair? default) (car default))))
|
||||
(lambda ( . rest)
|
||||
(if (null? rest) v
|
||||
(set! v (car rest))))) ',module)
|
||||
',fluid))))
|
||||
((lambda (fluid)
|
||||
`(begin
|
||||
(module-define!
|
||||
(boot-module)
|
||||
',fluid
|
||||
((lambda (v)
|
||||
(lambda ( . rest)
|
||||
(if (null? rest) v
|
||||
(set! v (car rest)))))
|
||||
,(and (pair? default) (car default))))
|
||||
',fluid))
|
||||
(symbol-append 'fluid: (gensym))))
|
||||
|
||||
(define (fluid-ref fluid)
|
||||
(fluid))
|
||||
|
@ -92,7 +72,7 @@
|
|||
`(let ,(map (lambda (b s) `(,s (,b))) (map car bindings) syms)
|
||||
,@(map (lambda (o) `(fluid-set! ,(car o) ,(cadr o))) bindings)
|
||||
(let ((r (begin ,@bodies)))
|
||||
`,@(map (lambda (b s) `(fluid-set! ,b ,s)) (map car bindings) syms)
|
||||
,@(map (lambda (b s) `(fluid-set! ,b ,s)) (map car bindings) syms)
|
||||
r))))
|
||||
|
||||
(define (dynamic-wind in-guard thunk out-guard)
|
||||
|
|
|
@ -27,6 +27,5 @@
|
|||
|
||||
(define datum->syntax datum->syntax-object)
|
||||
(define syntax->datum syntax-object->datum)
|
||||
(define-macro (portable-macro-expand) #t)
|
||||
(define-macro (portable-macro-expand) '(begin #t))
|
||||
(set! macro-expand sc-expand)
|
||||
|
||||
|
|
|
@ -136,7 +136,7 @@ along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|||
(define (quit . x)
|
||||
(exit 0))
|
||||
(define (use a)
|
||||
(lambda ()
|
||||
(lambda (. x)
|
||||
(let ((module (read)))
|
||||
(mes-load-module-env module a))))
|
||||
(define (meta command a)
|
||||
|
|
|
@ -37,6 +37,7 @@
|
|||
(cons <cell:ref> (quote <cell:ref>))
|
||||
(cons <cell:special> (quote <cell:special>))
|
||||
(cons <cell:string> (quote <cell:string>))
|
||||
(cons <cell:struct> (quote <cell:struct>))
|
||||
(cons <cell:symbol> (quote <cell:symbol>))
|
||||
(cons <cell:values> (quote <cell:values>))
|
||||
(cons <cell:variable> (quote <cell:variable>))
|
||||
|
@ -86,6 +87,9 @@
|
|||
(define (string? x)
|
||||
(eq? (core:type x) <cell:string>))
|
||||
|
||||
(define (struct? x)
|
||||
(eq? (core:type x) <cell:struct>))
|
||||
|
||||
(define (symbol? x)
|
||||
(eq? (core:type x) <cell:symbol>))
|
||||
|
||||
|
@ -119,14 +123,11 @@
|
|||
|
||||
(define (string->symbol s)
|
||||
(if (not (pair? (core:car s))) '()
|
||||
(core:lookup-symbol (core:car s))))
|
||||
(list->symbol (core:car s))))
|
||||
|
||||
(define (symbol->keyword s)
|
||||
(core:make-cell <cell:keyword> (symbol->list s) 0))
|
||||
|
||||
(define (list->symbol lst)
|
||||
(core:lookup-symbol lst))
|
||||
|
||||
(define (symbol->list s)
|
||||
(core:car s))
|
||||
|
||||
|
|
|
@ -0,0 +1,145 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; GNU Mes --- Maxwell Equations of Software
|
||||
;;; 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/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; srfi-9.mes - records, based on struct.
|
||||
|
||||
(define-macro (define-record-type name constructor+params predicate . fields)
|
||||
(let ((type (make-record-type name (map car fields))))
|
||||
`(begin
|
||||
(define ,name ,type)
|
||||
(define ,(car constructor+params) ,(record-constructor type name (cdr constructor+params)))
|
||||
(define ,predicate ,(record-predicate type))
|
||||
(define-record-accessors ,type ,@fields))))
|
||||
|
||||
(define (make-record-type type fields . printer)
|
||||
(let ((printer (if (pair? printer) (car printer))))
|
||||
(make-struct '<record-type> (cons type (list fields)) printer)))
|
||||
|
||||
(define (record-type? o)
|
||||
(eq? (struct-vtable o) '<record-type>))
|
||||
|
||||
(define (struct-vtable o)
|
||||
(struct-ref o 0))
|
||||
|
||||
(define (record-type o)
|
||||
(struct-ref o 2))
|
||||
|
||||
(define (record-predicate type)
|
||||
(lambda (o)
|
||||
(and (record? o)
|
||||
(eq? (record-type o) (record-type type)))))
|
||||
|
||||
(define (record? o)
|
||||
(and (struct? o)
|
||||
(record-type? (struct-vtable o))))
|
||||
|
||||
(define (record-constructor type name params)
|
||||
(let ((fields (record-fields type))
|
||||
(record-type (record-type type)))
|
||||
(lambda (. o)
|
||||
(if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
|
||||
(let ((rest (make-list (- (length fields) (length params)))))
|
||||
(make-struct type (cons name (append o rest)) record-printer))))))
|
||||
|
||||
(define record-printer *unspecified*) ; TODO
|
||||
(define (record-printer o)
|
||||
(display "#<")
|
||||
(display (record-type o))
|
||||
(let* ((vtable (struct-vtable o))
|
||||
(fields (record-fields vtable)))
|
||||
(for-each (lambda (field)
|
||||
(display " ")
|
||||
(display field)
|
||||
(display ": ")
|
||||
(display ((record-getter vtable field) o)))
|
||||
fields))
|
||||
(display ">"))
|
||||
|
||||
(define (record-fields o)
|
||||
(struct-ref o 3))
|
||||
|
||||
(define-macro (define-record-accessors type . fields)
|
||||
`(begin
|
||||
,@(map (lambda (field)
|
||||
`(define-record-accessor ,type ,field))
|
||||
fields)))
|
||||
|
||||
(define-macro (define-record-accessor type field)
|
||||
`(begin
|
||||
(define ,(cadr field) ,(record-getter type (car field)))
|
||||
(if ,(pair? (cddr field))
|
||||
(define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
|
||||
|
||||
(define (record-getter type field)
|
||||
(let ((i (record-field-index type field)))
|
||||
(lambda (o . field?)
|
||||
(if (not (eq? (record-type o) (record-type type))) (error "record getter: record expected" type o)
|
||||
(if (pair? field?) field
|
||||
(struct-ref o i))))))
|
||||
|
||||
(define (record-setter type field)
|
||||
(let ((i (record-field-index type field)))
|
||||
(lambda (o v)
|
||||
(if (not (eq? (record-type o) (record-type type))) (error "record setter: record expected" type o)
|
||||
(struct-set! o i v)))))
|
||||
|
||||
(define (record-field-index type field)
|
||||
(+ 3 (or (lst-index (record-fields type) field)
|
||||
(error "no such field" type field))))
|
||||
|
||||
(define (lst-index lst o)
|
||||
(let loop ((lst lst) (i 0))
|
||||
(and (pair? lst)
|
||||
(if (eq? o (car lst)) i
|
||||
(loop (cdr lst) (1+ i))))))
|
||||
|
||||
;; (define-record-type <employee>
|
||||
;; (make-employee name age salary)
|
||||
;; employee?
|
||||
;; (name employe-name)
|
||||
;; (age employee-age set-employee-age!)
|
||||
;; (salary employee-salary))
|
||||
|
||||
;; (display <employee>)
|
||||
;; (newline)
|
||||
|
||||
;; (display make-employee)
|
||||
;; (newline)
|
||||
;; (display "employee-age ")
|
||||
;; (display employee-age)
|
||||
;; (newline)
|
||||
|
||||
;; (display "set-employee-age! ")
|
||||
;; (display set-employee-age!)
|
||||
;; (newline)
|
||||
|
||||
;; (define janneke (make-employee "janneke" 49 42))
|
||||
;; (display janneke)
|
||||
;; (newline)
|
||||
|
||||
;; (display (employee-age janneke))
|
||||
;; (newline)
|
||||
|
||||
;; (display (set-employee-age! janneke 33))
|
||||
;; (newline)
|
||||
;; (display (employee-age janneke))
|
||||
;; (newline)
|
|
@ -0,0 +1,116 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; GNU Mes --- Maxwell Equations of Software
|
||||
;;; 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/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; srfi-9-vector.mes - records, based on vector
|
||||
|
||||
(define-macro (define-record-type type constructor+params predicate . fields)
|
||||
(let ((record (make-record-type type (map car fields))))
|
||||
`(begin
|
||||
(define ,type ,record)
|
||||
(define ,(car constructor+params) ,(record-constructor record (cdr constructor+params)))
|
||||
(define ,predicate ,(record-predicate record))
|
||||
(define-record-accessors ,record ,@fields))))
|
||||
|
||||
(define (make-record-type type fields)
|
||||
(list->vector (list '*record-type* type fields (length fields))))
|
||||
|
||||
(define (record-type? o)
|
||||
(eq? (record-type o) '*record-type*))
|
||||
|
||||
(define (record-type o)
|
||||
(vector-ref o 0))
|
||||
|
||||
(define (record-predicate type)
|
||||
(lambda (o)
|
||||
(and (vector? o)
|
||||
(eq? (record-type o) type))))
|
||||
|
||||
(define (record-constructor type params)
|
||||
(let ((fields (record-fields type)))
|
||||
(lambda (. o)
|
||||
(if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
|
||||
(let ((rest (make-list (- (length fields) (length params)))))
|
||||
(list->vector (cons type (append o rest))))))))
|
||||
|
||||
(define (record-fields o)
|
||||
(vector-ref o 2))
|
||||
|
||||
(define-macro (define-record-accessors type . fields)
|
||||
`(begin
|
||||
,@(map (lambda (field)
|
||||
`(define-record-accessor ,type ,field))
|
||||
fields)))
|
||||
|
||||
(define-macro (define-record-accessor type field)
|
||||
`(begin
|
||||
(define ,(cadr field) ,(record-getter type (car field)))
|
||||
(if ,(pair? (cddr field))
|
||||
(define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
|
||||
|
||||
(define (record-getter type field)
|
||||
(let ((i (record-field-index type field)))
|
||||
(lambda (o . field?)
|
||||
(if (not (eq? (record-type o) type)) (error "record getter: record expected" type o)
|
||||
(if (pair? field?) field
|
||||
(vector-ref o i))))))
|
||||
|
||||
(define (record-setter type field)
|
||||
(let ((i (record-field-index type field)))
|
||||
(lambda (o v)
|
||||
(if (not (eq? (record-type o) type)) (error "record setter: record expected" type o)
|
||||
(vector-set! o i v)))))
|
||||
|
||||
(define (record-field-index type field)
|
||||
(1+ (or (lst-index (record-fields type) field)
|
||||
(error "no such field" type field))))
|
||||
|
||||
(define (lst-index lst o)
|
||||
(let loop ((lst lst) (i 0))
|
||||
(and (pair? lst)
|
||||
(if (eq? o (car lst)) i
|
||||
(loop (cdr lst) (1+ i))))))
|
||||
|
||||
;; (define-record-type <employee> (make-employee name age salary) employee? (name employe-name) (age employee-age set-employee-age!) (salary employee-salary))
|
||||
|
||||
;; (display <employee>)
|
||||
;; (newline)
|
||||
;; (display make-employee)
|
||||
;; (newline)
|
||||
;; (display "employee-age ")
|
||||
;; (display employee-age)
|
||||
;; (newline)
|
||||
|
||||
;; (display "set-employee-age! ")
|
||||
;; (display set-employee-age!)
|
||||
;; (newline)
|
||||
|
||||
;; (define janneke (make-employee "janneke" 49 42))
|
||||
;; (display janneke)
|
||||
;; (newline)
|
||||
|
||||
;; (display (employee-age janneke))
|
||||
;; (newline)
|
||||
|
||||
;; (display (set-employee-age! janneke 33))
|
||||
;; (newline)
|
||||
;; (display (employee-age janneke))
|
||||
;; (newline)
|
|
@ -1,138 +0,0 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; GNU Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2017 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:
|
||||
|
||||
;;; srfi-9.mes - records.
|
||||
|
||||
(define (lst-index lst o)
|
||||
(let loop ((lst lst) (i 0))
|
||||
(and (pair? lst)
|
||||
(if (equal? o (car lst)) i
|
||||
(loop (cdr lst) (1+ i))))))
|
||||
|
||||
(define (make-record-type type fields)
|
||||
(list->vector (list '*record-type* type fields (length fields))))
|
||||
|
||||
(define (record-type o)
|
||||
(vector-ref o 0))
|
||||
|
||||
(define (record-type? o)
|
||||
(eq? (record-type o) '*record-type*))
|
||||
|
||||
(define (record-constructor type params)
|
||||
(let ((fields (record-fields type)))
|
||||
(lambda (. o)
|
||||
(if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
|
||||
(let ((rest (make-list (- (length fields) (length params)))))
|
||||
(list->vector (cons type (append o rest))))))))
|
||||
|
||||
(define (record-fields o)
|
||||
(vector-ref o 2))
|
||||
|
||||
(define (record-field-index type field)
|
||||
(1+ (or (lst-index (record-fields type) field)
|
||||
(error "no such field" type field))))
|
||||
|
||||
(define (record-getter type field)
|
||||
(let ((i (record-field-index type field)))
|
||||
(lambda (o . field?)
|
||||
(if (not (eq? (record-type o) type)) (error "record getter: record expected" type o)
|
||||
(if (pair? field?) field
|
||||
(vector-ref o i))))))
|
||||
|
||||
(define (record-setter type field)
|
||||
(let ((i (record-field-index type field)))
|
||||
(lambda (o v)
|
||||
(if (not (eq? (record-type o) type)) (error "record setter: record expected" type o)
|
||||
(vector-set! o i v)))))
|
||||
|
||||
(define (record-predicate type)
|
||||
(lambda (o)
|
||||
(and (vector? o)
|
||||
(eq? (record-type o) type))))
|
||||
|
||||
(define-macro (define-record-accessors type . fields)
|
||||
`(begin
|
||||
,@(map (lambda (field)
|
||||
`(define-record-accessor ,type ,field))
|
||||
fields)))
|
||||
|
||||
(define-macro (define-record-accessor type field)
|
||||
`(begin
|
||||
(define ,(cadr field) ,(record-getter type (car field)))
|
||||
(if ,(pair? (cddr field))
|
||||
(define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
|
||||
|
||||
(define-macro (define-record-type type constructor+params predicate . fields)
|
||||
(let ((record (make-record-type type (map car fields))))
|
||||
`(begin
|
||||
(define ,type ,record)
|
||||
(define ,(car constructor+params) ,(record-constructor record (cdr constructor+params)))
|
||||
(define ,predicate ,(record-predicate record))
|
||||
(define-record-accessors ,record ,@fields))))
|
||||
|
||||
;; (define-record-type cpi
|
||||
;; (make-cpi-1)
|
||||
;; cpi?
|
||||
;; (debug cpi-debug set-cpi-debug!) ; debug #t #f
|
||||
;; (defines cpi-defs set-cpi-defs!) ; #defines
|
||||
;; (incdirs cpi-incs set-cpi-incs!) ; #includes
|
||||
;; (inc-tynd cpi-itynd set-cpi-itynd!) ; a-l of incfile => typenames
|
||||
;; (inc-defd cpi-idefd set-cpi-idefd!) ; a-l of incfile => defines
|
||||
;; (ptl cpi-ptl set-cpi-ptl!) ; parent typename list
|
||||
;; (ctl cpi-ctl set-cpi-ctl!) ; current typename list
|
||||
;; (blev cpi-blev set-cpi-blev!) ; curr brace/block level
|
||||
;; )
|
||||
|
||||
;; (display cpi)
|
||||
;; (newline)
|
||||
;; (display make-cpi-1)
|
||||
;; (newline)
|
||||
;; (define cpi (make-cpi-1))
|
||||
;; (set-cpi-debug! cpi #t)
|
||||
;; (set-cpi-blev! cpi #t)
|
||||
|
||||
|
||||
;; (define-record-type <employee> (make-employee name age salary) employee? (name employe-name) (age employee-age set-employee-age!) (salary employee-salary))
|
||||
|
||||
;; (display <employee>)
|
||||
;; (newline)
|
||||
;; (display make-employee)
|
||||
;; (newline)
|
||||
;; (display "employee-age ")
|
||||
;; (display employee-age)
|
||||
;; (newline)
|
||||
|
||||
;; (display "set-employee-age! ")
|
||||
;; (display set-employee-age!)
|
||||
;; (newline)
|
||||
|
||||
;; (define janneke (make-employee "janneke" 49 42))
|
||||
;; (display janneke)
|
||||
;; (newline)
|
||||
|
||||
;; (display (employee-age janneke))
|
||||
;; (newline)
|
||||
|
||||
;; (display (set-employee-age! janneke 33))
|
||||
;; (newline)
|
||||
;; (display (employee-age janneke))
|
||||
;; (newline)
|
|
@ -0,0 +1 @@
|
|||
srfi-9-struct.mes
|
|
@ -0,0 +1,38 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; GNU Mes --- Maxwell Equations of Software
|
||||
;;; 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/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; srfi-9.mes - GNU immutable records.
|
||||
|
||||
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
|
||||
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
|
||||
|
||||
(define-macro (set-field o getters value)
|
||||
`(let ((getter ,(car getters)))
|
||||
(let* ((type (struct-vtable ,o))
|
||||
(name (record-type ,o))
|
||||
(set (getter ,o #t)))
|
||||
(define (field->value field)
|
||||
(if (eq? set field) ,value
|
||||
((record-getter type field) ,o)))
|
||||
(let* ((fields (record-fields type))
|
||||
(values (map field->value fields)))
|
||||
(apply (record-constructor type name fields) values)))))
|
|
@ -0,0 +1,37 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; GNU Mes --- Maxwell Equations of Software
|
||||
;;; 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/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; srfi-9.mes - GNU immutable records.
|
||||
|
||||
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
|
||||
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
|
||||
|
||||
(define-macro (set-field o getters value)
|
||||
`(let ((getter ,(car getters)))
|
||||
(let ((type (record-type ,o))
|
||||
(set (getter ,o #t)))
|
||||
(define (field->value field)
|
||||
(if (eq? set field) ,value
|
||||
((record-getter type field) ,o)))
|
||||
(let* ((fields (record-fields type))
|
||||
(values (map field->value fields)))
|
||||
(apply (record-constructor type fields) values)))))
|
|
@ -1,37 +0,0 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; GNU Mes --- Maxwell Equations of Software
|
||||
;;; 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/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; srfi-9.mes - GNU immutable records.
|
||||
|
||||
(define-macro (define-immutable-record-type type constructor+params predicate . fields)
|
||||
`(define-record-type ,type ,constructor+params ,predicate ,@(map (lambda (f) (list-head f 2)) fields)))
|
||||
|
||||
(define-macro (set-field o getters value)
|
||||
`(let ((getter ,(car getters)))
|
||||
(let ((type (record-type ,o))
|
||||
(set (getter ,o #t)))
|
||||
(define (field->value field)
|
||||
(if (eq? set field) ,value
|
||||
((record-getter type field) ,o)))
|
||||
(let* ((fields (record-fields type))
|
||||
(values (map field->value fields)))
|
||||
(apply (record-constructor type fields) values)))))
|
|
@ -0,0 +1 @@
|
|||
gnu-struct.mes
|
|
@ -22,7 +22,9 @@
|
|||
disjoin
|
||||
guile?
|
||||
mes?
|
||||
pk
|
||||
pke
|
||||
warn
|
||||
stderr
|
||||
string-substitute))
|
||||
|
||||
|
@ -43,6 +45,13 @@
|
|||
(define (stderr string . rest)
|
||||
(apply logf (cons* (current-error-port) string rest)))
|
||||
|
||||
(define (pk . stuff)
|
||||
(newline)
|
||||
(display ";;; ")
|
||||
(write stuff)
|
||||
(newline)
|
||||
(car (last-pair stuff)))
|
||||
|
||||
(define (pke . stuff)
|
||||
(newline (current-error-port))
|
||||
(display ";;; " (current-error-port))
|
||||
|
@ -50,6 +59,8 @@
|
|||
(newline (current-error-port))
|
||||
(car (last-pair stuff)))
|
||||
|
||||
(define warn pke)
|
||||
|
||||
(define (disjoin . predicates)
|
||||
(lambda (. arguments)
|
||||
(any (lambda (o) (apply o arguments)) predicates)))
|
||||
|
|
|
@ -87,7 +87,7 @@
|
|||
(dec->hex (quotient o #x100000000))))
|
||||
(string-append "%" (number->string (dec->hex (modulo o #x100000000)))
|
||||
" %" (if (< o 0) "-1"
|
||||
(number->string (dec->hex (quoteint o #x100000000)))))))
|
||||
(number->string (dec->hex (quotient o #x100000000)))))))
|
||||
|
||||
(define* (display-join o #:optional (sep ""))
|
||||
(let loop ((o o))
|
||||
|
|
|
@ -0,0 +1,50 @@
|
|||
;;; 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 display core:display)
|
||||
(define (newline) (core:display "\n"))
|
||||
(define (pair? x) (eq? (core:type x) <cell:pair>))
|
||||
(define (not x) (if x #f #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 (f x)
|
||||
(display "x=") (display x) (newline)
|
||||
(cond ((not (pair? x)) 'dun)
|
||||
(#t
|
||||
((lambda (h t)
|
||||
(list h t))
|
||||
(f (car x))
|
||||
(f (cdr x))))))
|
||||
|
||||
(display (f '(42)))
|
||||
(newline)
|
|
@ -0,0 +1,33 @@
|
|||
;;; 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 display core:display)
|
||||
(define (newline) (core:display "\n"))
|
||||
(define (pair? x) (eq? (core:type x) <cell:pair>))
|
||||
(define (not x) (if x #f #t))
|
||||
|
||||
(define (f x)
|
||||
(display "x=") (display x) (newline)
|
||||
(if (not (pair? x)) 'dun
|
||||
((lambda (h t)
|
||||
(list h t))
|
||||
(f (car x))
|
||||
(f (cdr x)))))
|
||||
|
||||
(display (f '(42)))
|
||||
(newline)
|
|
@ -55,51 +55,6 @@
|
|||
(if (eq? x (car lst)) lst
|
||||
(memq x (cdr lst)))))
|
||||
|
||||
;; (define (quasiquote-expand x)
|
||||
;; (core:display "quasiquote-expand x=") (core:display x) (core:display "\n")
|
||||
;; (cond ((null? x)
|
||||
;; (core:display "NULL\n")
|
||||
;; '())
|
||||
;; ((vector? x)
|
||||
;; (core:display "vector\n")
|
||||
;; (list 'list->vector (quasiquote-expand (vector->list x))))
|
||||
;; ((not (pair? x))
|
||||
;; (core:display "NOT a pair\n")
|
||||
;; (cons 'quote (cons x '())))
|
||||
;; ((eq? (car x) 'quasiquote) (quasiquote-expand (quasiquote-expand
|
||||
;; (if (null? (cddr x)) (cadr x)
|
||||
;; (cons 'list (cdr x))))))
|
||||
;; ((eq? (car x) 'unquote) (if (null? (cddr x)) (cadr x)
|
||||
;; (cons 'list (cdr x))))
|
||||
;; ((and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
|
||||
;; ((lambda (d)
|
||||
;; (if (null? (cddar x)) (list 'append (cadar x) d)
|
||||
;; (list 'quote (append (cdar x) d))))
|
||||
;; (quasiquote-expand (cdr x))))
|
||||
;; (else
|
||||
;; (core:display "ELSje\n")
|
||||
;; (core:display "CAR x=") (core:display (car x))
|
||||
;; (core:display "\n")
|
||||
;; (core:display "CDR x=") (core:display (cdr x))
|
||||
;; (core:display "\n")
|
||||
;; ((lambda (a d)
|
||||
;; (core:display " a=") (core:display a) (core:display "\n")
|
||||
;; (core:display " d=") (core:display d)
|
||||
|
||||
;; (if (pair? d)
|
||||
;; (if (eq? (car d) 'quote)
|
||||
;; (if (and (pair? a) (eq? (car a) 'quote))
|
||||
;; (list 'quote (cons (cadr a) (cadr d)))
|
||||
;; (if (null? (cadr d))
|
||||
;; (list 'list a)
|
||||
;; (list 'cons* a d)))
|
||||
;; (if (memq (car d) '(list cons*))
|
||||
;; (cons (car d) (cons a (cdr d)))
|
||||
;; (list 'cons* a d)))
|
||||
;; (list 'cons* a d)))
|
||||
;; (quasiquote-expand (car x))
|
||||
;; (list 'quasiquote-expand (list 'cdr x))))))
|
||||
|
||||
(define (caar x) (car (car x)))
|
||||
(define (cadr x) (car (cdr x)))
|
||||
(define (cdar x) (cdr (car x)))
|
||||
|
@ -111,7 +66,8 @@
|
|||
(define (quasiquote-expand x)
|
||||
(core:display "quasiquote-expand x=") (core:display x) (core:display "\n")
|
||||
(cond ((vector? x) (list 'list->vector (quasiquote-expand (vector->list x))))
|
||||
((not (pair? x)) (cons 'quote (cons x '())))
|
||||
((not (pair? x))
|
||||
(core:display "not pair!\n") (cons 'quote (cons x '())))
|
||||
((eq? (car x) 'quasiquote) (quasiquote-expand (quasiquote-expand
|
||||
(if (null? (cddr x)) (cadr x)
|
||||
(cons 'list (cdr x))))))
|
||||
|
@ -124,16 +80,17 @@
|
|||
(quasiquote-expand (cdr x))))
|
||||
(else
|
||||
(core:display "ELSje\n")
|
||||
(core:display "x=") (core:display x) (core:display "\n")
|
||||
(core:display "CAR x=") (core:display (car x))
|
||||
(core:display "\n")
|
||||
(core:display "CDR x=") (core:display (cdr x))
|
||||
(core:display "\n")
|
||||
((lambda (a d)
|
||||
(core:display "CAR a=") (core:display a)
|
||||
(core:display "a=") (core:display a)
|
||||
(core:display "\n")
|
||||
(core:display "CDR d=") (core:display d)
|
||||
(core:display "d=") (core:display d)
|
||||
(core:display "\n")
|
||||
|
||||
|
||||
(if (pair? d)
|
||||
(if (eq? (car d) 'quote)
|
||||
(if (and (pair? a) (eq? (car a) 'quote))
|
||||
|
@ -146,17 +103,7 @@
|
|||
(list 'cons* a d)))
|
||||
(list 'cons* a d)))
|
||||
(quasiquote-expand (car x))
|
||||
(quasiquote-expand (cdr x))
|
||||
))))
|
||||
(quasiquote-expand (cdr x))))))
|
||||
|
||||
(define-macro (quasiquote x)
|
||||
(quasiquote-expand x))
|
||||
|
||||
;; (define (remainder x y)
|
||||
;; (- x (* (/ x y) y)))
|
||||
;; (define (even? x)
|
||||
;; (eq? 0 (remainder x v2)))
|
||||
;; (pass-if-equal "qq 4" '#(10 5 #t #t #f #f #f 8)
|
||||
;; `#(10 5 ,(even? 4) ,@(map even? '(2 3 5 7)) 8))
|
||||
;;(core:display (quasiquote #(42)))
|
||||
(core:display (quasiquote-expand #(42)))
|
||||
(core:display "\n")
|
||||
|
|
|
@ -35,21 +35,11 @@
|
|||
(define-macro (simple-let bindings . rest)
|
||||
(cons (cons 'lambda (cons (map car bindings) rest))
|
||||
(map cadr bindings)))
|
||||
|
||||
;; (define-macro (xsimple-let bindings rest)
|
||||
;; `(,`(lambda ,(map car bindings) ,@rest)
|
||||
;; ,@(map cadr bindings)))
|
||||
|
||||
(define-macro (xsimple-let bindings rest)
|
||||
(cons* (cons* (quote lambda)
|
||||
(map car bindings) (append2 rest (quote ())))
|
||||
(append2 (map cadr bindings) (quote ()))))
|
||||
|
||||
;; (define-macro (xnamed-let name bindings rest)
|
||||
;; `(simple-let ((,name *unspecified*))
|
||||
;; (set! ,name (lambda ,(map car bindings) ,@rest))
|
||||
;; (,name ,@(map cadr bindings))))
|
||||
|
||||
(define-macro (xnamed-let name bindings rest)
|
||||
(list (quote simple-let)
|
||||
(list (cons* name (quote (*unspecified*))))
|
||||
|
@ -60,11 +50,6 @@
|
|||
(append2 rest (quote ()))))
|
||||
(cons* name (append2 (map cadr bindings) (quote ())))))
|
||||
|
||||
;; (define-macro (let bindings-or-name . rest)
|
||||
;; (if (symbol? bindings-or-name)
|
||||
;; `(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
|
||||
;; `(xsimple-let ,bindings-or-name ,rest)))
|
||||
|
||||
(define-macro (let bindings-or-name . rest)
|
||||
(if (symbol? bindings-or-name) (list (quote xnamed-let) bindings-or-name (car rest) (cdr rest))
|
||||
(list (quote xsimple-let) bindings-or-name rest)))
|
||||
|
@ -84,13 +69,6 @@
|
|||
(if (= 0 n) '()
|
||||
(cons (car x) (ss-list-head (cdr x) (- n 1)))))
|
||||
|
||||
;; (define (foo x y)
|
||||
;; (cons x y))
|
||||
|
||||
;; (define (ss-list-head x n)
|
||||
;; (if (= 0 n) '()
|
||||
;; (foo (car x) (ss-list-head (cdr x) (- n 1)))))
|
||||
|
||||
(define (string->list s)
|
||||
(core:car s))
|
||||
|
||||
|
|
|
@ -81,7 +81,7 @@
|
|||
(list 'load (list string-append %moduledir file)))
|
||||
|
||||
(define (string->symbol s)
|
||||
(core:lookup-symbol (core:car s)))
|
||||
(list->symbol (core:car s)))
|
||||
|
||||
(define (symbol->list s)
|
||||
(core:car s))
|
||||
|
|
|
@ -69,7 +69,7 @@
|
|||
;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (string->symbol s)
|
||||
(core:lookup-symbol (core:car s)))
|
||||
(list->symbol (core:car s)))
|
||||
|
||||
(define-macro (load file)
|
||||
(list 'primitive-load file))
|
||||
|
|
|
@ -28,7 +28,7 @@
|
|||
(if (null? lst) (list)
|
||||
(cons (f (car lst)) (map f (cdr lst)))))
|
||||
(define (closure x)
|
||||
(map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))))
|
||||
(map car (cdr (core:cdr (core:car (core:cdr (cdr (core:car (module-variable (current-module) 'x)))))))))))
|
||||
|
||||
(define (x t) #t)
|
||||
(define (xx x1 x2)
|
||||
|
|
|
@ -20,7 +20,7 @@
|
|||
(define mes %version)
|
||||
|
||||
(define (defined? x)
|
||||
(assq x (current-module)))
|
||||
(module-variable (current-module) x))
|
||||
|
||||
(define (cond-expand-expander clauses)
|
||||
(if (defined? (car (car clauses)))
|
||||
|
@ -139,35 +139,21 @@
|
|||
(if (eq? x (car lst)) lst
|
||||
(memq x (cdr lst)))))
|
||||
|
||||
;; (cond-expand
|
||||
;; (guile
|
||||
;; (define closure identity)
|
||||
;; (define body identity)
|
||||
;; (define append2 append)
|
||||
;; (define (core:apply f a m) (f a))
|
||||
;; )
|
||||
;; (mes
|
||||
(define <cell:symbol> 11)
|
||||
(define (symbol? x)
|
||||
(eq? (core:type x) <cell:symbol>))
|
||||
|
||||
(define (string->symbol s)
|
||||
(if (not (pair? (core:car s))) '()
|
||||
(core:lookup-symbol (core:car s))))
|
||||
(list->symbol (core:car s))))
|
||||
|
||||
(define <cell:string> 10)
|
||||
(define (string? x)
|
||||
(eq? (core:type x) <cell:string>))
|
||||
|
||||
|
||||
(define <cell:vector> 14)
|
||||
(define (vector? x)
|
||||
(eq? (core:type x) <cell:vector>))
|
||||
|
||||
;; (define (body x)
|
||||
;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module)))))))
|
||||
;; (define (closure x)
|
||||
;; (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))
|
||||
;; ))
|
||||
|
||||
(define (cons* . rest)
|
||||
(if (null? (cdr rest)) (car rest)
|
||||
|
@ -183,9 +169,7 @@
|
|||
(append2 (car rest) (apply append (cdr rest))))))
|
||||
|
||||
(define-macro (quasiquote x)
|
||||
;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n")
|
||||
(define (loop x)
|
||||
;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n")
|
||||
(if (vector? x) (list 'list->vector (loop (vector->list x)))
|
||||
(if (not (pair? x)) (cons 'quote (cons x '()))
|
||||
(if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
|
||||
|
@ -362,14 +346,14 @@
|
|||
(and (segment-template? pattern)
|
||||
(or (null? (cddr pattern))
|
||||
(syntax-error0 "segment matching not implemented" pattern))))
|
||||
|
||||
|
||||
(define (segment-template? pattern)
|
||||
(and (pair? pattern)
|
||||
(pair? (cdr pattern))
|
||||
(memq (cadr pattern) indicators-for-zero-or-more)))
|
||||
|
||||
|
||||
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
|
||||
|
||||
|
||||
(lambda (exp r c)
|
||||
|
||||
(define %input (r '%input)) ;Gensym these, if you like.
|
||||
|
@ -406,7 +390,7 @@
|
|||
0
|
||||
(meta-variables pattern 0 '())))))
|
||||
(syntax-error2 "ill-formed syntax rule" rule)))
|
||||
|
||||
|
||||
;; Generate code to test whether input expression matches pattern
|
||||
|
||||
(define (process-match input pattern)
|
||||
|
@ -427,7 +411,7 @@
|
|||
`((eq? ,input ',pattern)))
|
||||
(else
|
||||
`((equal? ,input ',pattern)))))
|
||||
|
||||
|
||||
(define (process-segment-match input pattern)
|
||||
;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
|
||||
;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n")
|
||||
|
@ -439,7 +423,7 @@
|
|||
(and (pair? l)
|
||||
,@conjuncts
|
||||
(loop (cdr l)))))))))
|
||||
|
||||
|
||||
;; Generate code to take apart the input expression
|
||||
;; This is pretty bad, but it seems to work (can't say why).
|
||||
|
||||
|
@ -560,5 +544,3 @@
|
|||
(if (not condition)
|
||||
(begin exp ...))))))
|
||||
(xwhen #f 42)))
|
||||
|
||||
|
||||
|
|
|
@ -52,32 +52,18 @@
|
|||
(if (eq? x (car lst)) lst
|
||||
(memq x (cdr lst)))))
|
||||
|
||||
;; (cond-expand
|
||||
;; (guile
|
||||
;; (define closure identity)
|
||||
;; (define body identity)
|
||||
;; (define append2 append)
|
||||
;; (define (core:apply f a m) (f a))
|
||||
;; )
|
||||
;; (mes
|
||||
(define (symbol? x)
|
||||
(eq? (core:type x) <cell:symbol>))
|
||||
|
||||
(define (string->symbol s)
|
||||
(if (not (pair? (core:car s))) '()
|
||||
(core:lookup-symbol (core:car s))))
|
||||
(list->symbol (core:car s))))
|
||||
|
||||
(define (string? x)
|
||||
(eq? (core:type x) <cell:string>))
|
||||
|
||||
|
||||
(define (vector? x)
|
||||
(eq? (core:type x) <cell:vector>))
|
||||
|
||||
;; (define (body x)
|
||||
;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module)))))))
|
||||
;; (define (closure x)
|
||||
;; (map car (cdr (core:cdr (core:car (core:cdr (cdr (assq 'x (current-module)))))))))
|
||||
;; ))
|
||||
|
||||
(define (cons* . rest)
|
||||
(if (null? (cdr rest)) (car rest)
|
||||
|
@ -93,9 +79,7 @@
|
|||
(append2 (car rest) (apply append (cdr rest))))))
|
||||
|
||||
(define-macro (quasiquote x)
|
||||
;;(core:display-error "quasiquote:") (core:write-error x) (core:display-error "\n")
|
||||
(define (loop x)
|
||||
;;(core:display-error "loop:") (core:write-error x) (core:display-error "\n")
|
||||
(if (vector? x) (list 'list->vector (loop (vector->list x)))
|
||||
(if (not (pair? x)) (cons 'quote (cons x '()))
|
||||
(if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
|
||||
|
@ -272,14 +256,14 @@
|
|||
(and (segment-template? pattern)
|
||||
(or (null? (cddr pattern))
|
||||
(syntax-error "segment matching not implemented" pattern))))
|
||||
|
||||
|
||||
(define (segment-template? pattern)
|
||||
(and (pair? pattern)
|
||||
(pair? (cdr pattern))
|
||||
(memq (cadr pattern) indicators-for-zero-or-more)))
|
||||
|
||||
|
||||
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
|
||||
|
||||
|
||||
(lambda (exp r c)
|
||||
|
||||
(define %input (r '%input)) ;Gensym these, if you like.
|
||||
|
@ -316,7 +300,7 @@
|
|||
0
|
||||
(meta-variables pattern 0 '())))))
|
||||
(syntax-error "ill-formed syntax rule" rule)))
|
||||
|
||||
|
||||
;; Generate code to test whether input expression matches pattern
|
||||
|
||||
(define (process-match input pattern)
|
||||
|
@ -337,7 +321,7 @@
|
|||
`((eq? ,input ',pattern)))
|
||||
(else
|
||||
`((equal? ,input ',pattern)))))
|
||||
|
||||
|
||||
(define (process-segment-match input pattern)
|
||||
;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
|
||||
;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n")
|
||||
|
@ -349,7 +333,7 @@
|
|||
(and (pair? l)
|
||||
,@conjuncts
|
||||
(loop (cdr l)))))))))
|
||||
|
||||
|
||||
;; Generate code to take apart the input expression
|
||||
;; This is pretty bad, but it seems to work (can't say why).
|
||||
|
||||
|
@ -470,4 +454,3 @@
|
|||
(if (not condition)
|
||||
(begin exp ...))))))
|
||||
(xwhen #f 42)))
|
||||
|
||||
|
|
3
src/gc.c
3
src/gc.c
|
@ -70,7 +70,8 @@ gc_copy (SCM old) ///((internal))
|
|||
return g_cells[old].car;
|
||||
SCM new = g_free++;
|
||||
g_news[new] = g_cells[old];
|
||||
if (NTYPE (new) == TVECTOR)
|
||||
if (NTYPE (new) == TSTRUCT
|
||||
|| NTYPE (new) == TVECTOR)
|
||||
{
|
||||
NVECTOR (new) = g_free;
|
||||
for (long i=0; i<LENGTH (old); i++)
|
||||
|
|
|
@ -0,0 +1,146 @@
|
|||
/* -*-comment-start: "//";comment-end:""-*-
|
||||
* 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/>.
|
||||
*/
|
||||
|
||||
SCM make_vector__ (long k);
|
||||
SCM vector_ref_ (SCM x, long i);
|
||||
SCM vector_set_x_ (SCM x, long i, SCM e);
|
||||
|
||||
int
|
||||
char_hash (int c)
|
||||
{
|
||||
if (c >= 'a' && c <= 'z')
|
||||
return c - 'a';
|
||||
return 27;
|
||||
}
|
||||
|
||||
int
|
||||
hashq_ (SCM x, long size)
|
||||
{
|
||||
int hash = char_hash (VALUE (CAR (STRING (x)))) * 27;
|
||||
if (TYPE (CDR (STRING (x))) == TPAIR)
|
||||
hash = hash + char_hash (VALUE (CADR (STRING (x))));
|
||||
else
|
||||
hash = hash + char_hash (0);
|
||||
assert (hash <= 756);
|
||||
return hash;
|
||||
}
|
||||
|
||||
int
|
||||
hashq (SCM x, SCM size)
|
||||
{
|
||||
return hashq_ (x, VALUE (size));
|
||||
}
|
||||
|
||||
SCM
|
||||
hashq_ref (SCM table, SCM key, SCM dflt)
|
||||
{
|
||||
unsigned hash = hashq_ (key, 0);
|
||||
SCM buckets = struct_ref_ (table, 4);
|
||||
SCM bucket = vector_ref_ (buckets, hash);
|
||||
SCM x = cell_f;
|
||||
if (TYPE (dflt) == TPAIR)
|
||||
x = CAR (dflt);
|
||||
if (TYPE (bucket) == TPAIR)
|
||||
x = assq (key, bucket);
|
||||
return x;
|
||||
}
|
||||
|
||||
SCM
|
||||
hashq_set_x (SCM table, SCM key, SCM value)
|
||||
{
|
||||
unsigned hash = hashq_ (key, 0);
|
||||
SCM buckets = struct_ref_ (table, 4);
|
||||
SCM bucket = vector_ref_ (buckets, hash);
|
||||
if (TYPE (bucket) != TPAIR)
|
||||
bucket = cell_nil;
|
||||
bucket = acons (key, value, bucket);
|
||||
vector_set_x_ (buckets, hash, bucket);
|
||||
return value;
|
||||
}
|
||||
|
||||
SCM
|
||||
hash_table_printer (SCM table)
|
||||
{
|
||||
fdputs ("#<", g_stdout); display_ (struct_ref_ (table, 2)); fdputc (' ', g_stdout);
|
||||
fdputs ("size: ", g_stdout); display_ (struct_ref_ (table, 3)); fdputc (' ', g_stdout);
|
||||
SCM buckets = struct_ref_ (table, 4);
|
||||
fdputs ("buckets: ", g_stdout);
|
||||
for (int i=0; i<LENGTH (buckets); i++)
|
||||
{
|
||||
SCM e = vector_ref_ (buckets, i);
|
||||
if (e != cell_unspecified)
|
||||
{
|
||||
fdputc ('[', g_stdout);
|
||||
while (TYPE (e) == TPAIR)
|
||||
{
|
||||
display_ (CAAR (e));
|
||||
e = CDR (e);
|
||||
if (TYPE (e) == TPAIR)
|
||||
fdputc (' ', g_stdout);
|
||||
}
|
||||
fdputs ("]\n ", g_stdout);
|
||||
}
|
||||
}
|
||||
fdputc ('>', g_stdout);
|
||||
}
|
||||
|
||||
SCM
|
||||
make_hashq_type () ///((internal))
|
||||
{
|
||||
SCM record_type_name = cstring_to_symbol ("<record-type>");
|
||||
SCM record_type = record_type_name; // FIXME
|
||||
SCM hashq_type_name = cstring_to_symbol ("<hashq-table>");
|
||||
SCM fields = cell_nil;
|
||||
fields = cons (cstring_to_symbol ("buckets"), fields);
|
||||
fields = cons (cstring_to_symbol ("size"), fields);
|
||||
fields = cons (fields, cell_nil);
|
||||
fields = cons (hashq_type_name, fields);
|
||||
return make_struct (record_type, fields, cell_unspecified);
|
||||
}
|
||||
|
||||
SCM
|
||||
make_hash_table_ (long size)
|
||||
{
|
||||
if (!size)
|
||||
size = 30 * 27;
|
||||
SCM hashq_type_name = cstring_to_symbol ("<hashq-table>");
|
||||
SCM record_type_name = cstring_to_symbol ("<record-type>");
|
||||
//SCM hashq_type = hashq_type_name; // FIXME
|
||||
SCM hashq_type = make_hashq_type ();
|
||||
|
||||
SCM buckets = make_vector__ (size);
|
||||
SCM values = cell_nil;
|
||||
values = cons (buckets, values);
|
||||
values = cons (MAKE_NUMBER (size), values);
|
||||
values = cons (hashq_type_name, values);
|
||||
return make_struct (hashq_type, values, cell_hash_table_printer);
|
||||
}
|
||||
|
||||
SCM
|
||||
make_hash_table (SCM x)
|
||||
{
|
||||
long size = 0;
|
||||
if (TYPE (x) == TPAIR)
|
||||
{
|
||||
assert (TYPE (x) == TNUMBER);
|
||||
size = VALUE (x);
|
||||
}
|
||||
return make_hash_table_ (size);
|
||||
}
|
27
src/lib.c
27
src/lib.c
|
@ -80,6 +80,8 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
|
|||
else if (t == TVARIABLE)
|
||||
{
|
||||
fdputs ("#<variable ", fd);
|
||||
if (LOCAL_P (x))
|
||||
fdputs ("*local* ", fd);
|
||||
display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
|
||||
fdputs (">", fd);
|
||||
}
|
||||
|
@ -166,11 +168,34 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
|
|||
if (TYPE (x) == TPORT)
|
||||
fdputs (">", fd);
|
||||
}
|
||||
else if (t == TREF)
|
||||
fdisplay_ (REF (x), fd, write_p);
|
||||
else if (t == TSTRUCT)
|
||||
{
|
||||
SCM printer = STRUCT (x) + 1;
|
||||
if (TYPE (printer) == TREF)
|
||||
printer = REF (printer);
|
||||
if (printer != cell_unspecified)
|
||||
apply (printer, cons (x, cell_nil), r0);
|
||||
else
|
||||
{
|
||||
fdputs ("#<", fd);
|
||||
fdisplay_ (STRUCT (x), fd, write_p);
|
||||
SCM t = CAR (x);
|
||||
long size = LENGTH (x);
|
||||
for (long i=2; i<size; i++)
|
||||
{
|
||||
fdputc (' ', fd);
|
||||
fdisplay_ (STRUCT (x) + i, fd, write_p);
|
||||
}
|
||||
fdputc ('>', fd);
|
||||
}
|
||||
}
|
||||
else if (t == TVECTOR)
|
||||
{
|
||||
fdputs ("#(", fd);
|
||||
SCM t = CAR (x);
|
||||
for (long i = 0; i < LENGTH (x); i++)
|
||||
for (long i = 0; i<LENGTH (x); i++)
|
||||
{
|
||||
if (i)
|
||||
fdputc (' ', fd);
|
||||
|
|
354
src/mes.c
354
src/mes.c
|
@ -52,8 +52,10 @@ SCM r1 = 0;
|
|||
SCM r2 = 0;
|
||||
// continuation
|
||||
SCM r3 = 0;
|
||||
// current-module
|
||||
SCM m0 = 0;
|
||||
// macro
|
||||
SCM g_macros = 1;
|
||||
SCM g_macros = 0;
|
||||
SCM g_ports = 1;
|
||||
|
||||
#if __M2_PLANET__
|
||||
|
@ -69,13 +71,14 @@ CONSTANT TPORT 8
|
|||
CONSTANT TREF 9
|
||||
CONSTANT TSPECIAL 10
|
||||
CONSTANT TSTRING 11
|
||||
CONSTANT TSYMBOL 12
|
||||
CONSTANT TVALUES 13
|
||||
CONSTANT TVARIABLE 14
|
||||
CONSTANT TVECTOR 15
|
||||
CONSTANT TBROKEN_HEART 16
|
||||
CONSTANT TSTRUCT 12
|
||||
CONSTANT TSYMBOL 13
|
||||
CONSTANT TVALUES 14
|
||||
CONSTANT TVARIABLE 15
|
||||
CONSTANT TVECTOR 16
|
||||
CONSTANT TBROKEN_HEART 17
|
||||
#else // !__M2_PLANET__
|
||||
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
|
||||
enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSTRUCT, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
|
||||
#endif // !__M2_PLANET__
|
||||
|
||||
typedef SCM (*function0_t) (void);
|
||||
|
@ -121,6 +124,7 @@ struct scm {
|
|||
long length;
|
||||
};
|
||||
union {
|
||||
long local_p;
|
||||
long value;
|
||||
long function;
|
||||
long port;
|
||||
|
@ -180,6 +184,7 @@ struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
|
|||
struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0};
|
||||
struct scm scm_call_with_current_continuation = {TSPECIAL, "*call/cc*",0};
|
||||
struct scm scm_symbol_call_with_current_continuation = {TSYMBOL, "call-with-current-continuation",0};
|
||||
struct scm scm_symbol_boot_module = {TSYMBOL, "boot-module",0};
|
||||
struct scm scm_symbol_current_module = {TSYMBOL, "current-module",0};
|
||||
struct scm scm_symbol_primitive_load = {TSYMBOL, "primitive-load",0};
|
||||
struct scm scm_symbol_read_input_file = {TSYMBOL, "read-input-file",0};
|
||||
|
@ -252,6 +257,7 @@ struct scm scm_type_port = {TSYMBOL, "<cell:port>",0};
|
|||
struct scm scm_type_ref = {TSYMBOL, "<cell:ref>",0};
|
||||
struct scm scm_type_special = {TSYMBOL, "<cell:special>",0};
|
||||
struct scm scm_type_string = {TSYMBOL, "<cell:string>",0};
|
||||
struct scm scm_type_struct = {TSYMBOL, "<cell:struct>",0};
|
||||
struct scm scm_type_symbol = {TSYMBOL, "<cell:symbol>",0};
|
||||
struct scm scm_type_values = {TSYMBOL, "<cell:values>",0};
|
||||
struct scm scm_type_variable = {TSYMBOL, "<cell:variable>",0};
|
||||
|
@ -274,19 +280,25 @@ int g_function = 0;
|
|||
|
||||
#if !__GNUC__ || !_POSIX_SOURCE
|
||||
#include "gc.mes.h"
|
||||
#include "hash.mes.h"
|
||||
#include "lib.mes.h"
|
||||
#include "math.mes.h"
|
||||
#include "mes.mes.h"
|
||||
#include "module.mes.h"
|
||||
#include "posix.mes.h"
|
||||
#include "reader.mes.h"
|
||||
#include "struct.mes.h"
|
||||
#include "vector.mes.h"
|
||||
#else
|
||||
#include "gc.h"
|
||||
#include "hash.h"
|
||||
#include "lib.h"
|
||||
#include "math.h"
|
||||
#include "mes.h"
|
||||
#include "module.h"
|
||||
#include "posix.h"
|
||||
#include "reader.h"
|
||||
#include "struct.h"
|
||||
#include "vector.h"
|
||||
#endif
|
||||
|
||||
|
@ -300,6 +312,7 @@ int g_function = 0;
|
|||
|
||||
#if !_POSIX_SOURCE
|
||||
#define LENGTH(x) g_cells[x].car
|
||||
#define LOCAL_P(x) g_cells[x].cdr
|
||||
#define REF(x) g_cells[x].car
|
||||
#define STRING(x) g_cells[x].car
|
||||
#define VARIABLE(x) g_cells[x].car
|
||||
|
@ -311,6 +324,7 @@ int g_function = 0;
|
|||
#define FUNCTION0(x) g_functions[g_cells[x].cdr].function
|
||||
#define MACRO(x) g_cells[x].cdr
|
||||
#define PORT(x) g_cells[x].cdr
|
||||
#define STRUCT(x) g_cells[x].cdr
|
||||
#define VALUE(x) g_cells[x].cdr
|
||||
#define VECTOR(x) g_cells[x].cdr
|
||||
|
||||
|
@ -320,8 +334,9 @@ int g_function = 0;
|
|||
#define NVECTOR(x) g_news[x].cdr
|
||||
|
||||
#else
|
||||
#define CONTINUATION(x) g_cells[x].cdr
|
||||
#define CONTINUATION(x) g_cells[x].continuation
|
||||
#define HITS(x) g_cells[x].hits
|
||||
#define LOCAL_P(x) g_cells[x].local_p
|
||||
#define LENGTH(x) g_cells[x].length
|
||||
#define NAME(x) g_cells[x].name
|
||||
#define STRING(x) g_cells[x].string
|
||||
|
@ -331,6 +346,7 @@ int g_function = 0;
|
|||
#define MACRO(x) g_cells[x].macro
|
||||
#define PORT(x) g_cells[x].port
|
||||
#define REF(x) g_cells[x].ref
|
||||
#define STRUCT(x) g_cells[x].vector
|
||||
#define VALUE(x) g_cells[x].value
|
||||
#define VECTOR(x) g_cells[x].vector
|
||||
#define FUNCTION(x) g_functions[g_cells[x].function]
|
||||
|
@ -409,7 +425,7 @@ list_of_char_equal_p (SCM a, SCM b) ///((internal))
|
|||
}
|
||||
|
||||
SCM
|
||||
lookup_symbol_ (SCM s)
|
||||
list_to_symbol (SCM s)
|
||||
{
|
||||
SCM x = g_symbols;
|
||||
while (x)
|
||||
|
@ -447,6 +463,7 @@ cdr_ (SCM x)
|
|||
{
|
||||
return (TYPE (x) != TCHAR
|
||||
&& TYPE (x) != TNUMBER
|
||||
&& TYPE (x) != TPORT
|
||||
&& (TYPE (CDR (x)) == TPAIR
|
||||
|| TYPE (CDR (x)) == TREF
|
||||
|| TYPE (CDR (x)) == TSPECIAL
|
||||
|
@ -553,7 +570,7 @@ error (SCM key, SCM x)
|
|||
{
|
||||
#if !__MESC_MES__
|
||||
SCM throw;
|
||||
if ((throw = assq_ref_env (cell_symbol_throw, r0)) != cell_undefined)
|
||||
if ((throw = module_ref (r0, cell_symbol_throw)) != cell_undefined)
|
||||
return apply (throw, cons (key, cons (x, cell_nil)), r0);
|
||||
#endif
|
||||
display_error_ (key);
|
||||
|
@ -578,6 +595,12 @@ cstring_to_list (char const* s)
|
|||
return string_to_list (s, strlen (s));
|
||||
}
|
||||
|
||||
SCM
|
||||
cstring_to_symbol (char const *s)
|
||||
{
|
||||
return list_to_symbol (cstring_to_list (s));
|
||||
}
|
||||
|
||||
// extra lib
|
||||
SCM
|
||||
assert_defined (SCM x, SCM e) ///((internal))
|
||||
|
@ -625,6 +648,8 @@ check_apply (SCM f, SCM e) ///((internal))
|
|||
type = "number";
|
||||
if (TYPE (f) == TSTRING)
|
||||
type = "string";
|
||||
if (TYPE (f) == TSTRUCT)
|
||||
type = "#<...>";
|
||||
if (TYPE (f) == TBROKEN_HEART)
|
||||
type = "<3";
|
||||
|
||||
|
@ -645,7 +670,7 @@ check_apply (SCM f, SCM e) ///((internal))
|
|||
SCM
|
||||
gc_push_frame () ///((internal))
|
||||
{
|
||||
SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cell_nil))));
|
||||
SCM frame = cons (r1, cons (r2, cons (r3, cons (r0, cons (m0, cell_nil)))));
|
||||
g_stack = cons (frame, g_stack);
|
||||
return g_stack;
|
||||
}
|
||||
|
@ -809,15 +834,6 @@ assq (SCM x, SCM a)
|
|||
return a != cell_nil ? CAR (a) : cell_f;
|
||||
}
|
||||
|
||||
SCM
|
||||
assq_ref_env (SCM x, SCM a)
|
||||
{
|
||||
x = assq (x, a);
|
||||
if (x == cell_f)
|
||||
return cell_undefined;
|
||||
return CDR (x);
|
||||
}
|
||||
|
||||
SCM
|
||||
set_car_x (SCM x, SCM e)
|
||||
{
|
||||
|
@ -842,19 +858,25 @@ set_env_x (SCM x, SCM e, SCM a)
|
|||
SCM p;
|
||||
if (TYPE (x) == TVARIABLE)
|
||||
p = VARIABLE (x);
|
||||
else
|
||||
p = assert_defined (x, assq (x, a));
|
||||
if (TYPE (x) == TSYMBOL)
|
||||
p = assert_defined (x, module_variable (a, x));
|
||||
if (TYPE (p) == TVARIABLE)
|
||||
p = VARIABLE (p);
|
||||
if (TYPE (p) != TPAIR)
|
||||
error (cell_symbol_not_a_pair, cons (p, x));
|
||||
return set_cdr_x (p, e);
|
||||
}
|
||||
|
||||
SCM expand_variable (SCM x, SCM formals, int global_p); // MOEFMIE
|
||||
|
||||
SCM
|
||||
call_lambda (SCM e, SCM x, SCM aa, SCM a) ///((internal))
|
||||
call_lambda (SCM e, SCM formals, SCM a) ///((internal))
|
||||
{
|
||||
SCM cl = cons (cons (cell_closure, x), x);
|
||||
SCM cl = cons (cons (cell_closure, a), a);
|
||||
r1 = e;
|
||||
r0 = cl;
|
||||
expand_variable (e, formals, 0);
|
||||
r0 = cl;
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
||||
|
@ -865,22 +887,38 @@ make_closure_ (SCM args, SCM body, SCM a) ///((internal))
|
|||
}
|
||||
|
||||
SCM
|
||||
make_variable_ (SCM var) ///((internal))
|
||||
make_variable_ (SCM var, int local_p) ///((internal))
|
||||
{
|
||||
return make_cell__ (TVARIABLE, var, 0);
|
||||
return make_cell__ (TVARIABLE, var, local_p);
|
||||
}
|
||||
|
||||
// SCM
|
||||
// make_variable (SCM var, SCM local_p)
|
||||
// {
|
||||
// return make_variable_ (var, VALUE (local_p));
|
||||
// }
|
||||
|
||||
SCM
|
||||
macro_ref (SCM table, SCM name) ///((internal))
|
||||
{
|
||||
return hashq_ref (table, name, cell_nil);
|
||||
}
|
||||
|
||||
SCM
|
||||
lookup_macro_ (SCM x, SCM a) ///((internal))
|
||||
get_macro (SCM table, SCM name) ///((internal))
|
||||
{
|
||||
if (TYPE (x) != TSYMBOL)
|
||||
return cell_f;
|
||||
SCM m = assq (x, a);
|
||||
SCM m = macro_ref (table, name);
|
||||
if (m != cell_f)
|
||||
return MACRO (CDR (m));
|
||||
return cell_f;
|
||||
}
|
||||
|
||||
SCM
|
||||
macro_set_x (SCM table, SCM name, SCM value) ///((internal))
|
||||
{
|
||||
return hashq_set_x (table, name, value);
|
||||
}
|
||||
|
||||
SCM
|
||||
push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
|
||||
{
|
||||
|
@ -889,7 +927,10 @@ push_cc (SCM p1, SCM p2, SCM a, SCM c) ///((internal))
|
|||
r2 = p2;
|
||||
gc_push_frame ();
|
||||
r1 = p1;
|
||||
r0 = a;
|
||||
// if (TYPE (a) == TPAIR)
|
||||
// r0 = module_clone_locals (r0, a);
|
||||
// else
|
||||
r0 = a;
|
||||
r3 = x;
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
@ -902,6 +943,7 @@ gc_peek_frame () ///((internal))
|
|||
r2 = CADR (frame);
|
||||
r3 = CAR (CDDR (frame));
|
||||
r0 = CADR (CDDR (frame));
|
||||
m0 = CAR (CDDR (CDDR (frame)));
|
||||
return frame;
|
||||
}
|
||||
|
||||
|
@ -945,30 +987,42 @@ formal_p (SCM x, SCM formals) /// ((internal))
|
|||
}
|
||||
|
||||
SCM
|
||||
expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
|
||||
expand_variable_ (SCM x, SCM formals, int global_p, int top_p) ///((internal))
|
||||
{
|
||||
while (TYPE (x) == TPAIR)
|
||||
{
|
||||
if (g_debug > 2)
|
||||
{
|
||||
eputs ("expand x=");
|
||||
display_error_ (x);
|
||||
eputs ("\n");
|
||||
}
|
||||
if (TYPE (CAR (x)) == TPAIR)
|
||||
{
|
||||
if (CAAR (x) == cell_symbol_lambda)
|
||||
{
|
||||
if (!global_p)
|
||||
return cell_unspecified;
|
||||
SCM f = CAR (CDAR (x));
|
||||
formals = add_formals (formals, f);
|
||||
}
|
||||
else if (CAAR (x) == cell_symbol_define
|
||||
|| CAAR (x) == cell_symbol_define_macro)
|
||||
{
|
||||
if (!global_p)
|
||||
return cell_unspecified;
|
||||
SCM f = CAR (CDAR (x));
|
||||
formals = add_formals (formals, f);
|
||||
}
|
||||
if (CAAR (x) != cell_symbol_quote)
|
||||
expand_variable_ (CAR (x), formals, 0);
|
||||
expand_variable_ (CAR (x), formals, global_p, 0);
|
||||
}
|
||||
else
|
||||
{
|
||||
if (CAR (x) == cell_symbol_lambda)
|
||||
{
|
||||
if (!global_p)
|
||||
return cell_unspecified;
|
||||
SCM f = CADR (x);
|
||||
formals = add_formals (formals, f);
|
||||
x = CDR (x);
|
||||
|
@ -976,6 +1030,8 @@ expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
|
|||
else if (CAR (x) == cell_symbol_define
|
||||
|| CAR (x) == cell_symbol_define_macro)
|
||||
{
|
||||
if (!global_p)
|
||||
return cell_unspecified;
|
||||
SCM f = CADR (x);
|
||||
if (top_p && TYPE (f) == TPAIR)
|
||||
f = CDR (f);
|
||||
|
@ -984,17 +1040,49 @@ expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
|
|||
}
|
||||
else if (CAR (x) == cell_symbol_quote)
|
||||
return cell_unspecified;
|
||||
else if (TYPE (CAR (x)) == TVARIABLE && LOCAL_P (CAR (x)))
|
||||
{
|
||||
SCM n = CAR (VARIABLE (CAR (x)));
|
||||
if (g_debug > 2)
|
||||
{
|
||||
eputs ("local_p: "); display_error_ (CAR (x)); eputs ("\n");
|
||||
}
|
||||
SCM v = module_variable (r0, n);
|
||||
if (g_debug > 2)
|
||||
{
|
||||
eputs (" ==>: "); display_error_ (v); eputs ("\n");
|
||||
}
|
||||
if (v == cell_f && g_debug > 2)
|
||||
{
|
||||
eputs ("local_p: "); display_error_ (CAR (x)); eputs ("\n");
|
||||
exit (22);
|
||||
}
|
||||
//if (v == cell_f || formal_p (n, formals))
|
||||
//if (v == cell_f)
|
||||
//v = n;
|
||||
CAR (x) = v;
|
||||
}
|
||||
else if (TYPE (CAR (x)) == TVARIABLE)
|
||||
{
|
||||
if (g_debug > 2)
|
||||
{
|
||||
eputs ("global: "); display_error_ (CAR (x)); eputs ("\n");
|
||||
}
|
||||
}
|
||||
else if (TYPE (CAR (x)) == TSYMBOL
|
||||
&& CAR (x) != cell_begin
|
||||
&& CAR (x) != cell_symbol_begin
|
||||
&& CAR (x) != cell_symbol_boot_module
|
||||
&& CAR (x) != cell_symbol_current_module
|
||||
&& CAR (x) != cell_symbol_primitive_load
|
||||
&& CAR (x) != cell_symbol_if // HMM
|
||||
&& !formal_p (CAR (x), formals))
|
||||
{
|
||||
SCM v = assq (CAR (x), r0);
|
||||
if (v != cell_f)
|
||||
CAR (x) = make_variable_ (v);
|
||||
SCM v = module_variable (r0, CAR (x));
|
||||
if (g_debug > 1 && v != cell_f)
|
||||
{
|
||||
eputs ("expanding: "); display_error_ (v); eputs ("\n");
|
||||
}
|
||||
if (v != cell_f && (!LOCAL_P (v) || !global_p)) // local expand!
|
||||
//if (v != cell_f && !LOCAL_P (v)) // no local expand: works
|
||||
CAR (x) = v;
|
||||
}
|
||||
}
|
||||
x = CDR (x);
|
||||
|
@ -1004,11 +1092,14 @@ expand_variable_ (SCM x, SCM formals, int top_p) ///((internal))
|
|||
}
|
||||
|
||||
SCM
|
||||
expand_variable (SCM x, SCM formals) ///((internal))
|
||||
expand_variable (SCM x, SCM formals, int global_p) ///((internal))
|
||||
{
|
||||
return expand_variable_ (x, formals, 1);
|
||||
return expand_variable_ (x, formals, global_p, 1);
|
||||
}
|
||||
|
||||
SCM struct_ref_ (SCM x, long i);
|
||||
SCM vector_ref_ (SCM x, long i);
|
||||
|
||||
SCM
|
||||
eval_apply ()
|
||||
{
|
||||
|
@ -1025,6 +1116,7 @@ eval_apply ()
|
|||
SCM p;
|
||||
SCM program;
|
||||
SCM sc_expand;
|
||||
SCM v;
|
||||
SCM x;
|
||||
int global_p;
|
||||
int macro_p;
|
||||
|
@ -1102,7 +1194,7 @@ eval_apply ()
|
|||
aa = CDR (aa);
|
||||
check_formals (CAR (r1), formals, CDR (r1));
|
||||
p = pairlis (formals, args, aa);
|
||||
call_lambda (body, p, aa, r0);
|
||||
call_lambda (body, formals, p);
|
||||
goto begin;
|
||||
}
|
||||
else if (t == TCONTINUATION)
|
||||
|
@ -1151,6 +1243,11 @@ eval_apply ()
|
|||
r1 = r0;
|
||||
goto vm_return;
|
||||
}
|
||||
if (CAR (r1) == cell_symbol_boot_module)
|
||||
{
|
||||
r1 = m0;
|
||||
goto vm_return;
|
||||
}
|
||||
}
|
||||
else if (t == TPAIR)
|
||||
{
|
||||
|
@ -1161,7 +1258,7 @@ eval_apply ()
|
|||
body = CDDR (CAR (r1));
|
||||
p = pairlis (formals, CDR (r1), r0);
|
||||
check_formals (r1, formals, args);
|
||||
call_lambda (body, p, p, r0);
|
||||
call_lambda (body, formals, p);
|
||||
goto begin;
|
||||
}
|
||||
}
|
||||
|
@ -1251,21 +1348,13 @@ eval_apply ()
|
|||
{
|
||||
entry = assq (name, g_macros);
|
||||
if (entry == cell_f)
|
||||
{
|
||||
entry = cons (name, cell_f);
|
||||
g_macros = cons (entry, g_macros);
|
||||
}
|
||||
macro_set_x (g_macros, name, cell_f);
|
||||
}
|
||||
else
|
||||
{
|
||||
entry = assq (name, r0);
|
||||
entry = module_variable (r0, name);
|
||||
if (entry == cell_f)
|
||||
{
|
||||
entry = cons (name, cell_f);
|
||||
aa = cons (entry, cell_nil);
|
||||
set_cdr_x (aa, cdr (r0));
|
||||
set_cdr_x (r0, aa);
|
||||
}
|
||||
module_define_x (m0, name, cell_f);
|
||||
}
|
||||
}
|
||||
r2 = r1;
|
||||
|
@ -1281,7 +1370,7 @@ eval_apply ()
|
|||
body = CDDR (r1);
|
||||
|
||||
if (macro_p || global_p)
|
||||
expand_variable (body, formals);
|
||||
expand_variable (body, formals, 1);
|
||||
r1 = cons (cell_symbol_lambda, cons (formals, body));
|
||||
push_cc (r1, r2, p, cell_vm_eval_define);
|
||||
goto eval;
|
||||
|
@ -1292,13 +1381,14 @@ eval_apply ()
|
|||
name = CAR (name);
|
||||
if (macro_p)
|
||||
{
|
||||
entry = assq (name, g_macros);
|
||||
entry = macro_ref (g_macros, name);
|
||||
r1 = MAKE_MACRO (name, r1);
|
||||
set_cdr_x (entry, r1);
|
||||
}
|
||||
else if (global_p)
|
||||
{
|
||||
entry = assq (name, r0);
|
||||
v = module_variable (r0, name);
|
||||
entry = VARIABLE (v);
|
||||
set_cdr_x (entry, r1);
|
||||
}
|
||||
else
|
||||
|
@ -1307,7 +1397,8 @@ eval_apply ()
|
|||
aa = cons (entry, cell_nil);
|
||||
set_cdr_x (aa, cdr (r0));
|
||||
set_cdr_x (r0, aa);
|
||||
cl = assq (cell_closure, r0);
|
||||
v = module_variable (r0, cell_closure);
|
||||
cl = VARIABLE (v);
|
||||
set_cdr_x (cl, aa);
|
||||
}
|
||||
r1 = cell_unspecified;
|
||||
|
@ -1326,6 +1417,8 @@ eval_apply ()
|
|||
}
|
||||
else if (t == TSYMBOL)
|
||||
{
|
||||
if (r1 == cell_symbol_boot_module)
|
||||
goto vm_return;
|
||||
if (r1 == cell_symbol_current_module)
|
||||
goto vm_return;
|
||||
if (r1 == cell_symbol_begin) // FIXME
|
||||
|
@ -1333,7 +1426,7 @@ eval_apply ()
|
|||
r1 = cell_begin;
|
||||
goto vm_return;
|
||||
}
|
||||
r1 = assert_defined (r1, assq_ref_env (r1, r0));
|
||||
r1 = assert_defined (r1, module_ref (r0, r1));
|
||||
goto vm_return;
|
||||
}
|
||||
else if (t == TVARIABLE)
|
||||
|
@ -1348,9 +1441,6 @@ eval_apply ()
|
|||
|
||||
macro_expand:
|
||||
{
|
||||
macro;
|
||||
expanders;
|
||||
|
||||
if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
|
||||
goto vm_return;
|
||||
|
||||
|
@ -1365,7 +1455,7 @@ eval_apply ()
|
|||
}
|
||||
|
||||
if (TYPE (r1) == TPAIR
|
||||
&& (macro = lookup_macro_ (CAR (r1), g_macros)) != cell_f)
|
||||
&& (macro = get_macro (g_macros, CAR (r1))) != cell_f)
|
||||
{
|
||||
r1 = cons (macro, CDR (r1));
|
||||
push_cc (r1, cell_nil, r0, cell_vm_macro_expand);
|
||||
|
@ -1403,11 +1493,11 @@ eval_apply ()
|
|||
if (TYPE (r1) == TPAIR
|
||||
&& TYPE (CAR (r1)) == TSYMBOL
|
||||
&& CAR (r1) != cell_symbol_begin
|
||||
&& ((macro = assq (cell_symbol_portable_macro_expand, g_macros)) != cell_f)
|
||||
&& ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
|
||||
&& ((macro = macro_ref (g_macros, cell_symbol_portable_macro_expand)) != cell_f)
|
||||
&& ((expanders = module_ref (r0, cell_symbol_sc_expander_alist)) != cell_undefined)
|
||||
&& ((macro = assq (CAR (r1), expanders)) != cell_f))
|
||||
{
|
||||
sc_expand = assq_ref_env (cell_symbol_macro_expand, r0);
|
||||
sc_expand = module_ref (r0, cell_symbol_macro_expand);
|
||||
r2 = r1;
|
||||
if (sc_expand != cell_undefined && sc_expand != cell_f)
|
||||
{
|
||||
|
@ -1499,6 +1589,8 @@ eval_apply ()
|
|||
|
||||
push_cc (input, r2, r0, cell_vm_return);
|
||||
x = read_input_file_env (r0);
|
||||
if (g_debug > 3)
|
||||
module_printer (m0);
|
||||
gc_pop_frame ();
|
||||
input = r1;
|
||||
r1 = x;
|
||||
|
@ -1520,7 +1612,7 @@ eval_apply ()
|
|||
continue;
|
||||
}
|
||||
r1 = r2;
|
||||
expand_variable (CAR (r1), cell_nil);
|
||||
expand_variable (CAR (r1), cell_nil, 1);
|
||||
push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
|
||||
goto eval;
|
||||
begin_expand_eval:
|
||||
|
@ -1586,16 +1678,18 @@ apply (SCM f, SCM x, SCM a) ///((internal))
|
|||
SCM
|
||||
mes_g_stack (SCM a) ///((internal))
|
||||
{
|
||||
r0 = a;
|
||||
//r0 = a;
|
||||
r1 = MAKE_CHAR (0);
|
||||
r2 = MAKE_CHAR (0);
|
||||
r3 = MAKE_CHAR (0);
|
||||
g_stack = cons (cell_nil, cell_nil);
|
||||
return r0;
|
||||
return a;
|
||||
}
|
||||
|
||||
// Environment setup
|
||||
|
||||
#include "hash.c"
|
||||
#include "module.c"
|
||||
#include "posix.c"
|
||||
#include "math.c"
|
||||
#include "lib.c"
|
||||
|
@ -1721,6 +1815,9 @@ g_cells[cell_call_with_current_continuation] = scm_call_with_current_continuatio
|
|||
g_free++;
|
||||
g_cells[cell_symbol_call_with_current_continuation] = scm_symbol_call_with_current_continuation;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_symbol_boot_module] = scm_symbol_boot_module;
|
||||
|
||||
g_free++;
|
||||
g_cells[cell_symbol_current_module] = scm_symbol_current_module;
|
||||
|
||||
|
@ -1942,6 +2039,7 @@ g_cells[cell_symbol_sc_expander_alist].car = cstring_to_list (scm_symbol_sc_expa
|
|||
g_cells[cell_symbol_call_with_values].car = cstring_to_list (scm_symbol_call_with_values.name);
|
||||
g_cells[cell_call_with_current_continuation].car = cstring_to_list (scm_call_with_current_continuation.name);
|
||||
g_cells[cell_symbol_call_with_current_continuation].car = cstring_to_list (scm_symbol_call_with_current_continuation.name);
|
||||
g_cells[cell_symbol_boot_module].car = cstring_to_list (scm_symbol_boot_module.name);
|
||||
g_cells[cell_symbol_current_module].car = cstring_to_list (scm_symbol_current_module.name);
|
||||
g_cells[cell_symbol_primitive_load].car = cstring_to_list (scm_symbol_primitive_load.name);
|
||||
g_cells[cell_symbol_read_input_file].car = cstring_to_list (scm_symbol_read_input_file.name);
|
||||
|
@ -2010,12 +2108,42 @@ g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car);
|
|||
#endif
|
||||
|
||||
a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, a);
|
||||
a = acons (cell_symbol_boot_module, cell_symbol_boot_module, a);
|
||||
a = acons (cell_symbol_current_module, cell_symbol_current_module, a);
|
||||
a = acons (cell_symbol_call_with_current_continuation, cell_call_with_current_continuation, a);
|
||||
|
||||
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);
|
||||
|
||||
a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a);
|
||||
a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a);
|
||||
a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a);
|
||||
a = acons (cell_type_function, MAKE_NUMBER (TFUNCTION), a);
|
||||
a = acons (cell_type_keyword, MAKE_NUMBER (TKEYWORD), a);
|
||||
a = acons (cell_type_macro, MAKE_NUMBER (TMACRO), a);
|
||||
a = acons (cell_type_number, MAKE_NUMBER (TNUMBER), a);
|
||||
a = acons (cell_type_pair, MAKE_NUMBER (TPAIR), a);
|
||||
a = acons (cell_type_port, MAKE_NUMBER (TPORT), a);
|
||||
a = acons (cell_type_ref, MAKE_NUMBER (TREF), a);
|
||||
a = acons (cell_type_special, MAKE_NUMBER (TSPECIAL), a);
|
||||
a = acons (cell_type_string, MAKE_NUMBER (TSTRING), a);
|
||||
a = acons (cell_type_struct, MAKE_NUMBER (TSTRUCT), a);
|
||||
a = acons (cell_type_symbol, MAKE_NUMBER (TSYMBOL), a);
|
||||
a = acons (cell_type_values, MAKE_NUMBER (TVALUES), a);
|
||||
a = acons (cell_type_variable, MAKE_NUMBER (TVARIABLE), a);
|
||||
a = acons (cell_type_vector, MAKE_NUMBER (TVECTOR), a);
|
||||
a = acons (cell_type_broken_heart, MAKE_NUMBER (TBROKEN_HEART), a);
|
||||
|
||||
a = acons (cell_closure, a, a);
|
||||
|
||||
return a;
|
||||
}
|
||||
|
||||
SCM
|
||||
mes_environment (int argc, char *argv[])
|
||||
{
|
||||
SCM a = mes_symbols ();
|
||||
|
||||
char *compiler = "gnuc";
|
||||
#if __MESC__
|
||||
compiler = "mesc";
|
||||
|
@ -2030,33 +2158,13 @@ g_cells[cell_vm_return].car = cstring_to_list (scm_vm_return.car);
|
|||
#endif
|
||||
a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a);
|
||||
|
||||
a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a);
|
||||
a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a);
|
||||
a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a);
|
||||
a = acons (cell_type_function, MAKE_NUMBER (TFUNCTION), a);
|
||||
a = acons (cell_type_keyword, MAKE_NUMBER (TKEYWORD), a);
|
||||
a = acons (cell_type_macro, MAKE_NUMBER (TMACRO), a);
|
||||
a = acons (cell_type_number, MAKE_NUMBER (TNUMBER), a);
|
||||
a = acons (cell_type_pair, MAKE_NUMBER (TPAIR), a);
|
||||
a = acons (cell_type_port, MAKE_NUMBER (TPORT), a);
|
||||
a = acons (cell_type_ref, MAKE_NUMBER (TREF), a);
|
||||
a = acons (cell_type_special, MAKE_NUMBER (TSPECIAL), a);
|
||||
a = acons (cell_type_string, MAKE_NUMBER (TSTRING), a);
|
||||
a = acons (cell_type_symbol, MAKE_NUMBER (TSYMBOL), a);
|
||||
a = acons (cell_type_values, MAKE_NUMBER (TVALUES), a);
|
||||
a = acons (cell_type_variable, MAKE_NUMBER (TVARIABLE), a);
|
||||
a = acons (cell_type_vector, MAKE_NUMBER (TVECTOR), a);
|
||||
a = acons (cell_type_broken_heart, MAKE_NUMBER (TBROKEN_HEART), a);
|
||||
#if !MES_MINI
|
||||
SCM lst = cell_nil;
|
||||
for (int i=argc-1; i>=0; i--)
|
||||
lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
|
||||
a = acons (cell_symbol_argv, lst, a);
|
||||
#endif
|
||||
|
||||
a = acons (cell_closure, a, a);
|
||||
|
||||
return a;
|
||||
}
|
||||
|
||||
SCM
|
||||
mes_environment () ///((internal))
|
||||
{
|
||||
SCM a = mes_symbols ();
|
||||
return mes_g_stack (a);
|
||||
}
|
||||
|
||||
|
@ -2191,37 +2299,49 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a);
|
|||
#include "mes.mes.i"
|
||||
|
||||
// Do not sort: Order of these includes define builtins
|
||||
#include "hash.mes.i"
|
||||
#include "module.mes.i"
|
||||
#include "posix.mes.i"
|
||||
#include "math.mes.i"
|
||||
#include "lib.mes.i"
|
||||
#include "vector.mes.i"
|
||||
#include "struct.mes.i"
|
||||
#include "gc.mes.i"
|
||||
#include "reader.mes.i"
|
||||
|
||||
#include "gc.mes.environment.i"
|
||||
#include "hash.mes.environment.i"
|
||||
#include "lib.mes.environment.i"
|
||||
#include "math.mes.environment.i"
|
||||
#include "mes.mes.environment.i"
|
||||
#include "module.mes.environment.i"
|
||||
#include "posix.mes.environment.i"
|
||||
#include "reader.mes.environment.i"
|
||||
#include "struct.mes.environment.i"
|
||||
#include "vector.mes.environment.i"
|
||||
#else
|
||||
#include "mes.i"
|
||||
|
||||
// Do not sort: Order of these includes define builtins
|
||||
#include "hash.i"
|
||||
#include "module.i"
|
||||
#include "posix.i"
|
||||
#include "math.i"
|
||||
#include "lib.i"
|
||||
#include "vector.i"
|
||||
#include "struct.i"
|
||||
#include "gc.i"
|
||||
#include "reader.i"
|
||||
|
||||
#include "gc.environment.i"
|
||||
#include "hash.environment.i"
|
||||
#include "lib.environment.i"
|
||||
#include "math.environment.i"
|
||||
#include "mes.environment.i"
|
||||
#include "module.environment.i"
|
||||
#include "posix.environment.i"
|
||||
#include "reader.environment.i"
|
||||
#include "struct.environment.i"
|
||||
#include "vector.environment.i"
|
||||
#endif
|
||||
|
||||
|
@ -2269,9 +2389,8 @@ load_boot (char *prefix, char const *boot, char const *location)
|
|||
}
|
||||
|
||||
SCM
|
||||
load_env (SCM a) ///((internal))
|
||||
load_env () ///((internal))
|
||||
{
|
||||
r0 = a;
|
||||
g_stdin = -1;
|
||||
char prefix[1024];
|
||||
char boot[1024];
|
||||
|
@ -2310,15 +2429,13 @@ load_env (SCM a) ///((internal))
|
|||
exit (1);
|
||||
}
|
||||
|
||||
if (!g_function)
|
||||
r0 = mes_builtins (r0);
|
||||
r2 = read_input_file_env (r0);
|
||||
g_stdin = STDIN;
|
||||
return r2;
|
||||
}
|
||||
|
||||
SCM
|
||||
bload_env (SCM a) ///((internal))
|
||||
bload_env () ///((internal))
|
||||
{
|
||||
#if !_POSIX_SOURCE
|
||||
char *mo = "mes/boot-0.32-mo";
|
||||
|
@ -2358,23 +2475,11 @@ bload_env (SCM a) ///((internal))
|
|||
gc_peek_frame ();
|
||||
g_symbols = r1;
|
||||
g_stdin = STDIN;
|
||||
// SCM a = struct_ref (r0, 4);
|
||||
// a = mes_builtins (a);
|
||||
// struct_set_x (r0, 4, a);
|
||||
r0 = mes_builtins (r0);
|
||||
|
||||
char *compiler = "gnuc";
|
||||
#if __MESC__
|
||||
compiler = "mesc";
|
||||
#elif __TINYC__
|
||||
compiler = "tcc";
|
||||
#endif
|
||||
|
||||
a = acons (cell_symbol_compiler, MAKE_STRING (cstring_to_list (compiler)), a);
|
||||
|
||||
char *arch = "x86";
|
||||
#if __x86_64__
|
||||
arch = "x86_64";
|
||||
#endif
|
||||
a = acons (cell_symbol_arch, MAKE_STRING (cstring_to_list (arch)), a);
|
||||
|
||||
if (g_debug > 3)
|
||||
{
|
||||
eputs ("symbols: ");
|
||||
|
@ -2402,6 +2507,7 @@ bload_env (SCM a) ///((internal))
|
|||
}
|
||||
|
||||
#include "vector.c"
|
||||
#include "struct.c"
|
||||
#include "gc.c"
|
||||
#include "reader.c"
|
||||
|
||||
|
@ -2429,21 +2535,21 @@ main (int argc, char *argv[])
|
|||
GC_SAFETY = atoi (p);
|
||||
g_stdin = STDIN;
|
||||
g_stdout = STDOUT;
|
||||
r0 = mes_environment ();
|
||||
|
||||
SCM a = mes_environment (argc, argv);
|
||||
a = mes_builtins (a);
|
||||
m0 = make_initial_module (a);
|
||||
g_macros = make_hash_table_ (0);
|
||||
|
||||
if (g_debug > 3)
|
||||
module_printer (m0);
|
||||
|
||||
SCM program = (argc > 1 && !strcmp (argv[1], "--load"))
|
||||
? bload_env (r0) : load_env (r0);
|
||||
? bload_env () : load_env ();
|
||||
g_tiny = argc > 2 && !strcmp (argv[2], "--tiny");
|
||||
if (argc > 1 && !strcmp (argv[1], "--dump"))
|
||||
return dump ();
|
||||
|
||||
#if !MES_MINI
|
||||
SCM lst = cell_nil;
|
||||
for (int i=argc-1; i>=0; i--)
|
||||
lst = cons (MAKE_STRING (cstring_to_list (argv[i])), lst);
|
||||
r0 = acons (cell_symbol_argv, lst, r0); // FIXME
|
||||
r0 = acons (cell_symbol_argv, lst, r0);
|
||||
#endif
|
||||
push_cc (r2, cell_unspecified, r0, cell_unspecified);
|
||||
|
||||
if (g_debug > 2)
|
||||
|
|
|
@ -0,0 +1,134 @@
|
|||
/* -*-comment-start: "//";comment-end:""-*-
|
||||
* 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/>.
|
||||
*/
|
||||
|
||||
SCM struct_ref_ (SCM x, long i);
|
||||
SCM struct_set_x_ (SCM x, long i, SCM e);
|
||||
|
||||
SCM
|
||||
make_module_type () ///(internal))
|
||||
{
|
||||
SCM record_type_name = cstring_to_symbol ("<record-type>");
|
||||
SCM record_type = record_type_name; // FIXME
|
||||
SCM module_type_name = cstring_to_symbol ("<module>");
|
||||
SCM fields = cell_nil;
|
||||
fields = cons (cstring_to_symbol ("globals"), fields);
|
||||
fields = cons (cstring_to_symbol ("locals"), fields);
|
||||
fields = cons (cstring_to_symbol ("name"), fields);
|
||||
fields = cons (fields, cell_nil);
|
||||
fields = cons (module_type_name, fields);
|
||||
return make_struct (record_type, fields, cell_unspecified);
|
||||
}
|
||||
|
||||
SCM
|
||||
make_initial_module (SCM a) ///((internal))
|
||||
{
|
||||
SCM module_type_name = cstring_to_symbol ("<module>");
|
||||
// SCM module_type = module_type_name; //FIXME
|
||||
SCM module_type = make_module_type ();
|
||||
a = acons (module_type_name, module_type, a);
|
||||
|
||||
SCM hashq_type = make_hashq_type ();
|
||||
SCM hashq_type_name = cstring_to_symbol ("<hashq-table>");
|
||||
a = acons (hashq_type_name, hashq_type, a);
|
||||
|
||||
SCM name = cons (cstring_to_symbol ("boot"), cell_nil);
|
||||
SCM globals = make_hash_table_ (0);
|
||||
SCM locals = cell_nil;
|
||||
|
||||
SCM values = cell_nil;
|
||||
values = cons (globals, values);
|
||||
values = cons (locals, values);
|
||||
values = cons (name, values);
|
||||
values = cons (module_type_name, values);
|
||||
SCM module = make_struct (module_type, values, cell_module_printer);
|
||||
r0 = cell_nil;
|
||||
r0 = cons (CADR (a), r0);
|
||||
r0 = cons (CAR (a), r0);
|
||||
m0 = module;
|
||||
while (TYPE (a) == TPAIR)
|
||||
{
|
||||
if (g_debug > 3)
|
||||
{
|
||||
eputs ("entry="); display_error_ (CAR (a)); eputs ("\n");
|
||||
}
|
||||
module_define_x (module, CAAR (a), CDAR (a));
|
||||
a = CDR (a);
|
||||
}
|
||||
|
||||
return module;
|
||||
}
|
||||
|
||||
SCM
|
||||
module_printer (SCM module)
|
||||
{
|
||||
//module = m0;
|
||||
fdputs ("#<", g_stdout); display_ (struct_ref_ (module, 2)); fdputc (' ', g_stdout);
|
||||
fdputs ("name: ", g_stdout); display_ (struct_ref_ (module, 3)); fdputc (' ', g_stdout);
|
||||
fdputs ("locals: ", g_stdout); display_ (struct_ref_ (module, 4)); fdputc (' ', g_stdout);
|
||||
SCM table = struct_ref_ (module, 5);
|
||||
fdputs ("globals:\n ", g_stdout);
|
||||
display_ (table);
|
||||
fdputc ('>', g_stdout);
|
||||
}
|
||||
|
||||
SCM
|
||||
module_variable (SCM module, SCM name)
|
||||
{
|
||||
if (g_debug > 4)
|
||||
{
|
||||
eputs ("module_variable: "); display_error_ (name); eputs ("\n");
|
||||
}
|
||||
//SCM locals = struct_ref_ (module, 3);
|
||||
SCM locals = module;
|
||||
SCM x = assq (name, locals);
|
||||
if (x != cell_f)
|
||||
x = make_variable_ (x, 1);
|
||||
else
|
||||
{
|
||||
module = m0;
|
||||
SCM globals = struct_ref_ (module, 5);
|
||||
x = hashq_ref (globals, name, cell_f);
|
||||
if (x != cell_f)
|
||||
x = make_variable_ (x, 0);
|
||||
}
|
||||
return x;
|
||||
}
|
||||
|
||||
SCM
|
||||
module_ref (SCM module, SCM name)
|
||||
{
|
||||
SCM x = module_variable (module, name);
|
||||
if (x == cell_f)
|
||||
return cell_undefined;
|
||||
x = VARIABLE (x);
|
||||
return CDR (x);
|
||||
}
|
||||
|
||||
SCM
|
||||
module_define_x (SCM module, SCM name, SCM value)
|
||||
{
|
||||
if (g_debug > 4)
|
||||
{
|
||||
eputs ("module_define_x: "); display_error_ (name); eputs ("\n");
|
||||
}
|
||||
module = m0;
|
||||
SCM globals = struct_ref_ (module, 5);
|
||||
return hashq_set_x (globals, name, value);
|
||||
}
|
|
@ -34,8 +34,9 @@ read_input_file_env_ (SCM e, SCM a)
|
|||
SCM
|
||||
read_input_file_env (SCM a)
|
||||
{
|
||||
r0 = a;
|
||||
return read_input_file_env_ (read_env (r0), r0);
|
||||
//r0 = a;
|
||||
//return read_input_file_env_ (read_env (r0), r0);
|
||||
return read_input_file_env_ (read_env (cell_nil), cell_nil);
|
||||
}
|
||||
|
||||
int
|
||||
|
@ -103,7 +104,7 @@ reader_read_identifier_or_number (int c)
|
|||
}
|
||||
unreadchar (c);
|
||||
buf[i] = 0;
|
||||
return lookup_symbol_ (cstring_to_list (buf));
|
||||
return cstring_to_symbol (buf);
|
||||
}
|
||||
|
||||
SCM
|
||||
|
|
|
@ -0,0 +1,83 @@
|
|||
/* -*-comment-start: "//";comment-end:""-*-
|
||||
* 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/>.
|
||||
*/
|
||||
|
||||
SCM
|
||||
make_struct (SCM type, SCM fields, SCM printer)
|
||||
{
|
||||
long size = 2 + length__ (fields);
|
||||
SCM v = alloc (size);
|
||||
SCM x = make_cell__ (TSTRUCT, size, v);
|
||||
g_cells[v] = g_cells[vector_entry (type)];
|
||||
g_cells[v+1] = g_cells[vector_entry (printer)];
|
||||
for (long i=2; i<size; i++)
|
||||
{
|
||||
SCM e = cell_unspecified;
|
||||
if (fields != cell_nil)
|
||||
{
|
||||
e = CAR (fields);
|
||||
fields = CDR (fields);
|
||||
}
|
||||
g_cells[v+i] = g_cells[vector_entry (e)];
|
||||
}
|
||||
return x;
|
||||
}
|
||||
|
||||
SCM
|
||||
struct_length (SCM x)
|
||||
{
|
||||
assert (TYPE (x) == TSTRUCT);
|
||||
return MAKE_NUMBER (LENGTH (x));
|
||||
}
|
||||
|
||||
SCM
|
||||
struct_ref_ (SCM x, long i)
|
||||
{
|
||||
assert (TYPE (x) == TSTRUCT);
|
||||
assert (i < LENGTH (x));
|
||||
SCM e = STRUCT (x) + i;
|
||||
if (TYPE (e) == TREF)
|
||||
e = REF (e);
|
||||
if (TYPE (e) == TCHAR)
|
||||
e = MAKE_CHAR (VALUE (e));
|
||||
if (TYPE (e) == TNUMBER)
|
||||
e = MAKE_NUMBER (VALUE (e));
|
||||
return e;
|
||||
}
|
||||
|
||||
SCM
|
||||
struct_set_x_ (SCM x, long i, SCM e)
|
||||
{
|
||||
assert (TYPE (x) == TSTRUCT);
|
||||
assert (VALUE (i) < LENGTH (x));
|
||||
g_cells[STRUCT (x)+i] = g_cells[vector_entry (e)];
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
||||
SCM
|
||||
struct_ref (SCM x, SCM i)
|
||||
{
|
||||
return struct_ref_ (x, VALUE (i));
|
||||
}
|
||||
|
||||
SCM
|
||||
struct_set_x (SCM x, SCM i, SCM e)
|
||||
{
|
||||
return struct_set_x_ (x, VALUE (i), e);
|
||||
}
|
24
src/vector.c
24
src/vector.c
|
@ -42,11 +42,11 @@ vector_length (SCM x)
|
|||
}
|
||||
|
||||
SCM
|
||||
vector_ref (SCM x, SCM i)
|
||||
vector_ref_ (SCM x, long i)
|
||||
{
|
||||
assert (TYPE (x) == TVECTOR);
|
||||
assert (VALUE (i) < LENGTH (x));
|
||||
SCM e = VECTOR (x) + VALUE (i);
|
||||
assert (i < LENGTH (x));
|
||||
SCM e = VECTOR (x) + i;
|
||||
if (TYPE (e) == TREF)
|
||||
e = REF (e);
|
||||
if (TYPE (e) == TCHAR)
|
||||
|
@ -56,6 +56,12 @@ vector_ref (SCM x, SCM i)
|
|||
return e;
|
||||
}
|
||||
|
||||
SCM
|
||||
vector_ref (SCM x, SCM i)
|
||||
{
|
||||
return vector_ref_ (x, VALUE (i));
|
||||
}
|
||||
|
||||
SCM
|
||||
vector_entry (SCM x)
|
||||
{
|
||||
|
@ -65,14 +71,20 @@ vector_entry (SCM x)
|
|||
}
|
||||
|
||||
SCM
|
||||
vector_set_x (SCM x, SCM i, SCM e)
|
||||
vector_set_x_ (SCM x, long i, SCM e)
|
||||
{
|
||||
assert (TYPE (x) == TVECTOR);
|
||||
assert (VALUE (i) < LENGTH (x));
|
||||
g_cells[VECTOR (x)+VALUE (i)] = g_cells[vector_entry (e)];
|
||||
assert (i < LENGTH (x));
|
||||
g_cells[VECTOR (x)+i] = g_cells[vector_entry (e)];
|
||||
return cell_unspecified;
|
||||
}
|
||||
|
||||
SCM
|
||||
vector_set_x (SCM x, SCM i, SCM e)
|
||||
{
|
||||
return vector_set_x_ (x, VALUE (i), e);
|
||||
}
|
||||
|
||||
SCM
|
||||
list_to_vector (SCM x)
|
||||
{
|
||||
|
|
|
@ -51,14 +51,14 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
|||
;; 0 (with-fluids* (list a b) '(0 1)
|
||||
;; (lambda () (fluid-ref a))))
|
||||
|
||||
(pass-if-equal "with-fluids"
|
||||
(pass-if-eq "with-fluids"
|
||||
0 (with-fluids ((a 1)
|
||||
(a 2)
|
||||
(a 3))
|
||||
(fluid-set! a 0)
|
||||
(fluid-ref a)))
|
||||
|
||||
(pass-if-equal "with-fluids" ; FIXME: fails with Mes
|
||||
(pass-if-eq "with-fluids"
|
||||
#f (begin
|
||||
(with-fluids ((a 1)
|
||||
(b 2))
|
||||
|
@ -66,4 +66,4 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
|||
(display "X:") (display (fluid-ref a)) (newline))
|
||||
(fluid-ref a)))
|
||||
|
||||
(result 'report (if mes? 1 0))
|
||||
(result 'report)
|
||||
|
|
|
@ -26,11 +26,13 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
|||
(define-module (tests guile)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (mes mes-0)
|
||||
#:use-module (mes misc)
|
||||
#:use-module (mes test))
|
||||
|
||||
(cond-expand
|
||||
(mes
|
||||
(mes-use-module (mes test))
|
||||
(mes-use-module (mes misc))
|
||||
(mes-use-module (mes guile)))
|
||||
(else))
|
||||
|
||||
|
@ -71,14 +73,6 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
|||
(set-current-input-port (car ipstk))
|
||||
(fluid-set! *input-stack* (cdr ipstk))))))
|
||||
|
||||
;; Return #f if empty
|
||||
(define (pop-input)
|
||||
(let ((ipstk (fluid-ref *input-stack*)))
|
||||
(if (null? ipstk) #f
|
||||
(begin
|
||||
(set-current-input-port (car ipstk))
|
||||
(fluid-set! *input-stack* (cdr ipstk))))))
|
||||
|
||||
(pass-if-equal "push-input"
|
||||
"bla"
|
||||
(let ()
|
||||
|
@ -102,8 +96,7 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
|
|||
(unless (eof-object? ch) (write-char ch) (iter (read-char))))
|
||||
(pop-input)
|
||||
(let iter ((ch (read-char)))
|
||||
(unless (eof-object? ch) (write-char ch) (iter (read-char))))
|
||||
)))))
|
||||
(unless (eof-object? ch) (write-char ch) (iter (read-char)))))))))
|
||||
|
||||
(pass-if "input-stack/2"
|
||||
(let ((sp (open-input-string "abc")))
|
||||
|
|
|
@ -0,0 +1,117 @@
|
|||
#! /bin/sh
|
||||
# -*-scheme-*-
|
||||
if [ "$MES" != guile ]; then
|
||||
export MES_BOOT=boot-02.scm
|
||||
MES=${MES-$(dirname $0)/../src/mes}
|
||||
$MES < $0
|
||||
exit $?
|
||||
fi
|
||||
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests macro)' -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 boot)
|
||||
#:use-module (mes mes-0)
|
||||
#: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)
|
||||
|
||||
(define gensym
|
||||
((lambda (symbols)
|
||||
(lambda (. rest)
|
||||
((lambda (head tail)
|
||||
(set! symbols tail)
|
||||
head)
|
||||
(car symbols)
|
||||
(cdr symbols))))
|
||||
'(g0 g1 g2 g3 g4)))
|
||||
|
||||
;; 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))
|
||||
|
||||
;; boot-0.scm
|
||||
(define (symbol->string s)
|
||||
(apply string (symbol->list s)))
|
||||
|
||||
(define (string-append . rest)
|
||||
(apply string (apply append (map1 string->list rest))))
|
||||
|
||||
;; scm.mes
|
||||
(define (symbol-append . rest)
|
||||
(string->symbol (apply string-append (map symbol->string rest))))
|
||||
|
||||
(define-macro (make-fluid . default)
|
||||
((lambda (fluid)
|
||||
(list
|
||||
'begin
|
||||
(list
|
||||
'module-define!
|
||||
(list 'boot-module)
|
||||
(list 'quote fluid)
|
||||
(list
|
||||
(lambda (v)
|
||||
(lambda ( . rest)
|
||||
(if (null? rest) v
|
||||
(set! v (car rest)))))
|
||||
(and (pair? default) (car default))))
|
||||
(list 'quote fluid)))
|
||||
(symbol-append 'fluid: (gensym))))
|
||||
|
||||
(define fluid (make-fluid 42))
|
||||
|
||||
(pass-if-eq "fluid" 42 (fluid))
|
||||
|
||||
(fluid 0)
|
||||
(pass-if-eq "fluid 0" 0 (fluid))
|
||||
|
||||
(fluid '())
|
||||
(pass-if-eq "fluid null" '() (fluid))
|
||||
|
||||
(define (fluid-ref fluid)
|
||||
(fluid))
|
||||
|
||||
(define (fluid-set! fluid value)
|
||||
(fluid value))
|
||||
|
||||
(fluid-set! fluid 0)
|
||||
(pass-if-eq "fluid 0" 0 (fluid-ref fluid))
|
||||
|
||||
(fluid-set! fluid '())
|
||||
(pass-if-eq "fluid null" '() (fluid-ref fluid))
|
||||
|
||||
(result 'report)
|
|
@ -0,0 +1,48 @@
|
|||
#! /bin/sh
|
||||
# -*-scheme-*-
|
||||
if [ "$MES" != guile ]; then
|
||||
export MES_BOOT=boot-02.scm
|
||||
MES=${MES-$(dirname $0)/../src/mes}
|
||||
$MES < $0
|
||||
exit $?
|
||||
fi
|
||||
exec ${MES-mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests boot)' -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-0)
|
||||
#:use-module (mes mes-0)
|
||||
#:use-module (mes test))
|
||||
|
||||
(display "srfi-0...\n")
|
||||
|
||||
(cond-expand
|
||||
(mes
|
||||
(display "mes\n")
|
||||
(exit 0))
|
||||
(guile
|
||||
(display "guile\n")
|
||||
(exit guile?))
|
||||
(else
|
||||
(exit 1)))
|
||||
|
||||
(exit 1)
|
Loading…
Reference in New Issue