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

mes: Single environment lookup for variables, SICP chapter 3.

Browse source 
* 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 2017-12-09 08:33:50 +01:00
parent d1444ead65
commit 9fc27ee25a
15 changed files with 367 additions and 156 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
make.scm
View file

@ -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 (snarf "src/vector.c" #:mes? #t))))
(add-target (bin.gcc "src/mes.c" #:dependencies gcc-snarf-targets (add-target (bin.gcc "src/mes.c" #:dependencies gcc-snarf-targets
#:defines `("MES_FIXED_PRIMITIVES=1" #:defines `("POSIX=1"
"MES_FULL=1"
"POSIX=1"
,(string-append "VERSION=\"" %version "\"") ,(string-append "VERSION=\"" %version "\"")
,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"") ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"")
,(string-append "PREFIX=\"" %prefix "\"")) ,(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 (add-target (bin.gcc "src/mes.c" #:libc libc-gcc.mlibc-o
#:dependencies mes-snarf-targets #:dependencies mes-snarf-targets
#:defines `( "MES_FIXED_PRIMITIVES=1" #:defines `(,(string-append "VERSION=\"" %version "\"")
"MES_FULL=1"
,(string-append "VERSION=\"" %version "\"")
,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") "/" %moduledir "/") "\"") ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") "/" %moduledir "/") "\"")
,(string-append "PREFIX=\"" %prefix "\"")) ,(string-append "PREFIX=\"" %prefix "\""))
#:includes '("src"))) #:includes '("src")))
(add-target (bin.mescc "src/mes.c" #:dependencies mes-snarf-targets (add-target (bin.mescc "src/mes.c" #:dependencies mes-snarf-targets
#:defines `("MES_FIXED_PRIMITIVES=1" #:defines `(,(string-append "VERSION=\"" %version "\"")
"MES_FULL=1"
,(string-append "VERSION=\"" %version "\"")
,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"") ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"")
,(string-append "PREFIX=\"" %prefix "\"")) ,(string-append "PREFIX=\"" %prefix "\""))
#:includes '("src"))) #:includes '("src")))

4
module/language/c99/compiler.mes
View file

