diff --git a/make.scm b/make.scm index c43f0c4f..b2d8a800 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_C_READER=1" - "MES_C_DEFINE=1" - "MES_FIXED_PRIMITIVES=1" + #:defines `("MES_FIXED_PRIMITIVES=1" "MES_FULL=1" "POSIX=1" ,(string-append "VERSION=\"" %version "\"") @@ -446,9 +444,7 @@ 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_C_READER=1" - "MES_C_DEFINE=1" - "MES_FIXED_PRIMITIVES=1" + #:defines `( "MES_FIXED_PRIMITIVES=1" "MES_FULL=1" ,(string-append "VERSION=\"" %version "\"") ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") "/" %moduledir "/") "\"") @@ -456,9 +452,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ #:includes '("src"))) (add-target (bin.mescc "src/mes.c" #:dependencies mes-snarf-targets - #:defines `("MES_C_READER=1" - "MES_C_DEFINE=1" - "MES_FIXED_PRIMITIVES=1" + #:defines `("MES_FIXED_PRIMITIVES=1" "MES_FULL=1" ,(string-append "VERSION=\"" %version "\"") ,(string-append "MODULEDIR=\"" (string-append %prefix (if (string-null? %prefix) "" "/") %moduledir "/") "\"") @@ -537,7 +531,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ (for-each (lambda (f) ((install-dir #:dir (string-append %module-dir)) f)) - '("module/language/c99/compiler.mes" + '(;;"module/language/c99/compiler.mes" "module/language/c99/compiler.scm" "module/language/c99/info.mes" "module/language/c99/info.scm" @@ -550,6 +544,9 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ "module/mes/as.scm" ;;"module/mes/base-0.mes" "module/mes/base.mes" + "module/mes/boot-0.scm" + "module/mes/boot-00.scm" + "module/mes/boot-01.scm" "module/mes/bytevectors.mes" "module/mes/bytevectors.scm" "module/mes/catch.mes" @@ -587,7 +584,6 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$ "module/mes/quasiquote.mes" "module/mes/quasisyntax.mes" "module/mes/quasisyntax.scm" - "module/mes/read-0.mes" "module/mes/repl.mes" "module/mes/scm.mes" "module/mes/syntax.mes" diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes index 727522e6..3222a84e 100644 --- a/module/mes/base-0.mes +++ b/module/mes/base-0.mes @@ -34,9 +34,6 @@ (define (primitive-eval e) (core:eval e (current-module))) (define eval core:eval) -(if (defined? 'current-input-port) #t - (define (current-input-port) 0)) - (define (current-output-port) 1) (define (current-error-port) 2) (define (port-filename port) "") @@ -63,8 +60,8 @@ (if (pair? (cdr (car clauses))) (if (eq? (car (cdr (car clauses))) '=>) (append2 (cdr (cdr (car clauses))) '(test)) - (list (cons 'lambda (cons '() (cons 'test (cdar clauses)))))) - (list (cons 'lambda (cons '() (cons 'test (cdar clauses)))))) + (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses))))))) + (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses))))))) (if (pair? (cdr clauses)) (cons 'cond (cdr clauses))))))) (car (car clauses))))) @@ -118,8 +115,9 @@ (string->list "/module") ; `module/' gets replaced upon install (string->list "/"))))) +;;(primitive-load "module/mes/type-0.mes") (include (list->string - (append (string->list %moduledir) (string->list "/mes/type-0.mes")))) + (append2 (string->list %moduledir) (string->list "/mes/type-0.mes")))) (define (symbol->string s) (apply string (symbol->list s))) @@ -151,15 +149,19 @@ (include-from-path "mes/module.mes") +(mes-use-module (mes base-0)) + (mes-use-module (mes base)) -(mes-use-module (srfi srfi-0)) +;; (mes-use-module (srfi srfi-0)) (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) (mes-use-module (mes scm)) +(mes-use-module (srfi srfi-1)) ;; FIXME: module read order (mes-use-module (srfi srfi-13)) + +(mes-use-module (mes fluids)) ;; FIXME: module read order (mes-use-module (mes catch)) (mes-use-module (mes posix)) - diff --git a/module/mes/base.mes b/module/mes/base.mes index 54959aa7..f3df2169 100644 --- a/module/mes/base.mes +++ b/module/mes/base.mes @@ -72,6 +72,7 @@ (define call/cc call-with-current-continuation) (define (command-line) %argv) +(define (read) (read-env (current-module))) (define-macro (and . x) (if (null? x) #t diff --git a/module/mes/boot-0.scm b/module/mes/boot-0.scm new file mode 100644 index 00000000..2f3d7188 --- /dev/null +++ b/module/mes/boot-0.scm @@ -0,0 +1,116 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; 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. +;;; +;;; 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 Mes. If not, see . + +;;; Commentary: + +;;; read-0.mes - bootstrap reader. This file is read by a minimal +;;; core reader. It only supports s-exps and line-comments; quotes, +;;; character literals, string literals cannot be used here. + +;;; Code: + +;; boot-00.scm +(define mes %version) + +(define (defined? x) + (assq x (current-module))) + +(define (cond-expand-expander clauses) + (if (defined? (car (car clauses))) + (cdr (car clauses)) + (cond-expand-expander (cdr clauses)))) + +(define-macro (cond-expand . clauses) + (cons 'begin (cond-expand-expander clauses))) +;; end boot-00.scm + +;; boot-01.scm +(define 0) +(define 7) +(define 10) + +(define (pair? x) (eq? (core:type x) )) +(define (not x) (if x #f #t)) + +(define (display x . rest) + (if (null? rest) (core:display x) + (core:display-port x (car rest)))) + +(define (write x . rest) + (if (null? rest) (core:write x) + (core:write-port x (car rest)))) + +(define (list->string lst) + (core:make-cell lst 0)) + +(define (integer->char x) + (core:make-cell 0 x)) + +(define (newline . rest) + (core:display (list->string (list (integer->char 10))))) + +(define (string->list s) + (core:car s)) + +(define (cadr x) (car (cdr x))) + +(define (map1 f lst) + (if (null? lst) (list) + (cons (f (car lst)) (map1 f (cdr lst))))) + +(define map map1) + +(define (cons* . rest) + (if (null? (cdr rest)) (car rest) + (cons (car rest) (core:apply cons* (cdr rest) (current-module))))) + +(define (apply f h . t) + (if (null? t) (core:apply f h (current-module)) + (apply f (apply cons* (cons h t))))) + +(define (append . rest) + (if (null? rest) '() + (if (null? (cdr rest)) (car rest) + (append2 (car rest) (apply append (cdr rest)))))) +;; end boot-01.scm + +(define-macro (and . x) + (if (null? x) #t + (if (null? (cdr x)) (car x) + (list (quote if) (car x) (cons (quote and) (cdr x)) + #f)))) + +(define-macro (or . x) + (if (null? x) #f + (if (null? (cdr x)) (car x) + (list (list (quote lambda) (list (quote r)) + (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) + +(define-macro (mes-use-module module) + #t) + +;;((lambda (*program*) *program*) (primitive-load 0)) +(primitive-load 0) + diff --git a/module/mes/boot-00.scm b/module/mes/boot-00.scm new file mode 100644 index 00000000..4c0b3378 --- /dev/null +++ b/module/mes/boot-00.scm @@ -0,0 +1,35 @@ +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; 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. +;;; +;;; 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 Mes. If not, see . + +;; boot-00.scm +(define mes %version) + +(define (defined? x) + (assq x (current-module))) + +(define (cond-expand-expander clauses) + (if (defined? (car (car clauses))) + (cdr (car clauses)) + (cond-expand-expander (cdr clauses)))) + +(define-macro (cond-expand . clauses) + (cons 'begin (cond-expand-expander clauses))) +;; end boot-00.scm + +;;((lambda (*program*) *program*) (primitive-load 0)) +(primitive-load 0) diff --git a/module/mes/boot-01.scm b/module/mes/boot-01.scm new file mode 100644 index 00000000..1026f19a --- /dev/null +++ b/module/mes/boot-01.scm @@ -0,0 +1,85 @@ +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2018 Jan Nieuwenhuizen +;;; +;;; This file is part of Mes. +;;; +;;; 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. +;;; +;;; 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 Mes. If not, see . + +;; boot-00.scm +(define mes %version) + +(define (defined? x) + (assq x (current-module))) + +(define (cond-expand-expander clauses) + (if (defined? (car (car clauses))) + (cdr (car clauses)) + (cond-expand-expander (cdr clauses)))) + +(define-macro (cond-expand . clauses) + (cons 'begin (cond-expand-expander clauses))) +;; end boot-00.scm + +;; boot-01.scm +(define 0) +(define 7) +(define 10) + +(define (pair? x) (eq? (core:type x) )) +(define (not x) (if x #f #t)) + +(define (display x . rest) + (if (null? rest) (core:display x) + (core:display-port x (car rest)))) + +(define (write x . rest) + (if (null? rest) (core:write x) + (core:write-port x (car rest)))) + +(define (list->string lst) + (core:make-cell lst 0)) + +(define (integer->char x) + (core:make-cell 0 x)) + +(define (newline . rest) + (core:display (list->string (list (integer->char 10))))) + +(define (string->list s) + (core:car s)) + +(define (cadr x) (car (cdr x))) + +(define (map1 f lst) + (if (null? lst) (list) + (cons (f (car lst)) (map1 f (cdr lst))))) + +(define map map1) + +(define (cons* . rest) + (if (null? (cdr rest)) (car rest) + (cons (car rest) (core:apply cons* (cdr rest) (current-module))))) + +(define (apply f h . t) + (if (null? t) (core:apply f h (current-module)) + (apply f (apply cons* (cons h t))))) + +(define (append . rest) + (if (null? rest) '() + (if (null? (cdr rest)) (car rest) + (append2 (car rest) (apply append (cdr rest)))))) +;; end boot-01.scm + +;;((lambda (*program*) *program*) (primitive-load 0)) +(primitive-load 0) diff --git a/module/mes/let.mes b/module/mes/let.mes index a9b29fc1..7b984ba9 100644 --- a/module/mes/let.mes +++ b/module/mes/let.mes @@ -33,13 +33,13 @@ (map1 cadr bindings))) (define-macro (xsimple-let bindings rest) - `(,`(lambda ,(map car bindings) ,@rest) - ,@(map cadr bindings))) + `(,`(lambda ,(map1 car bindings) ,@rest) + ,@(map1 cadr bindings))) (define-macro (xnamed-let name bindings rest) `(simple-let ((,name *unspecified*)) - (set! ,name (lambda ,(map car bindings) ,@rest)) - (,name ,@(map cadr bindings)))) + (set! ,name (lambda ,(map1 car bindings) ,@rest)) + (,name ,@(map1 cadr bindings)))) (define-macro (let bindings-or-name . rest) (if (symbol? bindings-or-name) @@ -72,4 +72,3 @@ `(let ,(unspecified-bindings bindings '()) ,@(letrec-setters bindings '()) ,@body)) - diff --git a/module/mes/module.mes b/module/mes/module.mes index 54cd7cd2..b57bd32a 100644 --- a/module/mes/module.mes +++ b/module/mes/module.mes @@ -36,10 +36,13 @@ x)) (define-macro (mes-use-module module) - (list - 'begin - (list 'if (list 'not (list 'memq (list string->symbol (module->file module)) '*modules*)) - (list - 'begin - (list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*)) - (list 'load (list string-append '%moduledir (module->file module))))))) + (list 'if (list not (list memq (list string->symbol (module->file module)) '*modules*)) + (list + 'begin + (list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*)) + (list 'load (list string-append '%moduledir (module->file module)))) + (list 'if (getenv "MES_DEBUG") + (list 'begin + (list core:display-error ";;; already loaded: ") + (list core:display-error (list 'quote module)) + (list core:display-error "\n"))))) diff --git a/module/mes/pmatch.mes b/module/mes/pmatch.mes index 28d7143f..1242a899 100644 --- a/module/mes/pmatch.mes +++ b/module/mes/pmatch.mes @@ -1,7 +1,7 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017 Jan Nieuwenhuizen +;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen ;;; ;;; This file is part of Mes. ;;; @@ -22,7 +22,10 @@ ;;; Code: -(mes-use-module (mes guile)) +(define-macro (define-module module . rest) #t) +(define-macro (use-modules . rest) #t) + +;;(mes-use-module (mes guile)) (mes-use-module (mes quasiquote)) (mes-use-module (mes syntax)) (include-from-path "mes/pmatch.scm") diff --git a/module/mes/read-0.mes b/module/mes/read-0.mes deleted file mode 100644 index 5f25dc9d..00000000 --- a/module/mes/read-0.mes +++ /dev/null @@ -1,379 +0,0 @@ -;;; -*-scheme-*- - -;;; Mes --- Maxwell Equations of Software -;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen -;;; -;;; This file is part of Mes. -;;; -;;; 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. -;;; -;;; 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 Mes. If not, see . - -;;; Commentary: - -;;; read-0.mes - bootstrap reader. This file is read by a minimal -;;; core reader. It only supports s-exps and line-comments; quotes, -;;; character literals, string literals cannot be used here. - -;;; Code: - -(begin - (if %c-define - (begin - (define 7) - (define (not x) (if x #f #t)) - (define (pair? x) (eq? (core:type x) )) - (define (atom? x) (not (pair? x)))) - (begin - ((lambda (a+ a) - (set-cdr! a+ (cdr a)) - (set-cdr! a a+) - (set-cdr! (assq (quote *closure*) a) a+) - (car a+)) - (cons (cons (quote env:define) #f) (list)) - (current-module)) - - (set! env:define - (lambda (a+ a) - (set-cdr! a+ (cdr a)) - (set-cdr! a a+) - (set-cdr! (assq (quote *closure*) a) a+) - (car a+))) - - (env:define (cons (cons (quote ) 5) (list)) (current-module)) - (env:define (cons (cons (quote ) 7) (list)) (current-module)) - (env:define (cons (cons (quote sexp:define) #f) (list)) (current-module)) - (env:define (cons (cons (quote env:macro) #f) (list)) (current-module)) - (env:define (cons (cons (quote cons*) #f) (list)) (current-module)) - (env:define (cons (cons (quote not) - (lambda (x) (if x #f #t))) - (list)) (current-module)) - (env:define (cons (cons (quote pair?) - (lambda (x) (eq? (core:type x) ))) - (list)) (current-module)) - (env:define (cons (cons (quote atom?) - (lambda (x) (not (pair? x)))) - (list)) (current-module)) - - (set! sexp:define - (lambda (e a) - (if (atom? (car (cdr e))) (cons (car (cdr e)) (core:eval (car (cdr (cdr e))) a)) - (cons (car (car (cdr e))) (core:eval (cons (quote lambda) (cons (cdr (car (cdr e))) (cdr (cdr e)))) a))))) - - (set! env:macro - (lambda (name+entry) - (cons - (cons (car name+entry) - (core:make-cell (core:car (car name+entry)) (cdr name+entry))) - (list)))) - - (set! cons* - (lambda (. rest) - (if (null? (cdr rest)) (car rest) - (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))) - - (env:define - (env:macro - (sexp:define - (quote - (define-macro (define ARGS . BODY) - (cons* (quote env:define) - (cons* (quote cons) - (cons* (quote sexp:define) - (list (quote quote) - (cons (quote DEFINE) (cons ARGS BODY))) - (quote ((current-module)))) - (quote ((list)))) - (quote ((current-module)))))) - (current-module))) (current-module)) - - (env:define - (env:macro - (sexp:define - (quote - (define-macro (define-macro ARGS . BODY) - (cons* (quote env:define) - (list (quote env:macro) - (cons* (quote sexp:define) - (list (quote quote) - (cons (quote DEFINE-MACRO) (cons ARGS BODY))) - (quote ((current-module))))) - (quote ((current-module)))))) - (current-module))) (current-module)))) - - (define 0) - (define 4) - (define 10) - - (define (newline . rest) (core:display (list->string (list (integer->char 10))))) - (define (display x . rest) (if (null? rest) (core:display x) - (core:display-port x (car rest)))) - (define (write x . rest) (if (null? rest) (core:write x) - (core:write-port x (car rest)))) - - (define (list->symbol lst) (core:lookup-symbol lst)) - - (define (symbol->list s) - (core:car s)) - - (define (list->string lst) - (core:make-cell lst 0)) - - (define (integer->char x) - (core:make-cell 0 x)) - - (define (symbol->keyword s) - (core:make-cell (symbol->list s) 0)) - - (define-macro (defined? x) - (list (quote assq) x (quote (cdr (cdr (current-module)))))) - - (define-macro (cond . clauses) - (list (quote if) (pair? clauses) - (list (quote if) (car (car clauses)) - (if (pair? (cdr (car clauses))) - (if (eq? (car (cdr (car clauses))) (quote =>)) - (append2 (cdr (cdr (car clauses))) (list (car (car clauses)))) - (list (cons (quote lambda) (cons (list) (car clauses))))) - (list (cons (quote lambda) (cons (list) (car clauses))))) - (if (pair? (cdr clauses)) - (cons (quote cond) (cdr clauses)))))) - - (define-macro (and . x) - (if (null? x) #t - (if (null? (cdr x)) (car x) - (list (quote if) (car x) (cons (quote and) (cdr x)) - #f)))) - - (define-macro (or . x) - (if (null? x) #f - (if (null? (cdr x)) (car x) - (list (list (quote lambda) (list (quote r)) - (list (quote if) (quote r) (quote r) - (cons (quote or) (cdr x)))) - (car x))))) - - (define (not x) - (if x #f #t)) - - (define (map1 f lst) - (if (null? lst) (list) - (cons (f (car lst)) (map1 f (cdr lst))))) - - (define (read) - (read-word (read-byte) (list) (current-module))) - - (define (read-input-file) - (core:read-input-file-env (read-env (current-module)) (current-module))) - - (if (not %c-reader) - (begin - (define (read-env a) - (read-word (read-byte) (list) a)) - - (define (read-input-file) - (define (helper x) - (if (null? x) x - (cons x (helper (read))))) - (helper (read))) - - (define (eat-whitespace c) - (cond - ((eq? c 32) (eat-whitespace (read-byte))) - ((eq? c 10) (eat-whitespace (read-byte))) - ((eq? c 9) (eat-whitespace (read-byte))) - ((eq? c 12) (eat-whitespace (read-byte))) - ((eq? c 13) (eat-whitespace (read-byte))) - ((eq? c 59) (begin (read-line-comment c) - (eat-whitespace (read-byte)))) - ((eq? c 35) (cond ((eq? (peek-byte) 33) - (read-byte) - (read-block-comment 33 (read-byte)) - (eat-whitespace (read-byte))) - ((eq? (peek-byte) 59) - (read-byte) - (read-word (read-byte) (list) (list)) - (eat-whitespace (read-byte))) - ((eq? (peek-byte) 124) - (read-byte) - (read-block-comment 124 (read-byte)) - (eat-whitespace (read-byte))) - (#t (unread-byte 35)))) - (#t (unread-byte c)))) - - (define (read-block-comment s c) - (if (eq? c s) (if (eq? (peek-byte) 35) (read-byte) - (read-block-comment s (read-byte))) - (read-block-comment s (read-byte)))) - - (define (read-line-comment c) - (if (eq? c 10) c - (read-line-comment (read-byte)))) - - (define (read-list a) - (eat-whitespace (read-byte)) - (if (eq? (peek-byte) 41) (begin (read-byte) (list)) - ((lambda (w) - (if (eq? w *dot*) (car (read-list a)) - (cons w (read-list a)))) - (read-word (read-byte) (list) a)))) - - (define (read-character) - (define (read-octal c p n) - (if (not (and (> p 47) (< p 56))) n - (read-octal (read-byte) (peek-byte) (+ (ash n 3) (- p 48))))) - - (define (read-name c p n) - (define (lookup-char n) - (cond ((assq n (quote ((*foe* . -1) - (lun . 0) - (mrala . 7) - (ecapskcab . 8) - (bat . 9) - (th . 9) - (enilwen . 10) - (batv . 11) - (egap . 12) - (nruter . 13) - (rc . 13) - (ecaps . 32)))) => cdr) - (#t (error (quote char-not-supported) n)))) - (if (not (or (eq? p 42) (and (> p 96) (< p 123)))) (integer->char (lookup-char (list->symbol (cons (integer->char c) n)))) - (read-name (read-byte) (peek-byte) (cons (integer->char c) n)))) - - ((lambda (c p) - (cond ((and (> c 47) (< c 56) (> p 47) (< p 56)) - (integer->char (read-octal c p (- c 48)))) - ((and (or (= c 42) (and (> c 96) (< c 123))) - (or (= p 42) (and (> p 96) (< p 123)))) (read-name c p (list))) - (#t (integer->char c)))) - (read-byte) (peek-byte))) - - (define (read-hex) - (define (calc c) - (cond ((and (> c 64) (< c 71)) (+ (- c 65) 10)) - ((and (> c 96) (< c 103)) (+ (- c 97) 10)) - ((and (> c 47) (< c 58)) (- c 48)) - (#t 0))) - (define (read-hex c p s n) - (if (not (or (and (> p 64) (< p 71)) - (and (> p 96) (< p 103)) - (and (> p 47) (< p 58)))) (* s (+ (ash n 4) (calc c))) - (read-hex (read-byte) (peek-byte) s (+ (ash n 4) (calc c))))) - ((lambda (c p) - (if (eq? c 45) (read-hex (read-byte) (peek-byte) -1 0) - (read-hex c p 1 0))) - (read-byte) (peek-byte))) - - (define (read-octal) - (define (read-octal c p s n) - (if (not (or (and (> p 47) (< p 56)))) (* s (+ (ash n 3) (- c 48))) - (read-octal (read-byte) (peek-byte) s (+ (ash n 3) (- c 48))))) - ((lambda (c p) - (if (eq? c 45) (read-octal (read-byte) (peek-byte) -1 0) - (read-octal c p 1 0))) - (read-byte) (peek-byte))) - - (define (reader:read-string) - (define (append-char s c) - (append2 s (cons (integer->char c) (list)))) - (define (reader:read-string c p s) - (cond - ((and (eq? c 92) (or (eq? p 92) (eq? p 34))) - ((lambda (c) - (reader:read-string (read-byte) (peek-byte) (append-char s c))) - (read-byte))) - ((and (eq? c 92) (eq? p 110)) - (read-byte) - (reader:read-string (read-byte) (peek-byte) (append-char s 10))) - ((and (eq? c 92) (eq? p 116)) - (read-byte) - (reader:read-string (read-byte) (peek-byte) (append-char s 9))) - ((eq? c 34) s) - ((eq? c -1) (error (quote EOF-in-string) (cons c s))) - (#t (reader:read-string (read-byte) (peek-byte) (append-char s c))))) - (list->string (reader:read-string (read-byte) (peek-byte) (list)))) - - (define (lookup w a) - (define (lookup-number c p s n) - (and (> c 47) (< c 58) - (if (null? p) (* s (+ (* n 10) (- c 48))) - (lookup-number (car p) (cdr p) s (+ (* n 10) (- c 48)))))) - ((lambda (c p) - (or (cond ((and (> c 47) (< c 58)) (lookup-number c p 1 0)) - ((and (eq? c 45) (pair? p)) (lookup-number (car p) (cdr p) -1 0)) - (#t #f)) - (core:lookup-symbol (map1 integer->char w)))) - (car w) (cdr w))) - - (define (read-hash c w a) - (cond - ((eq? c 33) (begin (read-block-comment 33 (read-byte)) - (read-word (read-byte) w a))) - ((eq? c 124) (begin (read-block-comment 124 (read-byte)) - (read-word (read-byte) w a))) - ((eq? c 40) (list->vector (read-list a))) - ((eq? c 92) (read-character)) - ((eq? c 111) (read-octal)) - ((eq? c 120) (read-hex)) - ((eq? c 44) (cond ((eq? (peek-byte) 64) - (read-byte) - (cons (quote unsyntax-splicing) - (cons (read-word (read-byte) w a) w))) - (#t (cons (quote unsyntax) - (cons (read-word (read-byte) w a) w))))) - ((eq? c 39) (cons (quote syntax) (cons (read-word (read-byte) w a) w))) - ((eq? c 58) (symbol->keyword (read-word (read-byte) w a))) - ((eq? c 59) (begin (read-word (read-byte) w a) - (read-word (read-byte) w a))) - ((eq? c 96) (cons (quote quasisyntax) - (cons (read-word (read-byte) w a) w))) - (#t (read-word c (append2 w (cons 35 w)) a)))) - - (define (read-word c w a) - (cond - ((or (and (> c 96) (< c 123)) - (eq? c 45) - (eq? c 63) - (and (> c 47) (< c 58))) - (read-word (read-byte) (append2 w (cons c (list))) a)) - ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a))) - ((eq? c 40) (if (null? w) (read-list a) - (begin (unread-byte c) (lookup w a)))) - ((eq? c 41) (if (null? w) (quote *FOOBAR*) - (begin (unread-byte c) (lookup w a)))) - ((eq? c 34) (if (null? w) (reader:read-string) - (begin (unread-byte c) (lookup w a)))) - ((eq? c 32) (if (null? w) (read-word (read-byte) (list) a) (lookup w a))) - ((eq? c 10) (if (null? w) (read-word (read-byte) (list) a) (lookup w a))) - ((eq? c 35) (read-hash (read-byte) w a)) - ((eq? c 39) (if (null? w) (cons (quote quote) - (cons (read-word (read-byte) w a) (list))) - (begin (unread-byte c) (lookup w a)))) - ((eq? c 44) (cond - ((eq? (peek-byte) 64) - (begin (read-byte) - (cons - (quote unquote-splicing) - (cons (read-word (read-byte) w a) (list))))) - (#t (cons (quote unquote) - (cons (read-word (read-byte) w a) (list)))))) - ((eq? c 96) (cons (quote quasiquote) (cons (read-word (read-byte) w a) (list)))) - ((eq? c 59) (read-line-comment c) (read-word 10 w a)) - ((eq? c 9) (read-word 32 w a)) - ((eq? c 12) (read-word 32 w a)) - ((eq? c -1) (list)) - (#t (read-word (read-byte) (append2 w (cons c (list))) a)))))) - - ((lambda (p) - (core:eval (cons (quote begin) p) (current-module))) - (read-input-file))) diff --git a/module/mes/type-0.mes b/module/mes/type-0.mes index c98f8113..be903c40 100644 --- a/module/mes/type-0.mes +++ b/module/mes/type-0.mes @@ -131,6 +131,12 @@ (if (not (pair? (core:car s))) '() (core:lookup-symbol (core:car s)))) +(define (symbol->keyword s) + (core:make-cell (symbol->list s) 0)) + +(define (list->symbol lst) + (core:lookup-symbol lst)) + (define (symbol->list s) (core:car s)) diff --git a/src/mes.c b/src/mes.c index 743e298f..8788bc5d 100644 --- a/src/mes.c +++ b/src/mes.c @@ -24,12 +24,13 @@ #include #include -#if MES_C_READER -int ARENA_SIZE = 10000000; +int ARENA_SIZE = 20000000; // 32B: 100 MiB, 64b: 200 MiB +#if __MESC__ +//int MAX_ARENA_SIZE = 89478485; // 32b: ~1GiB +int MAX_ARENA_SIZE = 80000000; // 32b: ~1GiB #else -int ARENA_SIZE = 100000; +int MAX_ARENA_SIZE = 200000000; // 32b: 2GiB, 64b: 4GiB #endif -int MAX_ARENA_SIZE = 20000000; int GC_SAFETY = 250; @@ -129,12 +130,9 @@ struct scm scm_symbol_lambda = {TSYMBOL, "lambda",0}; struct scm scm_symbol_begin = {TSYMBOL, "begin",0}; struct scm scm_symbol_if = {TSYMBOL, "if",0}; struct scm scm_symbol_quote = {TSYMBOL, "quote",0}; -#if 1 //MES_C_DEFINE // snarfing makes these always needed for linking struct scm scm_symbol_define = {TSYMBOL, "define",0}; struct scm scm_symbol_define_macro = {TSYMBOL, "define-macro",0}; -#endif -#if 1 //MES_C_READER // snarfing makes these always needed for linking struct scm scm_symbol_quasiquote = {TSYMBOL, "quasiquote", 0}; struct scm scm_symbol_unquote = {TSYMBOL, "unquote", 0}; struct scm scm_symbol_unquote_splicing = {TSYMBOL, "unquote-splicing", 0}; @@ -142,7 +140,6 @@ struct scm scm_symbol_syntax = {TSYMBOL, "syntax",0}; struct scm scm_symbol_quasisyntax = {TSYMBOL, "quasisyntax", 0}; struct scm scm_symbol_unsyntax = {TSYMBOL, "unsyntax", 0}; struct scm scm_symbol_unsyntax_splicing = {TSYMBOL, "unsyntax-splicing", 0}; -#endif // MES_C_READER struct scm scm_symbol_set_x = {TSYMBOL, "set!",0}; @@ -189,9 +186,7 @@ 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}; -#if 1 //MES_C_DEFINE // snarfing makes these always needed for linking struct scm scm_vm_eval_define = {TSPECIAL, "*vm-eval-define*",0}; -#endif struct scm scm_vm_eval_set_x = {TSPECIAL, "*vm-eval-set!*",0}; struct scm scm_vm_eval_macro = {TSPECIAL, "*vm-eval-macro*",0}; @@ -209,8 +204,6 @@ struct scm scm_vm_return = {TSPECIAL, "*vm-return*",0}; struct scm scm_symbol_gnuc = {TSYMBOL, "%gnuc",0}; struct scm scm_symbol_mesc = {TSYMBOL, "%mesc",0}; -struct scm scm_symbol_c_reader = {TSYMBOL, "%c-reader",0}; -struct scm scm_symbol_c_define = {TSYMBOL, "%c-define",0}; struct scm scm_test = {TSYMBOL, "test",0}; @@ -295,12 +288,8 @@ int g_function = 0; #define MAKE_NUMBER(n) make_cell_ (tmp_num_ (TNUMBER), 0, tmp_num2_ (n)) #define MAKE_REF(n) make_cell_ (tmp_num_ (TREF), n, 0) #define MAKE_STRING(x) make_cell_ (tmp_num_ (TSTRING), x, 0) -#if MES_C_READER #define MAKE_KEYWORD(x) make_cell_ (tmp_num_ (TKEYWORD), x, 0) -#endif -#if MES_C_DEFINE #define MAKE_MACRO(name, x) make_cell_ (tmp_num_ (TMACRO), STRING (name), x) -#endif #define CAAR(x) CAR (CAR (x)) #define CADR(x) CAR (CDR (x)) @@ -768,9 +757,7 @@ eval_apply () case cell_vm_eval_cons: goto eval_cons; case cell_vm_eval_null_p: goto eval_null_p; #endif -#if MES_C_DEFINE case cell_vm_eval_define: goto eval_define; -#endif case cell_vm_eval_set_x: goto eval_set_x; case cell_vm_eval_macro: goto eval_macro; case cell_vm_eval_check_func: goto eval_check_func; @@ -953,56 +940,43 @@ eval_apply () push_cc (CADR (r1), r1, r0, cell_vm_macro_expand); goto eval; } - default: { - push_cc (r1, r1, r0, cell_vm_eval_macro); - goto macro_expand; - eval_macro: - if (r1 != r2) - { - if (TYPE (r1) == TPAIR) - { - set_cdr_x (r2, CDR (r1)); - set_car_x (r2, CAR (r1)); - } - goto eval; - } -#if MES_C_DEFINE - if (TYPE (r1) == TPAIR - && (CAR (r1) == cell_symbol_define + default: + { + if (TYPE (r1) == TPAIR + && (CAR (r1) == cell_symbol_define || CAR (r1) == cell_symbol_define_macro)) - { - r2 = CADR (r1); - if (TYPE (r2) != TPAIR) - { - push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define); - goto eval; - } - else - { - r2 = CAR (r2); - SCM p = pairlis (CADR (r1), CADR (r1), r0); - SCM args = CDR (CADR (r1)); - SCM body = CDDR (r1); - r1 = cons (cell_symbol_lambda, cons (args, body)); - push_cc (r1, r2, p, cell_vm_eval_define); - goto eval; - } - eval_define: - if (CAAR (CAAR (g_stack)) == cell_symbol_define_macro - || CAR (CAAR (g_stack)) == cell_symbol_define_macro) - r1 = MAKE_MACRO (r2, r1); - SCM entry = cons (r2, 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; - goto vm_return; - } -#endif // MES_C_DEFINE - - push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func); goto eval; + { + r2 = r1; + if (TYPE (CADR (r1)) != TPAIR) + { + push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define); + goto eval; + } + else + { + SCM p = pairlis (CADR (r1), CADR (r1), r0); + SCM args = CDR (CADR (r1)); + SCM body = CDDR (r1); + r1 = cons (cell_symbol_lambda, cons (args, 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; + r1 = cell_unspecified; + goto vm_return; + } + 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; eval2: @@ -1052,10 +1026,28 @@ eval_apply () r1 = append2 (CDAR (r1), CDR (r1)); else if (CAAR (r1) == cell_symbol_primitive_load) { - push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file); - goto apply; - begin_read_input_file: - r1 = append2 (r1, CDR (r2)); + // push_cc (cons (cell_symbol_read_input_file, cell_nil), r1, r0, cell_vm_begin_read_input_file); + // goto apply; + + push_cc (CAR (CDAR (r1)), r1, r0, cell_vm_begin_read_input_file); + goto eval; // FIXME: expand too?! + begin_read_input_file:; + SCM input = r1; + if ((TYPE (r1) == TNUMBER && VALUE (r1) == 0)) + ; + else + input = set_current_input_port (open_input_file (r1)); + push_cc (input, r2, r0, cell_vm_return); + x = read_input_file_env (r0); + gc_pop_frame (); + r1 = x; + input = r1; +#if DEBUG + eputs (" ..2.r2="); write_error_ (r2); eputs ("\n"); + eputs (" => result r1="); write_error_ (r1); eputs ("\n"); +#endif + set_current_input_port (input); + r1 = append2 (r1, cons (cell_t, CDR (r2))); } } if (CDR (r1) == cell_nil) @@ -1244,18 +1236,6 @@ mes_symbols () ///((internal)) a = acons (cell_symbol_gnuc, cell_f, a); a = acons (cell_symbol_mesc, cell_t, a); #endif - -#if MES_C_READER - a = acons (cell_symbol_c_reader, cell_t, a); -#else - a = acons (cell_symbol_c_reader, cell_f, a); -#endif - -#if MES_C_DEFINE - a = acons (cell_symbol_c_define, cell_t, a); -#else - a = acons (cell_symbol_c_define, cell_f, a); -#endif a = acons (cell_closure, a, a); return a; @@ -1335,15 +1315,21 @@ load_env (SCM a) ///((internal)) { r0 = a; g_stdin = -1; + char boot[128]; + char buf[128]; + if (getenv ("MES_BOOT")) + strcpy (boot, getenv ("MES_BOOT")); + else + strcpy (boot, "boot-0.scm"); if (getenv ("MES_PREFIX")) { - char buf[128]; strcpy (buf, getenv ("MES_PREFIX")); strcpy (buf + strlen (buf), "/module"); - strcpy (buf + strlen (buf), "/mes/read-0.mes"); + strcpy (buf + strlen (buf), "/mes/"); + strcpy (buf + strlen (buf), boot); if (getenv ("MES_DEBUG")) { - eputs ("MES_PREFIX reading read-0:"); + eputs ("MES_PREFIX reading boot-0:"); eputs (buf); eputs ("\n"); } @@ -1351,28 +1337,44 @@ load_env (SCM a) ///((internal)) } if (g_stdin < 0) { - char *read0 = MODULEDIR "mes/read-0.mes"; + char const *prefix = MODULEDIR "mes/"; + strcpy (buf, prefix); + strcpy (buf + strlen (buf), boot); if (getenv ("MES_DEBUG")) { - eputs ("MODULEDIR reading read-0:"); - eputs (read0); + eputs ("MODULEDIR reading boot-0:"); + eputs (buf); eputs ("\n"); } - g_stdin = open (read0, O_RDONLY); + g_stdin = open (buf, O_RDONLY); + } + if (g_stdin < 0) + { + strcpy (buf, "module/mes/"); + strcpy (buf + strlen (buf), boot); + if (getenv ("MES_DEBUG")) + { + eputs (". reading boot-0:"); + eputs (buf); + eputs ("\n"); + } + g_stdin = open (buf, O_RDONLY); } if (g_stdin < 0) { if (getenv ("MES_DEBUG")) { - eputs (". reading read-0:"); - eputs ("module/mes/read-0.mes"); + eputs (". reading boot-0:"); + eputs (boot); eputs ("\n"); } - g_stdin = open ("module/mes/read-0.mes", O_RDONLY); + g_stdin = open (boot, O_RDONLY); } if (g_stdin < 0) { - eputs ("boot failed, read-0.mes not found\n"); + eputs ("mes: boot failed: no such file: "); + eputs (boot); + eputs ("\n"); exit (1); } diff --git a/src/reader.c b/src/reader.c index 92e7404e..8210cb30 100644 --- a/src/reader.c +++ b/src/reader.c @@ -43,10 +43,8 @@ reader_read_line_comment (int c) return reader_read_line_comment (getchar ()); } -#if MES_C_READER SCM reader_read_block_comment (int s, int c); SCM read_hash (int c, SCM w, SCM a); -#endif SCM reader_read_word_ (int c, SCM w, SCM a) @@ -65,7 +63,6 @@ reader_read_word_ (int c, SCM w, SCM a) if (c == ')') {ungetchar (c); return reader_lookup_ (w, a);} if (c == ';') {reader_read_line_comment (c); return reader_read_word_ ('\n', w, a);} -#if MES_C_READER if (c == '"' && w == cell_nil) return reader_read_string (); if (c == '"') {ungetchar (c); return reader_lookup_ (w, a);} if (c == ',' && peekchar () == '@') {getchar (); return cons (cell_symbol_unquote_splicing, @@ -80,7 +77,6 @@ reader_read_word_ (int c, SCM w, SCM a) if (c == '#' && peekchar () == 'f') return reader_read_word_ (getchar (), append2 (w, cons (MAKE_CHAR (c), cell_nil)), a); if (c == '#' && peekchar () == 't') return reader_read_word_ (getchar (), append2 (w, cons (MAKE_CHAR (c), cell_nil)), a); if (c == '#') return read_hash (getchar (), w, a); -#endif //MES_C_READER return reader_read_word_ (getchar (), append2 (w, cons (MAKE_CHAR (c), cell_nil)), a); } @@ -90,9 +86,7 @@ eat_whitespace (int c) { while (c == ' ' || c == '\t' || c == '\n' || c == '\f') c = getchar (); if (c == ';') return eat_whitespace (reader_read_line_comment (c)); -#if MES_C_READER if (c == '#' && (peekchar () == '!' || peekchar () == '|')) {c=getchar (); reader_read_block_comment (c, getchar ()); return eat_whitespace (getchar ());} -#endif return c; } @@ -136,7 +130,6 @@ reader_lookup_ (SCM s, SCM a) return lookup_symbol_ (s); } -#if MES_C_READER SCM reader_read_block_comment (int s, int c) { @@ -315,13 +308,6 @@ reader_read_string () } return MAKE_STRING (p); } -#else // !MES_C_READER -SCM reader_read_word (SCM c,SCM w,SCM a) {} -SCM reader_read_character () {} -SCM reader_read_octal () {} -SCM reader_read_hex () {} -SCM reader_read_string () {} -#endif // MES_C_READER int g_tiny = 0;