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

mes: Boot from MES_BOOT, boot-0.scm.

Browse source 
* src/mes.c (load_env): Softcode loading of boot-0.scm from
  environment variabl MES_BOOT.
* module/mes/boot-00.scm: New file.
* module/mes/boot-01.scm: New file.
* module/mes/boot-0.scm: Rename from read-0.mes.
* module/mes/module.mes: New file.
This commit is contained in:
Jan Nieuwenhuizen 2018-02-03 21:43:52 +01:00
parent e54c70bc00
commit 459e4f6a57
13 changed files with 375 additions and 520 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
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 (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"

18
module/mes/base-0.mes
View file

@ -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) "<stdin>")
@ -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))

1
module/mes/base.mes
View file

@ -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

116
module/mes/boot-0.scm Normal file
View file

@ -0,0 +1,116 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
;;; 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 <cell:character> 0)
(define <cell:pair> 7)
(define <cell:string> 10)
(define (pair? x) (eq? (core:type x) <cell:pair>))
(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 <cell:string> lst 0))
(define (integer->char x)
(core:make-cell <cell:character> 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)

35
module/mes/boot-00.scm Normal file
View file

@ -0,0 +1,35 @@
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
;; 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)

85
module/mes/boot-01.scm Normal file
View file

@ -0,0 +1,85 @@
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
;; 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 <cell:character> 0)
(define <cell:pair> 7)
(define <cell:string> 10)
(define (pair? x) (eq? (core:type x) <cell:pair>))
(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 <cell:string> lst 0))
(define (integer->char x)
(core:make-cell <cell:character> 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)

9
module/mes/let.mes
View file

@ -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))

11
module/mes/module.mes
View file

@ -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 '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 '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")))))

7
module/mes/pmatch.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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")

379
module/mes/read-0.mes
View file

@ -1,379 +0,0 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
;;; 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 <cell:pair> 7)
(define (not x) (if x #f #t))
(define (pair? x) (eq? (core:type x) <cell:pair>))
(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 <cell:macro>) 5) (list)) (current-module))
(env:define (cons (cons (quote <cell:pair>) 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) <cell:pair>)))
(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 <cell:macro> (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 <cell:character> 0)
(define <cell:keyword> 4)
(define <cell:string> 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 <cell:string> lst 0))
(define (integer->char x)
(core:make-cell <cell:character> 0 x))
(define (symbol->keyword s)
(core:make-cell <cell:keyword> (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)))

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

@ -131,6 +131,12 @@
(if (not (pair? (core:car s))) '()
(core:lookup-symbol (core:car s))))
(define (symbol->keyword s)
(core:make-cell <cell:keyword> (symbol->list s) 0))
(define (list->symbol lst)
(core:lookup-symbol lst))
(define (symbol->list s)
(core:car s))

140
src/mes.c
View file

@ -24,12 +24,13 @@
#include <string.h>
#include <mlibc.h>
#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,33 +940,20 @@ 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)
default:
{
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
|| CAR (r1) == cell_symbol_define_macro))
{
r2 = CADR (r1);
if (TYPE (r2) != TPAIR)
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
{
r2 = CAR (r2);
SCM p = pairlis (CADR (r1), CADR (r1), r0);
SCM args = CDR (CADR (r1));
SCM body = CDDR (r1);
@ -987,21 +961,21 @@ eval_apply ()
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);
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 = entry;
r1 = cell_unspecified;
goto vm_return;
}
#endif // MES_C_DEFINE
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;
@ -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);
}

14
src/reader.c
View file

@ -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;