trying to get records up....WIP

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
+psyntax: all
-	cat scm.mes syntax.mes | ./mes
+	cat scm.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
 
-guile-syntax:
+syntax: all
-	guile -s syntax.mes
+	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

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

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)
+(define *record-type* #f)
-    (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 (predicate obj)
+; Make a record type from a name, used for printing and debugging, and
-    (and (vector? obj)
+; a list of field names.
-	 (= (vector-length obj) size)
+;
-	 (eq? (vector-ref obj 0) unique)))
+; The VM references both the record type and the resumer, so their offsets
+; should not be changed.
 
-  (define (accessor name)
+(define (make-record-type name field-names)
-    (let ((i (field-index name)))
+  (set! *record-type-uid* (+ *record-type-uid* 1))
-      (lambda (record)
+  (let ((r (make-record 7 (unspecific))))
-	(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
+    (record-set! r 0 *record-type*)
-	    (vector-ref record i)
+    (record-set! r 1 default-record-resumer)
-	    (error "invalid argument to record accessor"
+    (record-set! r 2 *record-type-uid*)
-		   record type-id name)))))
+    (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)
+(define (record-type? obj)
-    (let ((i (field-index name)))
+  (and (record? obj)
-      (lambda (record new-value)
+       (eq? (record-type obj) *record-type*)))
-	(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 (field-index name)
+; The various fields in a record type.
-    (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))))))
 
-  (define the-descriptor
+(define (record-type-resumer rt)          (record-ref rt 1))
-    (lambda (request)
+(define (set-record-type-resumer! rt r)   (record-set! rt 1 r))
-      (case request
+(define (record-type-uid rt)              (record-ref rt 2))
-	((constructor) constructor)
+(define (record-type-name rt)             (record-ref rt 3))
-	((predicate) predicate)
+(define (record-type-field-names rt)      (record-ref rt 4))
-	((accessor) accessor)
+(define (record-type-number-of-fields rt) (record-ref rt 5))
-	((modifier) modifier)
+(define (record-type-discloser rt)        (record-ref rt 6))
-	((name) type-id)
+(define (set-record-type-discloser! rt d) (record-set! rt 6 d))
-	((field-names) field-names))))
 
-  the-descriptor)
+; This is a hack; it is read by the script that makes c/scheme48.h.
 
-(define (record-constructor r-t . names-option)
+(define record-type-fields
-  (apply (r-t 'constructor) names-option))
+  '(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)
+(define (record-field-index rt name)
-  ((r-t 'accessor) field-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)
+; Return procedure for contstruction records of type RT.  NAMES is a list of
-  ((r-t 'modifier) field-name))
+; field names which the constructor will take as arguments.  Other fields are
+; uninitialized.
 
-(define (record-type-name r-t) (r-t 'name))
+(define (record-constructor rt names)
-(define (record-type-field-names r-t) (r-t 'field-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)
+; Making accessors, modifiers, and predicates for record types.
-  (and (procedure? r-t)
+
-       (error "record-type? not implemented" r-t)))
+(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")

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
+;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
-; 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).
 
 (define-syntax define-record-type
   (syntax-rules ()
-    ((define-record-type ?id ?type
+    ((define-record-type id type
-       (?constructor ?arg ...)
+       (constructor arg ...)
-       (?field . ?field-stuff)
+       (field . field-stuff)
        ...)
-     (begin (define ?type (make-record-type '?id '(?field ...)))
+     (begin (define type (make-record-type 'id '(field ...)))
-	    (define-constructor ?constructor ?type
+            (define constructor (record-constructor type '(arg ...)))
-	      ((?arg :value) ...)
+            (define-accessors type (field . field-stuff) ...)))
-	      (?field ...))
+    ((define-record-type id type
-	    (define-accessors ?type () (?field . ?field-stuff) ...)))
+       (constructor arg ...)
-    ((define-record-type ?id ?type
+       pred
-       (?constructor ?arg ...)
+       more ...)
-       ?pred
+     (begin (define-record-type id type
-       ?more ...)
+              (constructor arg ...)
-     (begin (define-record-type ?id ?type
+              more ...)
-	      (?constructor ?arg ...)
+            (define pred (record-predicate type))))))
-	      ?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 <id> <type> ((<arg> <arg-type>)*) (<field-name>*))
-;
-; Checks to see that there is an <arg> corresponding to every <field-name>.
-
-(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))
 
+;; Straightforward version
 (define-syntax define-accessors
-  (lambda (e r c)
+  (syntax-rules ()
-    (let ((%define-accessor (r 'define-accessor))
+    ((define-accessors type field-spec ...)
-	  (%begin (r 'begin))
+     (begin (define-accessor type . field-spec) ...))))
-	  (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))
 
 (define-syntax define-accessor
   (syntax-rules ()
-    ((define-accessor ?sync? ?type ?index ?accessor)
+    ((define-accessor type field accessor)
-     (define ?accessor
+     (define accessor (record-accessor type 'field)))
-       (loophole (proc (?type) :value)
+    ((define-accessor type field accessor modifier)
-		 (lambda (r)
+     (begin (define accessor (record-accessor type 'field))
-		   ((ref-proc ?sync?) (loophole :record r) ?type ?index)))))
+            (define modifier (record-modifier type 'field))))))
-    ((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!)))
-

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 ("#(");
+    printf ("#[%d](", x->length);
-    for (int i = 0; i < x->length; i++)
+    // for (int i = 0; i < x->length; i++)
-      display_helper (x->vector[i], true, i ? " " : "", false);
+    //   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"
   

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

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)