mes: Single environment lookup for variables, SICP chapter 3.
* src/mes.c (t): Add TVARIABLE. (scm_vm_eval_deref): New vm special. (make_vref_): New internal function. (eval_apply): WIP: replace symbols with their variable reference. * src/gc.c (gc_loop): Handle TVARIABLE. * src/lib.c (display_helper): Handle TVARIABLE. * module/mes/type-0.mes (<cell:variable>): New variable. (cell:type-alist): Add it. (variable?): New function. * module/mes/display.mes (display): Handle <variable>.
This commit is contained in:
Jan Nieuwenhuizen
parent
d1444ead65
commit
9fc27ee25a
12
make.scm
12
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")))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -95,6 +95,12 @@
|
|||
(display "#<macro " port)
|
||||
(display (core:cdr x) port)
|
||||
(display ">" port))
|
||||
((variable? x)
|
||||
(display "#<variable " port)
|
||||
(if (variable-global? x)
|
||||
(display "*global* " port))
|
||||
(display (car (core:car x)) port)
|
||||
(display ">" port))
|
||||
((number? x)
|
||||
(display (number->string x) port))
|
||||
((pair? x)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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 <janneke@gnu.org>
|
||||
;;;
|
||||
;;; 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))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -38,8 +38,9 @@
|
|||
(define <cell:string> 10)
|
||||
(define <cell:symbol> 11)
|
||||
(define <cell:values> 12)
|
||||
(define <cell:vector> 13)
|
||||
(define <cell:broken-heart> 14)
|
||||
(define <cell:variable> 13)
|
||||
(define <cell:vector> 14)
|
||||
(define <cell:broken-heart> 15)
|
||||
|
||||
(define cell:type-alist
|
||||
(list (cons <cell:char> (quote <cell:char>))
|
||||
|
|
@ -55,6 +56,7 @@
|
|||
(cons <cell:string> (quote <cell:string>))
|
||||
(cons <cell:symbol> (quote <cell:symbol>))
|
||||
(cons <cell:values> (quote <cell:values>))
|
||||
(cons <cell:variable> (quote <cell:variable>))
|
||||
(cons <cell:vector> (quote <cell:vector>))
|
||||
(cons <cell:broken-heart> (quote <cell:broken-heart>))))
|
||||
|
||||
|
|
@ -104,10 +106,15 @@
|
|||
(define (symbol? x)
|
||||
(eq? (core:type x) <cell:symbol>))
|
||||
|
||||
;; Hmm?
|
||||
(define (values? x)
|
||||
(eq? (core:type x) <cell:values>))
|
||||
|
||||
(define (variable? x)
|
||||
(eq? (core:type x) <cell:variable>))
|
||||
|
||||
(define (variable-global? x)
|
||||
(core:cdr x))
|
||||
|
||||
(define (vector? x)
|
||||
(eq? (core:type x) <cell:vector>))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
13
src/gc.c
13
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<g_symbol_max; i++)
|
||||
gc_copy (i);
|
||||
make_tmps (g_news);
|
||||
g_symbols = gc_copy (g_symbols);
|
||||
g_macros = gc_copy (g_macros);
|
||||
SCM new = gc_copy (g_stack);
|
||||
if (g_debug > 1)
|
||||
{
|
||||
|
|
|
|||
21
src/lib.c
21
src/lib.c
|
|
@ -56,7 +56,7 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
|
|||
case TCLOSURE:
|
||||
{
|
||||
fputs ("#<closure ", fd);
|
||||
display_helper (CDR (x), cont, "", fd, 0);
|
||||
//display_helper (CDR (x), cont, "", fd, 0);
|
||||
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 ("#<variable ", fd);
|
||||
if (VARIABLE_GLOBAL_P (x) == cell_t)
|
||||
fputs ("*global* ", fd);
|
||||
display_helper (CAR (VARIABLE (x)), cont, "", fd, 0);
|
||||
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);
|
||||
|
|
|
|||
320
src/mes.c
320
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
|
||||
|
||||
|
|
@ -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,7 +927,8 @@ eval_apply ()
|
|||
gc_check ();
|
||||
switch (TYPE (CAR (r1)))
|
||||
{
|
||||
case TFUNCTION: {
|
||||
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;
|
||||
|
|
@ -826,12 +936,13 @@ eval_apply ()
|
|||
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;
|
||||
}
|
||||
|
|
@ -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:
|
||||
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
|
||||
goto eval;
|
||||
eval_pmatch_car:
|
||||
x = r1;
|
||||
gc_pop_frame ();
|
||||
r1 = cons (CAR (x), CADR (x));
|
||||
r1 = CAR (x);
|
||||
goto eval_apply;
|
||||
}
|
||||
case cell_symbol_null_p:
|
||||
case cell_symbol_pmatch_cdr:
|
||||
{
|
||||
push_cc (CADR (r1), r1, r0, cell_vm_eval_null_p);
|
||||
push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
|
||||
goto eval;
|
||||
eval_null_p:
|
||||
x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply;
|
||||
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,10 +1074,8 @@ 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:
|
||||
|
|
@ -983,6 +1084,34 @@ eval_apply ()
|
|||
&& (CAR (r1) == cell_symbol_define
|
||||
|| 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,30 +1121,46 @@ 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)
|
||||
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 = entry;
|
||||
}
|
||||
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;
|
||||
|
|
@ -1024,9 +1169,20 @@ eval_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);
|
||||
|
|
|
|||
|
|
@ -28,7 +28,11 @@ exit $?
|
|||
|
||||
(cond-expand
|
||||
(guile
|
||||
(use-modules (system base pmatch)))
|
||||
(use-modules (system base pmatch))
|
||||
;;(include-from-path "mes/pmatch.scm")
|
||||
;;(include-from-path "mes-0.scm")
|
||||
;;(include-from-path "mes/test.mes")
|
||||
)
|
||||
(mes
|
||||
(mes-use-module (mes test))
|
||||
(mes-use-module (mes pmatch))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue