diff --git a/make.scm b/make.scm index 6b6702d8..9c523e90 100755 --- a/make.scm +++ b/make.scm @@ -434,9 +434,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ (add-target (snarf "src/vector.c" #:mes? #t)))) (add-target (bin.gcc "src/mes.c" #:dependencies gcc-snarf-targets - #:defines `("MES_FIXED_PRIMITIVES=1" - "MES_FULL=1" - "POSIX=1" + #:defines `("POSIX=1" ,(string-append "VERSION=\"" %version "\"") ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"") ,(string-append "PREFIX=\"" %prefix "\"")) @@ -444,17 +442,13 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ (add-target (bin.gcc "src/mes.c" #:libc libc-gcc.mlibc-o #:dependencies mes-snarf-targets - #:defines `( "MES_FIXED_PRIMITIVES=1" - "MES_FULL=1" - ,(string-append "VERSION=\"" %version "\"") + #:defines `(,(string-append "VERSION=\"" %version "\"") ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") "/" %moduledir "/") "\"") ,(string-append "PREFIX=\"" %prefix "\"")) #:includes '("src"))) (add-target (bin.mescc "src/mes.c" #:dependencies mes-snarf-targets - #:defines `("MES_FIXED_PRIMITIVES=1" - "MES_FULL=1" - ,(string-append "VERSION=\"" %version "\"") + #:defines `(,(string-append "VERSION=\"" %version "\"") ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"") ,(string-append "PREFIX=\"" %prefix "\"")) #:includes '("src"))) diff --git a/module/language/c99/compiler.mes b/module/language/c99/compiler.mes index d6338f33..87cb97c6 100644 --- a/module/language/c99/compiler.mes +++ b/module/language/c99/compiler.mes @@ -1223,8 +1223,8 @@ (info (append-text info (wrap-as `((#:label ,skip-b-label)))))) info)) - ((cast ,cast ,o) - ((expr->accu info) o)) + ((cast ,type ,expr) + ((expr->accu info) expr)) ((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b) (let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b))) diff --git a/module/mes/boot-0.scm b/module/mes/boot-0.scm index 2f3d7188..eddd0612 100644 --- a/module/mes/boot-0.scm +++ b/module/mes/boot-0.scm @@ -75,7 +75,9 @@ (if (null? lst) (list) (cons (f (car lst)) (map1 f (cdr lst))))) -(define map map1) +(define (map f lst) + (if (null? lst) (list) + (cons (f (car lst)) (map f (cdr lst))))) (define (cons* . rest) (if (null? (cdr rest)) (car rest) @@ -104,6 +106,7 @@ (list (quote if) (quote r) (quote r) (cons (quote or) (cdr x)))) (car x))))) + (define-macro (module-define! module name value) ;;(list 'define name value) #t) diff --git a/module/mes/display.mes b/module/mes/display.mes index beb2b075..e3b19ba8 100644 --- a/module/mes/display.mes +++ b/module/mes/display.mes @@ -95,6 +95,12 @@ (display "#" port)) + ((variable? x) + (display "#" port)) ((number? x) (display (number->string x) port)) ((pair? x) diff --git a/module/mes/guile.scm b/module/mes/guile.scm index ca61412c..1af8f6b4 100644 --- a/module/mes/guile.scm +++ b/module/mes/guile.scm @@ -35,12 +35,16 @@ core:write-error core:write-port core:type + pmatch-car + pmatch-cdr ) ;;#:re-export (open-input-file open-input-string with-input-from-string) ) (cond-expand (guile + (define pmatch-car car) + (define pmatch-cdr cdr) (define core:exit exit) (define core:display display) (define core:display-port display) diff --git a/module/mes/module.mes b/module/mes/module.mes index 8e6fba85..d6aa7677 100644 --- a/module/mes/module.mes +++ b/module/mes/module.mes @@ -26,15 +26,6 @@ (string-append (string-join (map symbol->string o) "/") ".mes")) (define *modules* '(mes/base-0.mes)) -(define (mes-load-module-env module a) - (push! *input-ports* (current-input-port)) - (set-current-input-port (open-input-file (string-append %moduledir (module->file module)))) - (let ((x (core:eval (append2 (cons 'begin (read-input-file-env a)) - '((current-module))) - a))) - (set-current-input-port (pop! *input-ports*)) - x)) - (define-macro (mes-use-module module) (list 'if (list not (list memq (list string->symbol (module->file module)) '*modules*)) (list @@ -46,3 +37,28 @@ (list core:display-error ";;; already loaded: ") (list core:display-error (list 'quote module)) (list core:display-error "\n"))))) + +(define *input-ports* '()) +(define-macro (push! stack o) + (cons + 'begin + (list + (list 'set! stack (list cons o stack)) + stack))) +(define-macro (pop! stack) + (list 'let (list (list 'o (list car stack))) + (list 'set! stack (list cdr stack)) + 'o)) +(define (mes-load-module-env module a) + (push! *input-ports* (current-input-port)) + (set-current-input-port (open-input-file (string-append %moduledir (module->file module)))) + (let ((x (core:eval (append2 (cons 'begin (read-input-file-env a)) + '((current-module))) + a))) + (set-current-input-port (pop! *input-ports*)) + x)) +(define (mes-load-module-env module a) + (core:display-error "loading:") (core:write-error (string-append %moduledir (module->file module))) (core:display-error "\n") + (primitive-load (string-append %moduledir (module->file module))) + (core:display-error "dun\n") + ) diff --git a/module/mes/pmatch.scm b/module/mes/pmatch.scm index 207cdb52..d06add25 100644 --- a/module/mes/pmatch.scm +++ b/module/mes/pmatch.scm @@ -3,6 +3,7 @@ ;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc ;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov ;;; Copyright (C) 2007 Daniel P. Friedman +;;; Copyright (C) 2018 Jan Nieuwenhuizen ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -51,20 +52,17 @@ (define-module (system base pmatch) #:export-syntax (pmatch)) -(define-syntax-rule (pmatch e cs ...) - (let ((v e)) (pmatch1 v cs ...))) - -(define-syntax pmatch1 +(define-syntax pmatch (syntax-rules (else guard) ((_ v) (if #f #f)) ((_ v (else e0 e ...)) (let () e0 e ...)) ((_ v (pat (guard g ...) e0 e ...) cs ...) - (let ((fk (lambda () (pmatch1 v cs ...)))) + (let ((fk (lambda () (pmatch v cs ...)))) (ppat v pat (if (and g ...) (let () e0 e ...) (fk)) (fk)))) ((_ v (pat e0 e ...) cs ...) - (let ((fk (lambda () (pmatch1 v cs ...)))) + (let ((fk (lambda () (pmatch v cs ...)))) (ppat v pat (let () e0 e ...) (fk)))))) (define-syntax ppat @@ -76,8 +74,6 @@ ((_ v (unquote var) kt kf) (let ((var v)) kt)) ((_ v (x . y) kt kf) (if (pair? v) - (let ((vx (car v)) (vy (cdr v))) - ;;(ppat vx x (ppat vy y kt kf) kf) ;; FIXME: broken with syntax.scm - (ppat (car v) x (ppat (cdr v) y kt kf) kf)) + (ppat (pmatch-car v) x (ppat (pmatch-cdr v) y kt kf) kf) kf)) ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf)))) diff --git a/module/mes/psyntax-1.mes b/module/mes/psyntax-1.mes index 6152e42b..e7209551 100644 --- a/module/mes/psyntax-1.mes +++ b/module/mes/psyntax-1.mes @@ -27,5 +27,6 @@ (define datum->syntax datum->syntax-object) (define syntax->datum syntax-object->datum) +(define-macro (portable-macro-expand) #t) (set! macro-expand sc-expand) diff --git a/module/mes/type-0.mes b/module/mes/type-0.mes index be903c40..16ee84bb 100644 --- a/module/mes/type-0.mes +++ b/module/mes/type-0.mes @@ -38,8 +38,9 @@ (define 10) (define 11) (define 12) -(define 13) -(define 14) +(define 13) +(define 14) +(define 15) (define cell:type-alist (list (cons (quote )) @@ -55,6 +56,7 @@ (cons (quote )) (cons (quote )) (cons (quote )) + (cons (quote )) (cons (quote )) (cons (quote )))) @@ -104,10 +106,15 @@ (define (symbol? x) (eq? (core:type x) )) -;; Hmm? (define (values? x) (eq? (core:type x) )) +(define (variable? x) + (eq? (core:type x) )) + +(define (variable-global? x) + (core:cdr x)) + (define (vector? x) (eq? (core:type x) )) diff --git a/scaffold/boot/51-module.scm b/scaffold/boot/51-module.scm index 34ce6646..7801aebb 100644 --- a/scaffold/boot/51-module.scm +++ b/scaffold/boot/51-module.scm @@ -111,4 +111,4 @@ (core:display-error module->file) (core:display-error "\n") (define %moduledir (string-append (getcwd) "/")) (mes-use-module (scaffold boot data module)) -(mes-use-module (scaffold boot data module)) +;; (mes-use-module (scaffold boot data module)) diff --git a/src/gc.c b/src/gc.c index e140b499..c9539b95 100644 --- a/src/gc.c +++ b/src/gc.c @@ -102,7 +102,8 @@ gc_loop (SCM scan) ///((internal)) || scan == 1 // null || NTYPE (scan) == TSPECIAL || NTYPE (scan) == TSTRING - || NTYPE (scan) == TSYMBOL) + || NTYPE (scan) == TSYMBOL + || NTYPE (scan) == TVARIABLE) { SCM car = gc_copy (g_news[scan].car); gc_relocate_car (scan, car); @@ -111,7 +112,8 @@ gc_loop (SCM scan) ///((internal)) || NTYPE (scan) == TCONTINUATION || NTYPE (scan) == TMACRO || NTYPE (scan) == TPAIR - || NTYPE (scan) == TVALUES) + || NTYPE (scan) == TVALUES + || NTYPE (scan) == TVARIABLE) && g_news[scan].cdr) // allow for 0 terminated list of symbols { SCM cdr = gc_copy (g_news[scan].cdr); @@ -133,7 +135,8 @@ gc_check () SCM gc () { - if (g_debug == 1) eputs ("."); + if (g_debug == 1) + eputs ("."); if (g_debug > 1) { eputs (";;; gc["); @@ -143,11 +146,13 @@ gc () eputs ("]..."); } g_free = 1; - if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) gc_up_arena (); + if (g_cells < g_news && ARENA_SIZE < MAX_ARENA_SIZE) + gc_up_arena (); for (int i=g_free; i 1) { diff --git a/src/lib.c b/src/lib.c index ec1702b0..91497418 100644 --- a/src/lib.c +++ b/src/lib.c @@ -56,7 +56,7 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p) case TCLOSURE: { fputs ("#", fd); break; } @@ -81,6 +81,15 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p) fputs (">", fd); break; } + case TVARIABLE: + { + fputs ("#", fd); + break; + } case TNUMBER: { fputs (itoa (VALUE (x)), fd); @@ -89,6 +98,12 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p) case TPAIR: { if (!cont) fputs ("(", fd); + if (CAR (x) == cell_closure) + fputs ("*closure* ", fd); + else + if (CAAR (x) == cell_closure) + fputs ("(*closure* ...) ", fd); + else if (CAR (x) == cell_circular) { fputs ("(*circ* . ", fd); @@ -97,8 +112,8 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p) while (x != cell_nil && i++ < 10) { g_depth = 1; - //display_helper (CAAR (x), 0, "", fd, write_p); fputs (" ", fd); - fdisplay_ (CAAR (x), fd, write_p); fputs (" ", fd); + display_helper (CAAR (x), 0, "", fd, write_p); fputs (" ", fd); + //fdisplay_ (CAAR (x), fd, write_p); fputs (" ", fd); x = CDR (x); } fputs (" ...)", fd); diff --git a/src/mes.c b/src/mes.c index 11b828b0..87c48ea1 100644 --- a/src/mes.c +++ b/src/mes.c @@ -32,7 +32,7 @@ int MAX_ARENA_SIZE = 80000000; // 32b: ~1GiB int MAX_ARENA_SIZE = 200000000; // 32b: 2GiB, 64b: 4GiB #endif -int GC_SAFETY = 250; +int GC_SAFETY = 2000; char *g_arena = 0; typedef int SCM; @@ -51,8 +51,11 @@ SCM r1 = 0; SCM r2 = 0; // continuation SCM r3 = 0; +// macro +SCM g_macros = 1; // cell_nil -enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVECTOR, TBROKEN_HEART}; + +enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART}; #if !_POSIX_SOURCE struct scm { @@ -86,9 +89,10 @@ struct scm { enum type_t type; union { char const* name; - SCM string; SCM car; SCM ref; + SCM string; + SCM variable; int length; }; union { @@ -97,6 +101,7 @@ struct scm { SCM cdr; SCM closure; SCM continuation; + SCM global_p; SCM macro; SCM vector; int hits; @@ -145,6 +150,7 @@ struct scm scm_symbol_set_x = {TSYMBOL, "set!",0}; struct scm scm_symbol_sc_expand = {TSYMBOL, "sc-expand",0}; struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-expand",0}; +struct scm scm_symbol_portable_macro_expand = {TSYMBOL, "portable-macro-expand",0}; struct scm scm_symbol_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0}; struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",0}; @@ -170,9 +176,8 @@ struct scm scm_symbol_mes_version = {TSYMBOL, "%version",0}; struct scm scm_symbol_car = {TSYMBOL, "car",0}; struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0}; -struct scm scm_symbol_null_p = {TSYMBOL, "null?",0}; -struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0}; -struct scm scm_symbol_cons = {TSYMBOL, "cons",0}; +struct scm scm_symbol_pmatch_car = {TSYMBOL, "pmatch-car",0}; +struct scm scm_symbol_pmatch_cdr = {TSYMBOL, "pmatch-cdr",0}; struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0}; struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",0}; @@ -181,11 +186,8 @@ struct scm scm_vm_apply = {TSPECIAL, "core:apply",0}; struct scm scm_vm_apply2 = {TSPECIAL, "*vm-apply2*",0}; struct scm scm_vm_eval = {TSPECIAL, "core:eval",0}; -//MES_FIXED_PRIMITIVES -struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0}; -struct scm scm_vm_eval_cdr = {TSPECIAL, "*vm-eval-cdr*",0}; -struct scm scm_vm_eval_cons = {TSPECIAL, "*vm-eval-cons*",0}; -struct scm scm_vm_eval_null_p = {TSPECIAL, "*vm-eval-null-p*",0}; +struct scm scm_vm_eval_pmatch_car = {TSPECIAL, "*vm-eval-pmatch-car*",0}; +struct scm scm_vm_eval_pmatch_cdr = {TSPECIAL, "*vm-eval-pmatch-cdr*",0}; struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0}; struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0}; @@ -262,11 +264,14 @@ int g_function = 0; #define LENGTH(x) g_cells[x].car #define REF(x) g_cells[x].car #define STRING(x) g_cells[x].car +#define VARIABLE(x) g_cells[x].car +#define VARIABLE_GLOBAL_P(x) g_cells[x].cdr #define CLOSURE(x) g_cells[x].cdr #define CONTINUATION(x) g_cells[x].cdr #define FUNCTION(x) g_functions[g_cells[x].cdr] +#define FUNCTION0(x) g_functions[g_cells[x].cdr].function #define MACRO(x) g_cells[x].cdr #define VALUE(x) g_cells[x].cdr #define VECTOR(x) g_cells[x].cdr @@ -282,12 +287,16 @@ int g_function = 0; #define LENGTH(x) g_cells[x].length #define NAME(x) g_cells[x].name #define STRING(x) g_cells[x].string +#define VARIABLE(x) g_cells[x].variable +#define VARIABLE_GLOBAL_P(x) g_cells[x].cdr + #define CLOSURE(x) g_cells[x].closure #define MACRO(x) g_cells[x].macro #define REF(x) g_cells[x].ref #define VALUE(x) g_cells[x].value #define VECTOR(x) g_cells[x].vector #define FUNCTION(x) g_functions[g_cells[x].function] +#define FUNCTION0(x) g_functions[g_cells[x].function].function0 #define NLENGTH(x) g_news[x].length @@ -342,15 +351,15 @@ make_cell_ (SCM type, SCM car, SCM cdr) TYPE (x) = VALUE (type); if (VALUE (type) == TCHAR || VALUE (type) == TNUMBER) { if (car) CAR (x) = CAR (car); - if (cdr) CDR(x) = CDR(cdr); + if (cdr) CDR (x) = CDR (cdr); } else if (VALUE (type) == TFUNCTION) { if (car) CAR (x) = car; - if (cdr) CDR(x) = CDR(cdr); + if (cdr) CDR (x) = CDR (cdr); } else { CAR (x) = car; - CDR(x) = cdr; + CDR (x) = cdr; } return x; } @@ -654,8 +663,8 @@ assq (SCM x, SCM a) SCM v = STRING (x); while (a != cell_nil && v != STRING (CAAR (a))) a = CDR (a); break; } - // case TSYMBOL: - // case TSPECIAL: + // case TSYMBOL: + // case TSPECIAL: default: while (a != cell_nil && x != CAAR (a)) a = CDR (a); break; } @@ -689,7 +698,11 @@ set_cdr_x (SCM x, SCM e) SCM set_env_x (SCM x, SCM e, SCM a) { - SCM p = assert_defined (x, assq (x, a)); + SCM p; + if (TYPE (x) == TVARIABLE) + p = VARIABLE (x); + else + p = assert_defined (x, assq (x, a)); if (TYPE (p) != TPAIR) error (cell_symbol_not_a_pair, cons (p, x)); return set_cdr_x (p, e); } @@ -709,12 +722,18 @@ make_closure_ (SCM args, SCM body, SCM a) ///((internal)) return make_cell_ (tmp_num_ (TCLOSURE), cell_f, cons (cons (cell_circular, a), cons (args, body))); } +SCM +make_variable_ (SCM var, SCM global_p) ///((internal)) +{ + return make_cell_ (tmp_num_ (TVARIABLE), var, global_p); +} + SCM lookup_macro_ (SCM x, SCM a) ///((internal)) { if (TYPE (x) != TSYMBOL) return cell_f; - SCM m = assq_ref_env (x, a); - if (TYPE (m) == TMACRO) return MACRO (m); + SCM m = assq (x, a); + if (m != cell_f) return MACRO (CDR (m)); return cell_f; } @@ -750,10 +769,104 @@ gc_pop_frame () ///((internal)) return frame; } +char const* string_to_cstring (SCM s); + +SCM +add_formals (SCM formals, SCM x) +{ + while (TYPE (x) == TPAIR) + { + formals = cons (CAR (x), formals); + x = CDR (x); + } + if (TYPE (x) == TSYMBOL) + formals = cons (x, formals); + return formals; +} + +int +formal_p (SCM x, SCM formals) /// ((internal)) +{ + if (TYPE (formals) == TSYMBOL) + { + if (x == formals) return x; + else return cell_f; + } + while (TYPE (formals) == TPAIR && CAR (formals) != x) + formals = CDR (formals); + if (TYPE (formals) == TSYMBOL) + return formals == x; + return TYPE (formals) == TPAIR; +} + +SCM +expand_variable_ (SCM x, SCM formals, int top_p) ///((internal)) +{ + while (TYPE (x) == TPAIR) + { + if (TYPE (CAR (x)) == TPAIR) + { + if (CAAR (x) == cell_symbol_lambda) + { + SCM f = CAR (CDAR (x)); + formals = add_formals (formals, f); + } + else if (CAAR (x) == cell_symbol_define + || CAAR (x) == cell_symbol_define_macro) + { + SCM f = CAR (CDAR (x)); + formals = add_formals (formals, f); + } + if (CAAR (x) != cell_symbol_quote) + expand_variable_ (CAR (x), formals, 0); + } + else + { + if (CAR (x) == cell_symbol_lambda) + { + SCM f = CADR (x); + formals = add_formals (formals, f); + x = CDR (x); + } + else if (CAR (x) == cell_symbol_define + || CAR (x) == cell_symbol_define_macro) + { + SCM f = CADR (x); + if (top_p && TYPE (f) == TPAIR) + f = CDR (f); + formals = add_formals (formals, f); + x = CDR (x); + } + else if (CAR (x) == cell_symbol_quote) + return cell_unspecified; + else if (TYPE (CAR (x)) == TSYMBOL + && CAR (x) != cell_begin + && CAR (x) != cell_symbol_begin + && 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, cell_t); + } + } + x = CDR (x); + top_p = 0; + } + return cell_unspecified; +} + +SCM +expand_variable (SCM x, SCM formals) ///((internal)) +{ + return expand_variable_ (x, formals, 1); +} + SCM eval_apply () { - int expanding_p = 0; eval_apply: gc_check (); switch (r3) @@ -764,12 +877,8 @@ eval_apply () case cell_vm_apply: goto apply; case cell_vm_apply2: goto apply2; case cell_vm_eval: goto eval; -#if MES_FIXED_PRIMITIVES - case cell_vm_eval_car: goto eval_car; - case cell_vm_eval_cdr: goto eval_cdr; - case cell_vm_eval_cons: goto eval_cons; - case cell_vm_eval_null_p: goto eval_null_p; -#endif + case cell_vm_eval_pmatch_car: goto eval_pmatch_car; + case cell_vm_eval_pmatch_cdr: goto eval_pmatch_cdr; case cell_vm_eval_define: goto eval_define; case cell_vm_eval_set_x: goto eval_set_x; case cell_vm_eval_macro_expand_eval: goto eval_macro_expand_eval; @@ -818,31 +927,33 @@ eval_apply () gc_check (); switch (TYPE (CAR (r1))) { - case TFUNCTION: { - check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1)); - r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply - goto vm_return; - } + case TFUNCTION: + { + check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1)); + r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply + goto vm_return; + } case TCLOSURE: { SCM cl = CLOSURE (CAR (r1)); - SCM formals = CADR (cl); SCM body = CDDR (cl); + SCM formals = CADR (cl); + SCM args = CDR (r1); SCM aa = CDAR (cl); aa = CDR (aa); check_formals (CAR (r1), formals, CDR (r1)); - SCM p = pairlis (formals, CDR (r1), aa); + SCM p = pairlis (formals, args, aa); call_lambda (body, p, aa, r0); goto begin; } - case TCONTINUATION: - { - x = r1; - g_stack = CONTINUATION (CAR (r1)); - gc_pop_frame (); - r1 = CADR (x); - goto eval_apply; - } + case TCONTINUATION: + { + x = r1; + g_stack = CONTINUATION (CAR (r1)); + gc_pop_frame (); + r1 = CADR (x); + goto eval_apply; + } case TSPECIAL: { switch (CAR (r1)) @@ -886,9 +997,10 @@ eval_apply () case cell_symbol_lambda: { SCM formals = CADR (CAR (r1)); + SCM args = CDR (r1); SCM body = CDDR (CAR (r1)); SCM p = pairlis (formals, CDR (r1), r0); - check_formals (r1, formals, CDR (r1)); + check_formals (r1, formals, args); call_lambda (body, p, p, r0); goto begin; } @@ -910,59 +1022,50 @@ eval_apply () { switch (CAR (r1)) { -#if MES_FIXED_PRIMITIVES - case cell_symbol_car: + case cell_symbol_pmatch_car: { - push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval; - eval_car: - x = r1; gc_pop_frame (); r1 = CAR (x); goto eval_apply; - } - case cell_symbol_cdr: - { - push_cc (CADR (r1), r1, r0, cell_vm_eval_cdr); goto eval; - eval_cdr: - x = r1; gc_pop_frame (); r1 = CDR (x); goto eval_apply; - } - case cell_symbol_cons: { - push_cc (CDR (r1), r1, r0, cell_vm_eval_cons); goto evlis; - eval_cons: - x = r1; - gc_pop_frame (); - r1 = cons (CAR (x), CADR (x)); - goto eval_apply; - } - case cell_symbol_null_p: - { - push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p); + push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car); goto eval; - eval_null_p: - x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply; + eval_pmatch_car: + x = r1; + gc_pop_frame (); + r1 = CAR (x); + goto eval_apply; + } + case cell_symbol_pmatch_cdr: + { + push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr); + goto eval; + eval_pmatch_cdr: + x = r1; + gc_pop_frame (); + r1 = CDR (x); + goto eval_apply; } -#else - eval_car:; - eval_cdr:; - eval_cons:; - eval_null_p:; - -#endif // MES_FIXED_PRIMITIVES case cell_symbol_quote: { - x = r1; gc_pop_frame (); r1 = CADR (x); goto eval_apply; + x = r1; + gc_pop_frame (); + r1 = CADR (x); + goto eval_apply; } case cell_symbol_begin: goto begin; case cell_symbol_lambda: { - r1 = make_closure_ (CADR (r1), CDDR (r1), assq (cell_closure, r0)); + r1 = make_closure_ (CADR (r1), CDDR (r1), r0); goto vm_return; } - case cell_symbol_if: {r1=CDR (r1); goto vm_if;} + case cell_symbol_if: + { + r1=CDR (r1); + goto vm_if; + } case cell_symbol_set_x: { push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x); goto eval; eval_set_x: - x = r2; - r1 = set_env_x (CADR (x), r1, r0); + r1 = set_env_x (CADR (r2), r1, r0); goto vm_return; } case cell_vm_macro_expand: @@ -971,18 +1074,44 @@ eval_apply () goto eval; eval_macro_expand_eval: push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand); - expanding_p++; goto macro_expand; eval_macro_expand_expand: - expanding_p--; goto vm_return; } default: { if (TYPE (r1) == TPAIR && (CAR (r1) == cell_symbol_define - || CAR (r1) == cell_symbol_define_macro)) + || CAR (r1) == cell_symbol_define_macro)) { + int global_p = CAAR (r0) != cell_closure; + int macro_p = CAR (r1) == cell_symbol_define_macro; + if (global_p) + { + SCM name = CADR (r1); + if (TYPE (CADR (r1)) == TPAIR) + name = CAR (name); + if (macro_p) + { + SCM entry = assq (name, g_macros); + if (entry == cell_f) + { + entry = cons (name, cell_f); + g_macros = cons (entry, g_macros); + } + } + else + { + SCM entry = assq (name, r0); + if (entry == cell_f) + { + entry = cons (name, cell_f); + SCM aa = cons (entry, cell_nil); + set_cdr_x (aa, cdr (r0)); + set_cdr_x (r0, aa); + } + } + } r2 = r1; if (TYPE (CADR (r1)) != TPAIR) { @@ -992,41 +1121,68 @@ eval_apply () else { SCM p = pairlis (CADR (r1), CADR (r1), r0); - SCM args = CDR (CADR (r1)); + SCM formals = CDR (CADR (r1)); SCM body = CDDR (r1); - r1 = cons (cell_symbol_lambda, cons (args, body)); + + if (macro_p || global_p) expand_variable (body, formals); + r1 = cons (cell_symbol_lambda, cons (formals, body)); push_cc (r1, r2, p, cell_vm_eval_define); goto eval; } eval_define:; SCM name = CADR (r2); - if (TYPE (CADR (r2)) == TPAIR) name = CAR (name); - if (CAR (r2) == cell_symbol_define_macro) - r1 = MAKE_MACRO (name, r1); - SCM entry = cons (name, r1); - SCM aa = cons (entry, cell_nil); - set_cdr_x (aa, cdr (r0)); - set_cdr_x (r0, aa); - SCM cl = assq (cell_closure, r0); - set_cdr_x (cl, aa); - //r1 = entry; + if (TYPE (CADR (r2)) == TPAIR) + name = CAR (name); + if (macro_p) + { + SCM entry = assq (name, g_macros); + r1 = MAKE_MACRO (name, r1); + set_cdr_x (entry, r1); + } + else if (global_p) + { + SCM entry = assq (name, r0); + set_cdr_x (entry, r1); + } + else + { + SCM entry = cons (name, r1); + SCM aa = cons (entry, cell_nil); + set_cdr_x (aa, cdr (r0)); + set_cdr_x (r0, aa); + SCM cl = assq (cell_closure, r0); + set_cdr_x (cl, aa); + } r1 = cell_unspecified; goto vm_return; } - push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval; + push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); + goto eval; eval_check_func: - push_cc (CDR (r2), r2, r0, cell_vm_eval2); goto evlis; + push_cc (CDR (r2), r2, r0, cell_vm_eval2); + goto evlis; eval2: r1 = cons (CAR (r2), r1); goto apply; - } + } } } case TSYMBOL: { + if (r1 == cell_symbol_current_module) goto vm_return; + if (r1 == cell_symbol_begin) // FIXME + { + r1 = cell_begin; + goto vm_return; + } r1 = assert_defined (r1, assq_ref_env (r1, r0)); goto vm_return; } + case TVARIABLE: + { + r1 = CDR (VARIABLE (r1)); + goto vm_return; + } default: goto vm_return; } @@ -1038,13 +1194,24 @@ eval_apply () if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote) goto vm_return; + if (CAR (r1) == cell_symbol_lambda) + { + push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_lambda); + goto macro_expand; + macro_expand_lambda: + CDDR (r2) = r1; + r1 = r2; + goto vm_return; + } + if (TYPE (r1) == TPAIR - && (macro = lookup_macro_ (CAR (r1), r0)) != cell_f) + && (macro = lookup_macro_ (CAR (r1), g_macros)) != cell_f) { r1 = cons (macro, CDR (r1)); push_cc (r1, cell_nil, r0, cell_vm_macro_expand); goto apply; } + if (CAR (r1) == cell_symbol_define || CAR (r1) == cell_symbol_define_macro) { @@ -1063,16 +1230,6 @@ eval_apply () goto vm_return; } - if (CAR (r1) == cell_symbol_lambda) - { - push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_lambda); - goto macro_expand; - macro_expand_lambda: - CDDR (r2) = r1; - r1 = r2; - goto vm_return; - } - if (CAR (r1) == cell_symbol_set_x) { push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_set_x); @@ -1086,6 +1243,7 @@ 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 = assq (CAR (r1), expanders)) != cell_f)) { @@ -1192,10 +1350,8 @@ eval_apply () } push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_macro); - expanding_p++; goto macro_expand; begin_expand_macro: - expanding_p--; if (r1 != CAR (r2)) { CAR (r2) = r1; @@ -1203,7 +1359,8 @@ eval_apply () continue; } r1 = r2; - + expand_variable (CAR (r1), cell_nil); + //eputs ("expanded r1="); write_error_ (CAR (r1)); eputs ("\n"); push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval); goto eval; begin_expand_eval: @@ -1372,7 +1529,10 @@ mes_symbols () ///((internal)) a = acons (cell_symbol_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a); a = acons (cell_symbol_dot, cell_dot, a); + a = acons (cell_symbol_begin, cell_begin, a); + a = acons (cell_symbol_quasisyntax, cell_symbol_quasisyntax, a); + a = acons (cell_symbol_call_with_values, cell_symbol_call_with_values, 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); @@ -1403,7 +1563,7 @@ mes_builtins (SCM a) ///((internal)) #if !__GNUC__ || !_POSIX_SOURCE #include "mes.mes.i" -// Do not sort: Order of these includes define builtins + // Do not sort: Order of these includes define builtins #include "posix.mes.i" #include "math.mes.i" #include "lib.mes.i" @@ -1421,7 +1581,7 @@ mes_builtins (SCM a) ///((internal)) #else #include "mes.i" -// Do not sort: Order of these includes define builtins + // Do not sort: Order of these includes define builtins #include "posix.i" #include "math.i" #include "lib.i" diff --git a/src/reader.c b/src/reader.c index 3269c456..2e69b20e 100644 --- a/src/reader.c +++ b/src/reader.c @@ -334,7 +334,7 @@ dump () eputs ("\n"); } - for (int i=0; i