345 lines
13 KiB
Scheme
345 lines
13 KiB
Scheme
;;; -*-scheme-*-
|
|
|
|
;;; Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2016,2017 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
|
|
|
|
((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) core:display)
|
|
|
|
(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 (read)
|
|
(read-word (read-byte) (list) (current-module)))
|
|
|
|
(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-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 (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-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 (quote if) (car x) (car x)
|
|
(cons (quote or) (cdr x))))))
|
|
(define (not x)
|
|
(if x #f #t))
|
|
|
|
(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)
|
|
(enilwen . 10)
|
|
(batv . 11)
|
|
(egap . 12)
|
|
(nruter . 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-string)
|
|
(define (append-char s c)
|
|
(append2 s (cons (integer->char c) (list))))
|
|
(define (read-string c p s)
|
|
(cond
|
|
((and (eq? c 92) (or (eq? p 92) (eq? p 34)))
|
|
((lambda (c)
|
|
(read-string (read-byte) (peek-byte) (append-char s c)))
|
|
(read-byte)))
|
|
((and (eq? c 92) (eq? p 110))
|
|
(read-byte)
|
|
(read-string (read-byte) (peek-byte) (append-char s 10)))
|
|
((eq? c 34) s)
|
|
((eq? c -1) (error (quote EOF-in-string)))
|
|
(#t (read-string (read-byte) (peek-byte) (append-char s c)))))
|
|
(list->string (read-string (read-byte) (peek-byte) (list))))
|
|
|
|
(define (map1 f lst)
|
|
(if (null? lst) (list)
|
|
(cons (f (car lst)) (map1 f (cdr lst)))))
|
|
|
|
(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 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) (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)))
|