diff --git a/build-aux/mes-snarf.scm b/build-aux/mes-snarf.scm index 1bc4ffc6..d01d337c 100755 --- a/build-aux/mes-snarf.scm +++ b/build-aux/mes-snarf.scm @@ -146,8 +146,8 @@ exec ${GUILE-guile} --no-auto-compile -L $(dirname $0) -C $(dirname $0) -e '(mes (format #f "g_cells[cell_~a].string = MAKE_STRING (scm_~a.string);\n" (function.name f) (function.name f)) (format #f "g_cells[cell_~a].car = MAKE_STRING (scm_~a.car);\n" (function.name f) (function.name f))) (if %gcc? - (format #f "a = acons (make_symbol (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f)) - (format #f "a = acons (make_symbol (scm_~a.car), ~a, a);\n\n" (function.name f) (function-cell-name f))))) + (format #f "a = acons (list_to_symbol (scm_~a.string), ~a, a);\n\n" (function.name f) (function-cell-name f)) + (format #f "a = acons (list_to_symbol (scm_~a.car), ~a, a);\n\n" (function.name f) (function-cell-name f))))) (define (disjoin . predicates) (lambda (. arguments) diff --git a/build-aux/snarf.sh b/build-aux/snarf.sh index 5b264691..98b6e3e3 100755 --- a/build-aux/snarf.sh +++ b/build-aux/snarf.sh @@ -31,6 +31,7 @@ trace "SNARF$snarf gc.c" ${srcdest}build-aux/mes-snarf.scm $1 src/gc.c trace "SNARF$snarf lib.c" ${srcdest}build-aux/mes-snarf.scm $1 src/lib.c trace "SNARF$snarf math.c" ${srcdest}build-aux/mes-snarf.scm $1 src/math.c trace "SNARF$snarf mes.c" ${srcdest}build-aux/mes-snarf.scm $1 src/mes.c +trace "SNARF$snarf module.c" ${srcdest}build-aux/mes-snarf.scm $1 src/module.c trace "SNARF$snarf posix.c" ${srcdest}build-aux/mes-snarf.scm $1 src/posix.c trace "SNARF$snarf reader.c" ${srcdest}build-aux/mes-snarf.scm $1 src/reader.c trace "SNARF$snarf struct.c" ${srcdest}build-aux/mes-snarf.scm $1 src/struct.c diff --git a/mes/module/mes/type-0.mes b/mes/module/mes/type-0.mes index a7b1059c..4db75f9c 100644 --- a/mes/module/mes/type-0.mes +++ b/mes/module/mes/type-0.mes @@ -123,7 +123,7 @@ (define (string->symbol s) (if (not (pair? (core:car s))) '() - (core:lookup-symbol (core:car s)))) + (list->symbol (core:car s)))) (define (symbol->keyword s) (core:make-cell (symbol->list s) 0)) diff --git a/scaffold/boot/51-module.scm b/scaffold/boot/51-module.scm index 17fe40f2..2457d75f 100644 --- a/scaffold/boot/51-module.scm +++ b/scaffold/boot/51-module.scm @@ -81,7 +81,7 @@ (list 'load (list string-append %moduledir file))) (define (string->symbol s) - (core:lookup-symbol (core:car s))) + (list->symbol (core:car s))) (define (symbol->list s) (core:car s)) diff --git a/scaffold/boot/52-define-module.scm b/scaffold/boot/52-define-module.scm index 65b44268..a7150162 100644 --- a/scaffold/boot/52-define-module.scm +++ b/scaffold/boot/52-define-module.scm @@ -69,7 +69,7 @@ ;;;;;;;;;;;;;;;;;; (define (string->symbol s) - (core:lookup-symbol (core:car s))) + (list->symbol (core:car s))) (define-macro (load file) (list 'primitive-load file)) diff --git a/scaffold/boot/60-let-syntax-expanded.scm b/scaffold/boot/60-let-syntax-expanded.scm index 301f71c3..4c66e11e 100644 --- a/scaffold/boot/60-let-syntax-expanded.scm +++ b/scaffold/boot/60-let-syntax-expanded.scm @@ -153,16 +153,16 @@ (define (string->symbol s) (if (not (pair? (core:car s))) '() - (core:lookup-symbol (core:car s)))) + (list->symbol (core:car s)))) (define 10) (define (string? x) (eq? (core:type x) )) - + (define 14) (define (vector? x) (eq? (core:type x) )) - + ;; (define (body x) ;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module))))))) ;; (define (closure x) @@ -362,14 +362,14 @@ (and (segment-template? pattern) (or (null? (cddr pattern)) (syntax-error0 "segment matching not implemented" pattern)))) - + (define (segment-template? pattern) (and (pair? pattern) (pair? (cdr pattern)) (memq (cadr pattern) indicators-for-zero-or-more))) - + (define indicators-for-zero-or-more (list (string->symbol "...") '---)) - + (lambda (exp r c) (define %input (r '%input)) ;Gensym these, if you like. @@ -406,7 +406,7 @@ 0 (meta-variables pattern 0 '()))))) (syntax-error2 "ill-formed syntax rule" rule))) - + ;; Generate code to test whether input expression matches pattern (define (process-match input pattern) @@ -427,7 +427,7 @@ `((eq? ,input ',pattern))) (else `((equal? ,input ',pattern))))) - + (define (process-segment-match input pattern) ;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n") ;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n") @@ -439,7 +439,7 @@ (and (pair? l) ,@conjuncts (loop (cdr l))))))))) - + ;; Generate code to take apart the input expression ;; This is pretty bad, but it seems to work (can't say why). @@ -560,5 +560,3 @@ (if (not condition) (begin exp ...)))))) (xwhen #f 42))) - - diff --git a/scaffold/boot/60-let-syntax.scm b/scaffold/boot/60-let-syntax.scm index d5602258..b6619b68 100644 --- a/scaffold/boot/60-let-syntax.scm +++ b/scaffold/boot/60-let-syntax.scm @@ -65,14 +65,14 @@ (define (string->symbol s) (if (not (pair? (core:car s))) '() - (core:lookup-symbol (core:car s)))) + (list->symbol (core:car s)))) (define (string? x) (eq? (core:type x) )) - + (define (vector? x) (eq? (core:type x) )) - + ;; (define (body x) ;; (core:cdr (core:cdr (core:cdr (cdr (assq 'x (current-module))))))) ;; (define (closure x) @@ -272,14 +272,14 @@ (and (segment-template? pattern) (or (null? (cddr pattern)) (syntax-error "segment matching not implemented" pattern)))) - + (define (segment-template? pattern) (and (pair? pattern) (pair? (cdr pattern)) (memq (cadr pattern) indicators-for-zero-or-more))) - + (define indicators-for-zero-or-more (list (string->symbol "...") '---)) - + (lambda (exp r c) (define %input (r '%input)) ;Gensym these, if you like. @@ -316,7 +316,7 @@ 0 (meta-variables pattern 0 '()))))) (syntax-error "ill-formed syntax rule" rule))) - + ;; Generate code to test whether input expression matches pattern (define (process-match input pattern) @@ -337,7 +337,7 @@ `((eq? ,input ',pattern))) (else `((equal? ,input ',pattern))))) - + (define (process-segment-match input pattern) ;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n") ;;(core:display-error " pattern:") (core:write-error pattern) (core:display-error "\n") @@ -349,7 +349,7 @@ (and (pair? l) ,@conjuncts (loop (cdr l))))))))) - + ;; Generate code to take apart the input expression ;; This is pretty bad, but it seems to work (can't say why). @@ -470,4 +470,3 @@ (if (not condition) (begin exp ...)))))) (xwhen #f 42))) - diff --git a/src/mes.c b/src/mes.c index b1c405a1..21975556 100644 --- a/src/mes.c +++ b/src/mes.c @@ -279,6 +279,7 @@ int g_function = 0; #include "lib.mes.h" #include "math.mes.h" #include "mes.mes.h" +#include "module.mes.h" #include "posix.mes.h" #include "reader.mes.h" #include "struct.mes.h" @@ -288,6 +289,7 @@ int g_function = 0; #include "lib.h" #include "math.h" #include "mes.h" +#include "module.h" #include "posix.h" #include "reader.h" #include "struct.h" @@ -1611,6 +1613,7 @@ mes_g_stack (SCM a) ///((internal)) // Environment setup +#include "module.c" #include "posix.c" #include "math.c" #include "lib.c" @@ -2207,6 +2210,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a); #include "mes.mes.i" // Do not sort: Order of these includes define builtins +#include "module.mes.i" #include "posix.mes.i" #include "math.mes.i" #include "lib.mes.i" @@ -2219,6 +2223,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a); #include "lib.mes.environment.i" #include "math.mes.environment.i" #include "mes.mes.environment.i" +#include "module.mes.environment.i" #include "posix.mes.environment.i" #include "reader.mes.environment.i" #include "struct.mes.environment.i" @@ -2227,6 +2232,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a); #include "mes.i" // Do not sort: Order of these includes define builtins +#include "module.i" #include "posix.i" #include "math.i" #include "lib.i" @@ -2239,6 +2245,7 @@ a = acons (lookup_symbol_ (scm_getenv_.string), cell_getenv_, a); #include "lib.environment.i" #include "math.environment.i" #include "mes.environment.i" +#include "module.environment.i" #include "posix.environment.i" #include "reader.environment.i" #include "struct.environment.i" diff --git a/src/module.c b/src/module.c new file mode 100644 index 00000000..e7f244be --- /dev/null +++ b/src/module.c @@ -0,0 +1,40 @@ +/* -*-comment-start: "//";comment-end:""-*- + * GNU Mes --- Maxwell Equations of Software + * Copyright © 2018 Jan (janneke) Nieuwenhuizen + * + * This file is part of GNU Mes. + * + * GNU Mes is free software; you can redistribute it and/or modify it + * under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 3 of the License, or (at + * your option) any later version. + * + * GNU Mes is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with GNU Mes. If not, see . + */ + +SCM +make_initial_module (SCM a) +{ + SCM fields = cell_nil; + fields = cons (cstring_to_symbol ("globals"), fields); + fields = cons (cstring_to_symbol ("locals"), fields); + fields = cons (cstring_to_symbol ("name"), fields); + fields = cons (cstring_to_symbol (""), fields); + SCM module_type = make_struct (cstring_to_symbol ("record-type"), fields, cell_unspecified); + SCM module_type_name = cstring_to_symbol (""); + a = acons (module_type_name, module_type, a); + SCM values = cell_nil; + SCM name = cons (cstring_to_symbol ("boot"), cell_nil); + SCM globals = cell_nil; + values = cons (a, values); + values = cons (globals, values); + values = cons (name, values); + SCM module = make_struct (module_type_name, values, cell_unspecified); + return module; +}