@ -1223,8 +1223,8 @@
(info (append-text info (wrap-as `((#:label ,skip-b-label)))))) (info (append-text info (wrap-as `((#:label ,skip-b-label))))))
info)) info))
((cast ,cast ,o) ((cast ,type ,expr)
((expr->accu info) o)) ((expr->accu info) expr))
((assn-expr (de-ref (post-inc (p-expr (ident ,name)))) (op ,op) ,b) ((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))) (let* ((info ((expr->accu info) `(assn-expr (de-ref (p-expr (ident ,name))) (op ,op) ,b)))

5
module/mes/boot-0.scm
View file

@ -75,7 +75,9 @@
(if (null? lst) (list) (if (null? lst) (list)
(cons (f (car lst)) (map1 f (cdr lst))))) (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) (define (cons* . rest)
(if (null? (cdr rest)) (car rest) (if (null? (cdr rest)) (car rest)
@ -104,6 +106,7 @@
(list (quote if) (quote r) (quote r) (list (quote if) (quote r) (quote r)
(cons (quote or) (cdr x)))) (cons (quote or) (cdr x))))
(car x))))) (car x)))))
(define-macro (module-define! module name value) (define-macro (module-define! module name value)
;;(list 'define name value) ;;(list 'define name value)
#t) #t)

6
module/mes/display.mes
View file

@ -95,6 +95,12 @@
(display "#<macro " port) (display "#<macro " port)
(display (core:cdr x) port) (display (core:cdr x) port)
(display ">" 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) ((number? x)
(display (number->string x) port)) (display (number->string x) port))
((pair? x) ((pair? x)

4
module/mes/guile.scm
View file

@ -35,12 +35,16 @@
core:write-error core:write-error
core:write-port core:write-port
core:type core:type
pmatch-car
pmatch-cdr
) )
;;#:re-export (open-input-file open-input-string with-input-from-string) ;;#:re-export (open-input-file open-input-string with-input-from-string)
) )
(cond-expand (cond-expand
(guile (guile
(define pmatch-car car)
(define pmatch-cdr cdr)
(define core:exit exit) (define core:exit exit)
(define core:display display) (define core:display display)
(define core:display-port display) (define core:display-port display)

34
module/mes/module.mes
View file

@ -26,15 +26,6 @@
(string-append (string-join (map symbol->string o) "/") ".mes")) (string-append (string-join (map symbol->string o) "/") ".mes"))
(define *modules* '(mes/base-0.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) (define-macro (mes-use-module module)
(list 'if (list not (list memq (list string->symbol (module->file module)) '*modules*)) (list 'if (list not (list memq (list string->symbol (module->file module)) '*modules*))
(list (list
@ -46,3 +37,28 @@
(list core:display-error ";;; already loaded: ") (list core:display-error ";;; already loaded: ")
(list core:display-error (list 'quote module)) (list core:display-error (list 'quote module))
(list core:display-error "\n"))))) (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")
)

14
module/mes/pmatch.scm
View file

@ -3,6 +3,7 @@
;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc ;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc
;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov ;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov
;;; Copyright (C) 2007 Daniel P. Friedman ;;; 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 ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -51,20 +52,17 @@
(define-module (system base pmatch) (define-module (system base pmatch)
#:export-syntax (pmatch)) #:export-syntax (pmatch))
(define-syntax-rule (pmatch e cs ...) (define-syntax pmatch
(let ((v e)) (pmatch1 v cs ...)))
(define-syntax pmatch1
(syntax-rules (else guard) (syntax-rules (else guard)
((_ v) (if #f #f)) ((_ v) (if #f #f))
((_ v (else e0 e ...)) (let () e0 e ...)) ((_ v (else e0 e ...)) (let () e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...) ((_ v (pat (guard g ...) e0 e ...) cs ...)
(let ((fk (lambda () (pmatch1 v cs ...)))) (let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat (ppat v pat
(if (and g ...) (let () e0 e ...) (fk)) (if (and g ...) (let () e0 e ...) (fk))
(fk)))) (fk))))
((_ v (pat e0 e ...) cs ...) ((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (pmatch1 v cs ...)))) (let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat (let () e0 e ...) (fk)))))) (ppat v pat (let () e0 e ...) (fk))))))
(define-syntax ppat (define-syntax ppat
@ -76,8 +74,6 @@
((_ v (unquote var) kt kf) (let ((var v)) kt)) ((_ v (unquote var) kt kf) (let ((var v)) kt))
((_ v (x . y) kt kf) ((_ v (x . y) kt kf)
(if (pair? v) (if (pair? v)
(let ((vx (car v)) (vy (cdr v))) (ppat (pmatch-car v) x (ppat (pmatch-cdr v) y kt kf) kf)
;;(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))
kf)) kf))
((_ v lit kt kf) (if (eq? v (quote lit)) kt kf)))) ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))

1
module/mes/psyntax-1.mes
View file

@ -27,5 +27,6 @@
(define datum->syntax datum->syntax-object) (define datum->syntax datum->syntax-object)
(define syntax->datum syntax-object->datum) (define syntax->datum syntax-object->datum)
(define-macro (portable-macro-expand) #t)
(set! macro-expand sc-expand) (set! macro-expand sc-expand)

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

@ -38,8 +38,9 @@
(define <cell:string> 10) (define <cell:string> 10)
(define <cell:symbol> 11) (define <cell:symbol> 11)
(define <cell:values> 12) (define <cell:values> 12)
(define <cell:vector> 13) (define <cell:variable> 13)
(define <cell:broken-heart> 14) (define <cell:vector> 14)
(define <cell:broken-heart> 15)
(define cell:type-alist (define cell:type-alist
(list (cons <cell:char> (quote <cell:char>)) (list (cons <cell:char> (quote <cell:char>))
@ -55,6 +56,7 @@
(cons <cell:string> (quote <cell:string>)) (cons <cell:string> (quote <cell:string>))
(cons <cell:symbol> (quote <cell:symbol>)) (cons <cell:symbol> (quote <cell:symbol>))
(cons <cell:values> (quote <cell:values>)) (cons <cell:values> (quote <cell:values>))
(cons <cell:variable> (quote <cell:variable>))
(cons <cell:vector> (quote <cell:vector>)) (cons <cell:vector> (quote <cell:vector>))
(cons <cell:broken-heart> (quote <cell:broken-heart>)))) (cons <cell:broken-heart> (quote <cell:broken-heart>))))
@ -104,10 +106,15 @@
(define (symbol? x) (define (symbol? x)
(eq? (core:type x) <cell:symbol>)) (eq? (core:type x) <cell:symbol>))
;; Hmm?
(define (values? x) (define (values? x)
(eq? (core:type x) <cell:values>)) (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) (define (vector? x)
(eq? (core:type x) <cell:vector>)) (eq? (core:type x) <cell:vector>))

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

@ -111,4 +111,4 @@
(core:display-error module->file) (core:display-error "\n") (core:display-error module->file) (core:display-error "\n")
(define %moduledir (string-append (getcwd) "/")) (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)) ;; (mes-use-module (scaffold boot data module))

13
src/gc.c
View file

@ -102,7 +102,8 @@ gc_loop (SCM scan) ///((internal))
|| scan == 1 // null || scan == 1 // null
|| NTYPE (scan) == TSPECIAL || NTYPE (scan) == TSPECIAL
|| NTYPE (scan) == TSTRING || NTYPE (scan) == TSTRING
|| NTYPE (scan) == TSYMBOL) || NTYPE (scan) == TSYMBOL
|| NTYPE (scan) == TVARIABLE)
{ {
SCM car = gc_copy (g_news[scan].car); SCM car = gc_copy (g_news[scan].car);
gc_relocate_car (scan, car); gc_relocate_car (scan, car);
@ -111,7 +112,8 @@ gc_loop (SCM scan) ///((internal))
|| NTYPE (scan) == TCONTINUATION || NTYPE (scan) == TCONTINUATION
|| NTYPE (scan) == TMACRO || NTYPE (scan) == TMACRO
|| NTYPE (scan) == TPAIR || NTYPE (scan) == TPAIR
|| NTYPE (scan) == TVALUES) || NTYPE (scan) == TVALUES
|| NTYPE (scan) == TVARIABLE)
&& g_news[scan].cdr) // allow for 0 terminated list of symbols && g_news[scan].cdr) // allow for 0 terminated list of symbols
{ {
SCM cdr = gc_copy (g_news[scan].cdr); SCM cdr = gc_copy (g_news[scan].cdr);
@ -133,7 +135,8 @@ gc_check ()
SCM SCM
gc () gc ()
{ {
if (g_debug == 1) eputs ("."); if (g_debug == 1)
eputs (".");
if (g_debug > 1) if (g_debug > 1)
{ {
eputs (";;; gc["); eputs (";;; gc[");
@ -143,11 +146,13 @@ gc ()
eputs ("]..."); eputs ("]...");
} }
g_free = 1; 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++) for (int i=g_free; i<g_symbol_max; i++)
gc_copy (i); gc_copy (i);
make_tmps (g_news); make_tmps (g_news);
g_symbols = gc_copy (g_symbols); g_symbols = gc_copy (g_symbols);
g_macros = gc_copy (g_macros);
SCM new = gc_copy (g_stack); SCM new = gc_copy (g_stack);
if (g_debug > 1) if (g_debug > 1)
{ {

21
src/lib.c
View file

@ -56,7 +56,7 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
case TCLOSURE: case TCLOSURE:
{ {
fputs ("#<closure ", fd); fputs ("#<closure ", fd);
display_helper (CDR (x), cont, "", fd, 0); //display_helper (CDR (x), cont, "", fd, 0);
fputs (">", fd); fputs (">", fd);
break; break;
} }
@ -81,6 +81,15 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
fputs (">", fd); fputs (">", fd);
break; 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: case TNUMBER:
{ {
fputs (itoa (VALUE (x)), fd); fputs (itoa (VALUE (x)), fd);
@ -89,6 +98,12 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p)
case TPAIR: case TPAIR:
{ {
if (!cont) fputs ("(", fd); 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) if (CAR (x) == cell_circular)
{ {
fputs ("(*circ* . ", fd); 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) while (x != cell_nil && i++ < 10)
{ {
g_depth = 1; g_depth = 1;
//display_helper (CAAR (x), 0, "", fd, write_p); fputs (" ", fd); display_helper (CAAR (x), 0, "", fd, write_p); fputs (" ", fd);
fdisplay_ (CAAR (x), fd, write_p); fputs (" ", fd); //fdisplay_ (CAAR (x), fd, write_p); fputs (" ", fd);
x = CDR (x); x = CDR (x);
} }
fputs (" ...)", fd); fputs (" ...)", fd);

320
src/mes.c
View file

@ -32,7 +32,7 @@ int MAX_ARENA_SIZE = 80000000; // 32b: ~1GiB
int MAX_ARENA_SIZE = 200000000; // 32b: 2GiB, 64b: 4GiB int MAX_ARENA_SIZE = 200000000; // 32b: 2GiB, 64b: 4GiB
#endif #endif
int GC_SAFETY = 250; int GC_SAFETY = 2000;
char *g_arena = 0; char *g_arena = 0;
typedef int SCM; typedef int SCM;
@ -51,8 +51,11 @@ SCM r1 = 0;
SCM r2 = 0; SCM r2 = 0;
// continuation // continuation
SCM r3 = 0; 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 #if !_POSIX_SOURCE
struct scm { struct scm {
@ -86,9 +89,10 @@ struct scm {
enum type_t type; enum type_t type;
union { union {
char const* name; char const* name;
SCM string;
SCM car; SCM car;
SCM ref; SCM ref;
SCM string;
SCM variable;
int length; int length;
}; };
union { union {
@ -97,6 +101,7 @@ struct scm {
SCM cdr; SCM cdr;
SCM closure; SCM closure;
SCM continuation; SCM continuation;
SCM global_p;
SCM macro; SCM macro;
SCM vector; SCM vector;
int hits; 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_sc_expand = {TSYMBOL, "sc-expand",0};
struct scm scm_symbol_macro_expand = {TSYMBOL, "macro-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_sc_expander_alist = {TSYMBOL, "*sc-expander-alist*",0};
struct scm scm_symbol_call_with_values = {TSYMBOL, "call-with-values",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_car = {TSYMBOL, "car",0};
struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0}; struct scm scm_symbol_cdr = {TSYMBOL, "cdr",0};
struct scm scm_symbol_null_p = {TSYMBOL, "null?",0}; struct scm scm_symbol_pmatch_car = {TSYMBOL, "pmatch-car",0};
struct scm scm_symbol_eq_p = {TSYMBOL, "eq?",0}; struct scm scm_symbol_pmatch_cdr = {TSYMBOL, "pmatch-cdr",0};
struct scm scm_symbol_cons = {TSYMBOL, "cons",0};
struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0}; struct scm scm_vm_evlis = {TSPECIAL, "*vm-evlis*",0};
struct scm scm_vm_evlis2 = {TSPECIAL, "*vm-evlis2*",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_apply2 = {TSPECIAL, "*vm-apply2*",0};
struct scm scm_vm_eval = {TSPECIAL, "core:eval",0}; struct scm scm_vm_eval = {TSPECIAL, "core:eval",0};
//MES_FIXED_PRIMITIVES struct scm scm_vm_eval_pmatch_car = {TSPECIAL, "*vm-eval-pmatch-car*",0};
struct scm scm_vm_eval_car = {TSPECIAL, "*vm-eval-car*",0}; struct scm scm_vm_eval_pmatch_cdr = {TSPECIAL, "*vm-eval-pmatch-cdr*",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_define = {TSPECIAL, "*vm-eval-define*",0}; struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0};
struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",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 LENGTH(x) g_cells[x].car
#define REF(x) g_cells[x].car #define REF(x) g_cells[x].car
#define STRING(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 CLOSURE(x) g_cells[x].cdr
#define CONTINUATION(x) g_cells[x].cdr #define CONTINUATION(x) g_cells[x].cdr
#define FUNCTION(x) g_functions[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 MACRO(x) g_cells[x].cdr
#define VALUE(x) g_cells[x].cdr #define VALUE(x) g_cells[x].cdr
#define VECTOR(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 LENGTH(x) g_cells[x].length
#define NAME(x) g_cells[x].name #define NAME(x) g_cells[x].name
#define STRING(x) g_cells[x].string #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 CLOSURE(x) g_cells[x].closure
#define MACRO(x) g_cells[x].macro #define MACRO(x) g_cells[x].macro
#define REF(x) g_cells[x].ref #define REF(x) g_cells[x].ref
#define VALUE(x) g_cells[x].value #define VALUE(x) g_cells[x].value
#define VECTOR(x) g_cells[x].vector #define VECTOR(x) g_cells[x].vector
#define FUNCTION(x) g_functions[g_cells[x].function] #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 #define NLENGTH(x) g_news[x].length
@ -689,7 +698,11 @@ set_cdr_x (SCM x, SCM e)
SCM SCM
set_env_x (SCM x, SCM e, SCM a) 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)); if (TYPE (p) != TPAIR) error (cell_symbol_not_a_pair, cons (p, x));
return set_cdr_x (p, e); 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))); 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 SCM
lookup_macro_ (SCM x, SCM a) ///((internal)) lookup_macro_ (SCM x, SCM a) ///((internal))
{ {
if (TYPE (x) != TSYMBOL) return cell_f; if (TYPE (x) != TSYMBOL) return cell_f;
SCM m = assq_ref_env (x, a); SCM m = assq (x, a);
if (TYPE (m) == TMACRO) return MACRO (m); if (m != cell_f) return MACRO (CDR (m));
return cell_f; return cell_f;
} }
@ -750,10 +769,104 @@ gc_pop_frame () ///((internal))
return frame; 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 SCM
eval_apply () eval_apply ()
{ {
int expanding_p = 0;
eval_apply: eval_apply:
gc_check (); gc_check ();
switch (r3) switch (r3)
@ -764,12 +877,8 @@ eval_apply ()
case cell_vm_apply: goto apply; case cell_vm_apply: goto apply;
case cell_vm_apply2: goto apply2; case cell_vm_apply2: goto apply2;
case cell_vm_eval: goto eval; case cell_vm_eval: goto eval;
#if MES_FIXED_PRIMITIVES case cell_vm_eval_pmatch_car: goto eval_pmatch_car;
case cell_vm_eval_car: goto eval_car; case cell_vm_eval_pmatch_cdr: goto eval_pmatch_cdr;
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_define: goto eval_define; case cell_vm_eval_define: goto eval_define;
case cell_vm_eval_set_x: goto eval_set_x; case cell_vm_eval_set_x: goto eval_set_x;
case cell_vm_eval_macro_expand_eval: goto eval_macro_expand_eval; case cell_vm_eval_macro_expand_eval: goto eval_macro_expand_eval;
@ -818,7 +927,8 @@ eval_apply ()
gc_check (); gc_check ();
switch (TYPE (CAR (r1))) switch (TYPE (CAR (r1)))
{ {
case TFUNCTION: { case TFUNCTION:
{
check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1)); check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
goto vm_return; goto vm_return;
@ -826,12 +936,13 @@ eval_apply ()
case TCLOSURE: case TCLOSURE:
{ {
SCM cl = CLOSURE (CAR (r1)); SCM cl = CLOSURE (CAR (r1));
SCM formals = CADR (cl);
SCM body = CDDR (cl); SCM body = CDDR (cl);
SCM formals = CADR (cl);
SCM args = CDR (r1);
SCM aa = CDAR (cl); SCM aa = CDAR (cl);
aa = CDR (aa); aa = CDR (aa);
check_formals (CAR (r1), formals, CDR (r1)); 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); call_lambda (body, p, aa, r0);
goto begin; goto begin;
} }
@ -886,9 +997,10 @@ eval_apply ()
case cell_symbol_lambda: case cell_symbol_lambda:
{ {
SCM formals = CADR (CAR (r1)); SCM formals = CADR (CAR (r1));
SCM args = CDR (r1);
SCM body = CDDR (CAR (r1)); SCM body = CDDR (CAR (r1));
SCM p = pairlis (formals, CDR (r1), r0); SCM p = pairlis (formals, CDR (r1), r0);
check_formals (r1, formals, CDR (r1)); check_formals (r1, formals, args);
call_lambda (body, p, p, r0); call_lambda (body, p, p, r0);
goto begin; goto begin;
} }
@ -910,59 +1022,50 @@ eval_apply ()
{ {
switch (CAR (r1)) switch (CAR (r1))
{ {
#if MES_FIXED_PRIMITIVES case cell_symbol_pmatch_car:
case cell_symbol_car:
{ {
push_cc (CADR (r1), r1, r0, cell_vm_eval_car); goto eval; push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
eval_car: goto eval;
x = r1; gc_pop_frame (); r1 = CAR (x); goto eval_apply; eval_pmatch_car:
}
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; x = r1;
gc_pop_frame (); gc_pop_frame ();
r1 = cons (CAR (x), CADR (x)); r1 = CAR (x);
goto eval_apply; 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; goto eval;
eval_null_p: eval_pmatch_cdr:
x = r1; gc_pop_frame (); r1 = null_p (x); goto eval_apply; 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: 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_begin: goto begin;
case cell_symbol_lambda: 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; 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: case cell_symbol_set_x:
{ {
push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x); push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
goto eval; goto eval;
eval_set_x: eval_set_x:
x = r2; r1 = set_env_x (CADR (r2), r1, r0);
r1 = set_env_x (CADR (x), r1, r0);
goto vm_return; goto vm_return;
} }
case cell_vm_macro_expand: case cell_vm_macro_expand:
@ -971,10 +1074,8 @@ eval_apply ()
goto eval; goto eval;
eval_macro_expand_eval: eval_macro_expand_eval:
push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand); push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
expanding_p++;
goto macro_expand; goto macro_expand;
eval_macro_expand_expand: eval_macro_expand_expand:
expanding_p--;
goto vm_return; goto vm_return;
} }
default: default:
@ -983,6 +1084,34 @@ eval_apply ()
&& (CAR (r1) == cell_symbol_define && (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; r2 = r1;
if (TYPE (CADR (r1)) != TPAIR) if (TYPE (CADR (r1)) != TPAIR)
{ {
@ -992,30 +1121,46 @@ eval_apply ()
else else
{ {
SCM p = pairlis (CADR (r1), CADR (r1), r0); SCM p = pairlis (CADR (r1), CADR (r1), r0);
SCM args = CDR (CADR (r1)); SCM formals = CDR (CADR (r1));
SCM body = CDDR (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); push_cc (r1, r2, p, cell_vm_eval_define);
goto eval; goto eval;
} }
eval_define:; eval_define:;
SCM name = CADR (r2); SCM name = CADR (r2);
if (TYPE (CADR (r2)) == TPAIR) name = CAR (name); if (TYPE (CADR (r2)) == TPAIR)
if (CAR (r2) == cell_symbol_define_macro) name = CAR (name);
if (macro_p)
{
SCM entry = assq (name, g_macros);
r1 = MAKE_MACRO (name, r1); 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 entry = cons (name, r1);
SCM aa = cons (entry, cell_nil); SCM aa = cons (entry, cell_nil);
set_cdr_x (aa, cdr (r0)); set_cdr_x (aa, cdr (r0));
set_cdr_x (r0, aa); set_cdr_x (r0, aa);
SCM cl = assq (cell_closure, r0); SCM cl = assq (cell_closure, r0);
set_cdr_x (cl, aa); set_cdr_x (cl, aa);
//r1 = entry; }
r1 = cell_unspecified; r1 = cell_unspecified;
goto vm_return; 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: 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: eval2:
r1 = cons (CAR (r2), r1); r1 = cons (CAR (r2), r1);
goto apply; goto apply;
@ -1024,9 +1169,20 @@ eval_apply ()
} }
case TSYMBOL: 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)); r1 = assert_defined (r1, assq_ref_env (r1, r0));
goto vm_return; goto vm_return;
} }
case TVARIABLE:
{
r1 = CDR (VARIABLE (r1));
goto vm_return;
}
default: goto vm_return; default: goto vm_return;
} }
@ -1038,13 +1194,24 @@ eval_apply ()
if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote) if (TYPE (r1) != TPAIR || CAR (r1) == cell_symbol_quote)
goto vm_return; 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 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)); r1 = cons (macro, CDR (r1));
push_cc (r1, cell_nil, r0, cell_vm_macro_expand); push_cc (r1, cell_nil, r0, cell_vm_macro_expand);
goto apply; goto apply;
} }
if (CAR (r1) == cell_symbol_define if (CAR (r1) == cell_symbol_define
|| CAR (r1) == cell_symbol_define_macro) || CAR (r1) == cell_symbol_define_macro)
{ {
@ -1063,16 +1230,6 @@ eval_apply ()
goto vm_return; 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) if (CAR (r1) == cell_symbol_set_x)
{ {
push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_set_x); push_cc (CDDR (r1), r1, r0, cell_vm_macro_expand_set_x);
@ -1086,6 +1243,7 @@ eval_apply ()
if (TYPE (r1) == TPAIR if (TYPE (r1) == TPAIR
&& TYPE (CAR (r1)) == TSYMBOL && TYPE (CAR (r1)) == TSYMBOL
&& CAR (r1) != cell_symbol_begin && 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) && ((expanders = assq_ref_env (cell_symbol_sc_expander_alist, r0)) != cell_undefined)
&& ((macro = assq (CAR (r1), expanders)) != cell_f)) && ((macro = assq (CAR (r1), expanders)) != cell_f))
{ {
@ -1192,10 +1350,8 @@ eval_apply ()
} }
push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_macro); push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_macro);
expanding_p++;
goto macro_expand; goto macro_expand;
begin_expand_macro: begin_expand_macro:
expanding_p--;
if (r1 != CAR (r2)) if (r1 != CAR (r2))
{ {
CAR (r2) = r1; CAR (r2) = r1;
@ -1203,7 +1359,8 @@ eval_apply ()
continue; continue;
} }
r1 = r2; 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); push_cc (CAR (r1), r1, r0, cell_vm_begin_expand_eval);
goto eval; goto eval;
begin_expand_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_mes_prefix, MAKE_STRING (cstring_to_list (PREFIX)), a);
a = acons (cell_symbol_dot, cell_dot, a); a = acons (cell_symbol_dot, cell_dot, a);
a = acons (cell_symbol_begin, cell_begin, 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_call_with_values, cell_symbol_call_with_values, a);
a = acons (cell_symbol_current_module, cell_symbol_current_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_call_with_current_continuation, cell_call_with_current_continuation, a);

6
tests/pmatch.test
View file

@ -28,7 +28,11 @@ exit $?
(cond-expand (cond-expand
(guile (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
(mes-use-module (mes test)) (mes-use-module (mes test))
(mes-use-module (mes pmatch)))) (mes-use-module (mes pmatch))))