diff --git a/GNUmakefile b/GNUmakefile index db4f96bb..331b4c35 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -33,16 +33,39 @@ mes.h: mes.c GNUmakefile check: all ./mes.test ./mes.test ./mes - cat scm.mes test.mes | ./mes + cat scm.mes lib/srfi/srfi-0.scm test.mes | ./mes run: all cat scm.mes test.mes | ./mes -syntax: all - cat scm.mes syntax.mes | ./mes +psyntax: all + cat scm.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes -guile-syntax: - guile -s syntax.mes +syntax: all + cat scm.mes syntax.mes syntax-test.mes | ./mes + +syntax.test: syntax.mes syntax-test.mes + cat $^ > $@ + +guile-syntax: syntax.test + guile -s $^ macro: all cat scm.mes macro.mes | ./mes + +peg: all + cat scm.mes syntax.mes peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes | ./mes + +peg.test: peg/pmatch.scm peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes + cat $^ | sed 's,\(;; Packages the results of a parser\),(when (guile?) (set! compile-peg-pattern (@@ (ice-9 peg codegen) compile-peg-pattern)))\n\1,' > $@ + +guile-peg: peg.test +# guile -s peg-test.mes +# @echo "=======================================" + guile -s $^ + +clean: + rm -f mes environment.i mes.h peg.test syntax.test + +record: all + cat scm.mes syntax.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm record.mes |./mes diff --git a/TODO b/TODO index 40f9f43c..62c14156 100644 --- a/TODO +++ b/TODO @@ -19,6 +19,19 @@ See bugs/ **** syntax-case ** parse C using PEG http://piumarta.com/software/peg/ +** C grammar in lex/yacc +https://github.com/rabishah/Mini-C-Compiler-using-Flex-And-Yacc +https://www.lysator.liu.se/c/ANSI-C-grammar-y.html +http://www2.cs.uidaho.edu/~jeffery/courses/nmsu/370/cgram.y +https://github.com/ProgramLeague/C-Compilerp +*** parsing in scheme +ftp://ftp.cs.indiana.edu/pub/scheme-repository/code/lang/cgram-ll1 +** Tiny C +https://en.wikipedia.org/wiki/Tiny_C_Compiler +** Sub C +http://www.t3x.org/subc/index.html +** +https://groups.google.com/forum/#!topic/comp.lang.lisp/VPuX0VsjTTE ** implement core primitives: DONE begin define diff --git a/lib/record.scm b/lib/record.scm index 75263f3d..92a047fe 100644 --- a/lib/record.scm +++ b/lib/record.scm @@ -1,96 +1,203 @@ -; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*- ; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING. - -; This is file record.scm. - ;;;; Records -; This is completely vanilla Scheme code. Should work anywhere. +; Every record in the image is assumed to be made either by MAKE-RECORD-TYPE +; or by a procedure returned by record-constructor. A record-type is a +; record that describes a type of record. At the end of the file we create +; a record type that describes record types. -(define (make-record-type type-id field-names) +; We number the record types for debugging purposes. - (define unique (list type-id)) +(define *record-type-uid* -1) - (define size (+ (length field-names) 1)) +; This is the record type that describes record types. It is set a the end +; of the file. Its first slot points to itself. - (define (constructor . names-option) - (let* ((names (if (null? names-option) - field-names - (car names-option))) - (number-of-inits (length names)) - (indexes (map field-index names))) - (lambda field-values - (if (= (length field-values) number-of-inits) - (let ((record (make-vector size 'uninitialized))) - (vector-set! record 0 unique) - (for-each (lambda (index value) - (vector-set! record index value)) - indexes - field-values) - record) - (error "wrong number of arguments to record constructor" - field-values type-id names))))) +(define *record-type* #f) - (define (predicate obj) - (and (vector? obj) - (= (vector-length obj) size) - (eq? (vector-ref obj 0) unique))) +; Make a record type from a name, used for printing and debugging, and +; a list of field names. +; +; The VM references both the record type and the resumer, so their offsets +; should not be changed. - (define (accessor name) - (let ((i (field-index name))) - (lambda (record) - (if (predicate record) ;Faster: (eq? (vector-ref record 0) unique) - (vector-ref record i) - (error "invalid argument to record accessor" - record type-id name))))) +(define (make-record-type name field-names) + (set! *record-type-uid* (+ *record-type-uid* 1)) + (let ((r (make-record 7 (unspecific)))) + (record-set! r 0 *record-type*) + (record-set! r 1 default-record-resumer) + (record-set! r 2 *record-type-uid*) + (record-set! r 3 name) + (record-set! r 4 field-names) + (record-set! r 5 (length field-names)) + (record-set! r 6 (make-default-record-discloser name)) + r)) - (define (modifier name) - (let ((i (field-index name))) - (lambda (record new-value) - (if (predicate record) ;Faster: (eq? (vector-ref record 0) unique) - (vector-set! record i new-value) - (error "invalid argument to record modifier" - record type-id name))))) +(define (record-type? obj) + (and (record? obj) + (eq? (record-type obj) *record-type*))) - (define (field-index name) - (let loop ((l field-names) (i 1)) - (if (null? l) - (error "bad field name" name) - (if (eq? name (car l)) - i - (loop (cdr l) (+ i 1)))))) +; The various fields in a record type. - (define the-descriptor - (lambda (request) - (case request - ((constructor) constructor) - ((predicate) predicate) - ((accessor) accessor) - ((modifier) modifier) - ((name) type-id) - ((field-names) field-names)))) +(define (record-type-resumer rt) (record-ref rt 1)) +(define (set-record-type-resumer! rt r) (record-set! rt 1 r)) +(define (record-type-uid rt) (record-ref rt 2)) +(define (record-type-name rt) (record-ref rt 3)) +(define (record-type-field-names rt) (record-ref rt 4)) +(define (record-type-number-of-fields rt) (record-ref rt 5)) +(define (record-type-discloser rt) (record-ref rt 6)) +(define (set-record-type-discloser! rt d) (record-set! rt 6 d)) - the-descriptor) +; This is a hack; it is read by the script that makes c/scheme48.h. -(define (record-constructor r-t . names-option) - (apply (r-t 'constructor) names-option)) +(define record-type-fields + '(resumer uid name field-names number-of-fields discloser)) -(define (record-predicate r-t) - (r-t 'predicate)) +;---------------- +; Given a record type and the name of a field, return the field's index. -(define (record-accessor r-t field-name) - ((r-t 'accessor) field-name)) +(define (record-field-index rt name) + (let loop ((names (record-type-field-names rt)) + (i 1)) + (cond ((null? names) + (error "unknown field" + (record-type-name rt) + name)) + ((eq? name (car names)) + i) + (else + (loop (cdr names) (+ i 1)))))) -(define (record-modifier r-t field-name) - ((r-t 'modifier) field-name)) +; Return procedure for contstruction records of type RT. NAMES is a list of +; field names which the constructor will take as arguments. Other fields are +; uninitialized. -(define (record-type-name r-t) (r-t 'name)) -(define (record-type-field-names r-t) (r-t 'field-names)) +(define (record-constructor rt names) + (let ((indexes (map (lambda (name) + (record-field-index rt name)) + names)) + (size (+ 1 (record-type-number-of-fields rt)))) + (lambda args + (let ((r (make-record size (unspecific)))) + (record-set! r 0 rt) + (let loop ((is indexes) (as args)) + (if (null? as) + (if (null? is) + r + (error "too few arguments to record constructor" + rt names args)) + (if (null? is) + (error "too many arguments to record constructor" + rt names args) + (begin (record-set! r (car is) (car as)) + (loop (cdr is) (cdr as)))))))))) -(define (record-type? r-t) - (and (procedure? r-t) - (error "record-type? not implemented" r-t))) +; Making accessors, modifiers, and predicates for record types. + +(define (record-accessor rt name) + (let ((index (record-field-index rt name)) + (error-cruft `(record-accessor ,rt ',name))) + (lambda (r) + (if (eq? (record-type r) rt) + (record-ref r index) + (call-error "invalid record access" error-cruft r))))) + +(define (record-modifier rt name) + (let ((index (record-field-index rt name)) + (error-cruft `(record-modifier ,rt ',name))) + (lambda (r x) + (if (eq? (record-type r) rt) + (record-set! r index x) + (call-error "invalid record modification" error-cruft r x))))) + +(define (record-predicate rt) + (lambda (x) + (and (record? x) + (eq? (record-type x) rt)))) + +;---------------- +; A discloser is a procedure that takes a record of a particular type and +; returns a list whose head is a string or symbol and whose tail is other +; stuff. +; +; Set the discloser for record type RT. + +(define (define-record-discloser rt proc) + (if (and (record-type? rt) + (procedure? proc)) + (set-record-type-discloser! rt proc) + (call-error "invalid argument" define-record-discloser rt proc))) + +; By default we just return the name of the record type. + +(define (make-default-record-discloser record-type-name) + (lambda (r) + (list record-type-name))) + +; DISCLOSE-RECORD calls the record's discloser procedure to obtain a list. + +(define (disclose-record r) + (if (record? r) + (let ((rt (record-type r))) + (if (record-type? rt) + ((record-type-discloser rt) r) + #f)) + #f)) + +;---------------- +; A resumer is a procedure that the VM calls on all records of a given +; type on startup. +; +; A resumer may be: +; #t -> do nothing on startup. +; #f -> records of this type do not survive a dump/resume; in images they +; are replaced by their first slot (so we make sure they have one) +; a one-argument procedure -> pass the record to this procedure +; +; Resumers are primarily intended for use by external code which keeps +; fields in records which do not survive a dump under their own power. +; For example, a record may contain a reference to a OS-dependent value. +; +; Resumers are called by the VM on startup. + +(define (define-record-resumer rt resumer) + (if (and (record-type? rt) + (or (eq? #t resumer) + (and (eq? #f resumer) + (< 0 (record-type-number-of-fields rt))) + (procedure? resumer))) + (set-record-type-resumer! rt resumer) + (call-error "invalid argument" define-record-resumer rt resumer))) + +; By default we leave records alone. + +(define default-record-resumer + #t) + +(define (initialize-records! resumer-records) + (if (vector? resumer-records) + (do ((i 0 (+ i 1))) + ((= i (vector-length resumer-records))) + (resume-record (vector-ref resumer-records i))))) + +(define (resume-record record) + ((record-type-resumer (record-type record)) + record)) + +;---------------- +; Initializing *RECORD-TYPE* and making a type. + +(set! *record-type* + (make-record-type 'record-type record-type-fields)) + +(record-set! *record-type* 0 *record-type*) + +(define :record-type *record-type*) + +(define-record-discloser :record-type + (lambda (rt) + (list 'record-type + (record-type-uid rt) + (record-type-name rt)))) -(define (define-record-discloser r-t proc) - "ignoring define-record-discloser form") diff --git a/lib/srfi/srfi-9.scm b/lib/srfi/srfi-9.scm index 6b971789..3adc5dc5 100644 --- a/lib/srfi/srfi-9.scm +++ b/lib/srfi/srfi-9.scm @@ -1,160 +1,44 @@ -; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING. +;; Copyright (c) 1993 by Richard Kelsey and Jonathan Rees. See file COPYING. +;; There's no implicit name concatenation, so it can be defined +;; entirely using syntax-rules. Example: +;; (define-record-type foo type/foo +;; (make-foo x y) +;; foo? - predicate name is optional +;; (x foo-x) +;; (y foo-y) +;; (z foo-z set-foo-z!)) -; This knows about the implementation of records and creates the various -; accessors, mutators, etc. directly instead of calling the procedures -; from the record structure. This is done to allow the optional auto-inlining -; optimizer to inline the accessors, mutators, etc. - -; LOOPHOLE is used to get a little compile-time type checking (in addition to -; the usual complete run-time checking). +;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING. (define-syntax define-record-type (syntax-rules () - ((define-record-type ?id ?type - (?constructor ?arg ...) - (?field . ?field-stuff) + ((define-record-type id type + (constructor arg ...) + (field . field-stuff) ...) - (begin (define ?type (make-record-type '?id '(?field ...))) - (define-constructor ?constructor ?type - ((?arg :value) ...) - (?field ...)) - (define-accessors ?type () (?field . ?field-stuff) ...))) - ((define-record-type ?id ?type - (?constructor ?arg ...) - ?pred - ?more ...) - (begin (define-record-type ?id ?type - (?constructor ?arg ...) - ?more ...) - (define ?pred - (lambda (x) - (and (record? x) - (eq? ?type (record-ref x 0))))))))) - -(define-syntax define-synchronized-record-type - (syntax-rules () - ((define-synchronized-record-type ?id ?type - (?constructor ?arg ...) - ?pred - (?field . ?field-stuff) - ...) - (define-synchronized-record-type ?id ?type - (?constructor ?arg ...) - (?field ...) - ?pred - (?field . ?field-stuff) - ...)) - ((define-synchronized-record-type ?id ?type - (?constructor ?arg ...) - (?sync-field ...) - ?pred - (?field . ?field-stuff) - ...) - (begin (define ?type (make-record-type '?id '(?field ...))) - (define-constructor ?constructor ?type - ((?arg :value) ...) - (?field ...)) - (define ?pred - (lambda (x) - (and (record? x) - (eq? ?type (record-ref x 0))))) - (define-accessors ?type (?sync-field ...) - (?field . ?field-stuff) ...))))) - -; (define-constructor (( )*) (*)) -; -; Checks to see that there is an corresponding to every . - -(define-syntax define-constructor - (lambda (e r c) - (let ((%record (r 'record)) - (%begin (r 'begin)) - (%lambda (r 'lambda)) - (%loophole (r 'loophole)) - (%proc (r 'proc)) - (%unspecific (r 'unspecific)) - (name (cadr e)) - (type (caddr e)) - (args (map r (map car (cadddr e)))) - (arg-types (map cadr (cadddr e))) - (fields (map r (caddr (cddr e))))) - (define (mem? name list) - (cond ((null? list) #f) - ((c name (car list)) #t) - (else - (mem? name (cdr list))))) - (define (every? pred list) - (cond ((null? list) #t) - ((pred (car list)) - (every? pred (cdr list))) - (else #f))) - (if (every? (lambda (arg) - (mem? arg fields)) - args) - `(define ,name - (,%loophole (,%proc ,arg-types ,type) - (,%lambda ,args - (,%record ,type . ,(map (lambda (field) - (if (mem? field args) - field - (list %unspecific))) - fields))))) - e))) - (record begin lambda loophole proc unspecific)) + (begin (define type (make-record-type 'id '(field ...))) + (define constructor (record-constructor type '(arg ...))) + (define-accessors type (field . field-stuff) ...))) + ((define-record-type id type + (constructor arg ...) + pred + more ...) + (begin (define-record-type id type + (constructor arg ...) + more ...) + (define pred (record-predicate type)))))) +;; Straightforward version (define-syntax define-accessors - (lambda (e r c) - (let ((%define-accessor (r 'define-accessor)) - (%begin (r 'begin)) - (type (cadr e)) - (sync-fields (caddr e)) - (field-specs (cdddr e))) - (define (mem? name list) - (cond ((null? list) #f) - ((c name (car list)) #t) - (else - (mem? name (cdr list))))) - (do ((i 1 (+ i 1)) - (field-specs field-specs (cdr field-specs)) - (ds '() - (cons `(,%define-accessor - ,(mem? (caar field-specs) - sync-fields) - ,type ,i ,@(cdar field-specs)) - ds))) - ((null? field-specs) - `(,%begin ,@ds))))) - (define-accessor begin)) + (syntax-rules () + ((define-accessors type field-spec ...) + (begin (define-accessor type . field-spec) ...)))) (define-syntax define-accessor (syntax-rules () - ((define-accessor ?sync? ?type ?index ?accessor) - (define ?accessor - (loophole (proc (?type) :value) - (lambda (r) - ((ref-proc ?sync?) (loophole :record r) ?type ?index))))) - ((define-accessor ?sync? ?type ?index ?accessor ?modifier) - (begin (define-accessor ?sync? ?type ?index ?accessor) - (define ?modifier - (loophole (proc (?type :value) :unspecific) - (lambda (r new) - ((set-proc ?sync?) - (loophole :record r) ?type ?index new)))))) - ((define-accessor ?sync? ?type ?index) - (begin)))) - -(define-syntax ref-proc - (syntax-rules () - ((ref-proc #t) - provisional-checked-record-ref) - ((ref-proc #f) - checked-record-ref))) - -(define-syntax set-proc - (syntax-rules () - ((set-proc #t) - provisional-checked-record-set!) - ((set-proc #f) - checked-record-set!))) - + ((define-accessor type field accessor) + (define accessor (record-accessor type 'field))) + ((define-accessor type field accessor modifier) + (begin (define accessor (record-accessor type 'field)) + (define modifier (record-modifier type 'field)))))) diff --git a/mes.c b/mes.c index d4f1a165..f1b1db76 100644 --- a/mes.c +++ b/mes.c @@ -342,6 +342,17 @@ eval (scm *e, scm *a) scm *entry = assq (name, a); scm *x = cdar (defines); set_cdr_x (entry, cdr (define (x, a))); + if (eq_p (car (x), &symbol_define_macro) == &scm_t) + // HACK: macros are global + // should we go back to (*macro* . ...) entry? + // scm *last = last_pair (a); + // printf ("\n LAST="); + // display (last); + // puts (""); + set_cdr_x (last_pair (a), cons (cons (name, cdr (define (x, a))), &scm_nil)); + // printf ("a="); + // display (a); + // puts (""); defines = cdr (defines); } scm *fubar = cons (&scm_dot, &scm_dot); @@ -361,6 +372,8 @@ eval (scm *e, scm *a) return eval_quasiquote (cadr (e), add_unquoters (a)); if (car (e) == &symbol_cond) return evcon (cdr (e), a); + if (eq_p (car (e), &symbol_define) == &scm_t) + return define (e, a); if (eq_p (car (e), &symbol_define_macro) == &scm_t) return define (e, a); if ((macro = lookup_macro (car (e), a)) != &scm_f) @@ -606,6 +619,16 @@ length (scm *x) return make_number (n); } +scm * +last_pair (scm *x) +{ + //if (x != &scm_nil && cdr (x) != &scm_nil) + //return last_pair (cdr (x)); + while (x != &scm_nil && cdr (x) != &scm_nil) + x = cdr (x); + return x; +} + scm * builtin_list (scm *x/*...*/) { @@ -833,9 +856,9 @@ display_helper (scm *x, bool cont, char *sep, bool quote) if (!cont) printf (")"); } else if (x->type == VECTOR) { - printf ("#("); - for (int i = 0; i < x->length; i++) - display_helper (x->vector[i], true, i ? " " : "", false); + printf ("#[%d](", x->length); + // for (int i = 0; i < x->length; i++) + // display_helper (x->vector[i], true, i ? " " : "", false); printf (")"); } else if (atom_p (x) == &scm_t) printf ("%s", x->name); @@ -1112,6 +1135,8 @@ mes_environment () a = cons (cons (&scm_nil, &scm_nil), a); a = cons (cons (&scm_t, &scm_t), a); a = cons (cons (&scm_unspecified, &scm_unspecified), a); + a = cons (cons (&symbol_begin, &symbol_begin), a); + a = cons (cons (&symbol_quote, &scm_quote), a); #include "environment.i" diff --git a/scm.mes b/scm.mes index bf07eadf..82487961 100755 --- a/scm.mes +++ b/scm.mes @@ -94,6 +94,11 @@ (#t (eq? a b)))) (define (vector . rest) (list->vector rest)) +(define (make-vector n . x) + (let ((fill (if (pair? x) (cdr x) *unspecified*))) + (list->vector (let loop ((n n)) + (if (= 0 n) '() + (cons fill (loop (- n 1)))))))) (define (apply f args) (eval (cons f args) (current-module))) @@ -204,3 +209,6 @@ (let loop ((lst lst)) (if (or (null? lst) (null? (cdr lst))) lst (loop (cdr lst))))) + +(define else #t) +(define (unspecific) (if #f #f)) diff --git a/syntax.mes b/syntax.mes index 6232fce7..eca054f2 100644 --- a/syntax.mes +++ b/syntax.mes @@ -4,7 +4,7 @@ (display "syntax-error:") (display message) (display ":") - ;;(display thing) + (display thing) (newline)) ;;; Adapted from scheme48-1.1/scheme/alt/syntax.scm @@ -246,5 +246,3 @@ `(define-syntax ,(car id-pattern) (syntax-rules () ((,(car id-pattern) . ,(cdr id-pattern)) ,@template)))) - -(define else #t)