[[project @ 1996-12-17 06:44:10 by ghouston]
ghouston**19961217064413
 Ignore-this: a2af451028b0bb242b81daea70fa7db3
 * init.scm: load syntax.scm instead of slib's macro-by-example.
 load defrec.scm.
 
 * defrec.scm: copied from SCSH.
 
 * syntax.scm: copied from SCSH.
 Redefine define-syntax and define syntax-error.  By some miracle
 it seems to work.
 
 * receive.scm: copied from SCSH.
] addfile ./defrec.scm
addfile ./receive.scm
addfile ./syntax.scm
hunk ./ChangeLog 1
+Tue Dec 17 06:24:39 1996  Gary Houston  <ghouston@actrix.gen.nz>
+
+	* init.scm: load syntax.scm instead of slib's macro-by-example.
+	load defrec.scm.
+	
+	* defrec.scm: copied from SCSH.
+
+	* syntax.scm: copied from SCSH.
+	Redefine define-syntax and define syntax-error.  By some miracle
+	it seems to work.
+
+Mon Dec 16 05:53:43 1996  Gary Houston  <ghouston@actrix.gen.nz>
+
+	* receive.scm: copied from SCSH.
+
hunk ./defrec.scm 1
+;;; Copyright (c) 1993 by Olin Shivers.
+
+;;; Syntax for defining record types.
+;;; This implementation works with the Scheme48 system --
+;;; or any Scheme that uses Clinger's "explicit renaming"
+;;; macro system.
+;;;
+;;; (define-record name . field&method-specs)
+;;;
+;;; A field-spec is one of the following:
+;;;     field		; Initialised field
+;;;     (field [default])	; Defaulted field.
+;;; An initialised field has its initial value passed as an argument to
+;;; the the record maker procedure. A defaulted field takes its value from
+;;; the the DEFAULT expression. If a DEFAULT expression is not given, then
+;;; the defaulted field's initial value is undefined.
+;;; 
+;;; Example:
+;;; (define-record employee
+;;;     name
+;;;     id
+;;;     (salary 10000)
+;;;     (department)	; Initial value undefined.
+;;;     sex
+;;;     married?)
+;;; 
+;;; Defines the following:
+;;; - A maker procedure:
+;;;   (make-employee "John Smith" 742931 'male #f)
+;;;   MAKE-EMPLOYEE takes one argument for each initialised field.
+;;; 
+;;; - Accessor procedures:
+;;;   (employee:name emp)
+;;;   (employee:id emp)
+;;;   (employee:salary emp)
+;;;   (employee:department emp)
+;;;   (employee:sex emp)
+;;;   (employee:married? emp)
+;;; 
+;;; - Setter procedures:
+;;;   (set-employee:name emp "Janet Q. Random")
+;;;   (set-employee:id emp 8271)
+;;;   (set-employee:salary emp 20000)
+;;;   (set-employee:department emp "Vaporware")
+;;;   (set-employee:sex emp 'female)
+;;;   (set-employee:married? emp #t)
+;;; 
+;;; - A type predicate:
+;;;   (employee? x)
+;;; 
+;;; - The record type descriptor:
+;;;     type/employee
+
+;;; Method specs are of the form
+;;; ((method self var ...) body ...)
+;;; The only supported method is DISCLOSE, which is used by the S48
+;;; structure printer. E.g.,
+;;;   (define-record ship
+;;;     x
+;;;     y
+;;;     name
+;;;     ((disclose self) (list "ship" (ship:name self))))
+;;; will cause (make-ship 10 20 "Valdez") to print as
+;;;   #{ship "Valdez"}
+
+
+(define-syntax define-record
+  (lambda (form rename compare)
+    (receive (field-specs method-specs)
+	     ;; Partition the field and method specs by form.
+	     (let lp ((specs (reverse (cddr form)))
+		      (fspecs '())
+		      (mspecs '()))
+	       (if (pair? specs)
+		   (let ((spec (car specs))
+			 (specs (cdr specs)))
+		     (if (and (pair? spec) (pair? (car spec)))
+			 ;; We only support the DISCLOSE method in S48.
+			 (if (eq? (caar spec) 'disclose)
+			     (lp specs fspecs (cons spec mspecs))
+			     (error "Unsupported method in define-record." spec))
+			 (lp specs (cons spec fspecs) mspecs)))
+		   (values fspecs mspecs)))
+
+      (let* ((name (cadr form))
+	     (s->s symbol->string)
+	     (s-conc (lambda args (string->symbol (apply string-append args))))
+	     (spec-name (lambda (s) (if (pair? s) (car s) s)))
+	     (filter (lambda (pred lst)
+		       (let f ((lst lst))
+			 (if (pair? lst)
+			     (let ((tail (f (cdr lst))))
+			       (if (pred (car lst)) (cons (car lst) tail) tail))
+			     '()))))
+	     (gensym (let ((j 0))
+		       (lambda (s) (set! j (+ j 1))
+			       (s-conc s (number->string j)))))
+
+	     (field-name (lambda (field-name)
+			   (s-conc (s->s name) ":" (s->s field-name))))
+	     (set-name (lambda (field-name)
+			 (s-conc "set-" (s->s name) ":" (s->s field-name))))
+	     (pred-name (s-conc (s->s name) "?"))
+	     (maker-name (s-conc "make-" (s->s name)))
+	     (type-name (s-conc "type/" (s->s name)))
+
+	     (fields (map spec-name field-specs))
+	     (param-fields (filter symbol? field-specs)) ; Args to maker proc.
+	     (default-field-specs (filter (lambda (fs) (and (pair? fs)
+							    (pair? (cdr fs))))
+					  field-specs))
+	     (default-exps (map cadr default-field-specs))
+	     (param-vars (map (lambda (fs) (rename (gensym "field")))
+			      param-fields))
+
+	     (maker (rename 'maker))
+	     (%make-record-type   (rename 'make-record-type))
+	     (%record-constructor (rename 'record-constructor))
+	     (%record-predicate	  (rename 'record-predicate))
+	     (%record-accessor	  (rename 'record-accessor))
+	     (%record-modifier	  (rename 'record-modifier))
+	     (%def-rec-discloser  (rename 'define-record-discloser))
+	     (%unspecified	  (rename 'unspecified))
+	     (%define		  (rename 'define))
+	     (%let		  (rename 'let))
+	     (%lambda		  (rename 'lambda))
+	     (%begin		  (rename 'begin)))
+
+	`(,%begin
+	  (,%define ,type-name
+	    (,%make-record-type ,(s->s name) ',fields))
+
+	  ;; Maker proc (MAKE-EMPLOYEE name id-number sex married?)
+	  (,%define ,maker-name
+	    ,(if (null? default-field-specs)
+		 ;; Gratuitous optimisation:
+		 `(,%record-constructor ,type-name ',param-fields)
+	      
+		 ;; Full-blown form.
+		 `(,%let ((,maker (,%record-constructor
+				   ,type-name
+				   ',(append param-fields
+					     (map spec-name
+						  default-field-specs)))))
+			 (,%lambda ,param-vars
+		           (,maker ,@param-vars ,@default-exps)))))
+
+	  ;; Type predicate (EMPLOYEE? x)
+	  (,%define ,pred-name (,%record-predicate ,type-name))
+       
+	  ;; Accessors (EMPLOYEE:NAME emp), ...
+	  ,@(map (lambda (spec)
+		   `(,%define ,(field-name (spec-name spec))
+		      (,%record-accessor ,type-name ',(spec-name spec))))
+		 field-specs)
+
+	  ;; Setters (SET-EMPLOYEE:NAME emp name), ...
+	  ,@(map (lambda (spec)
+		   `(,%define ,(set-name (spec-name spec))
+		      (,%record-modifier ,type-name ',(spec-name spec))))
+		 field-specs)
+
+	  ;; Methods (we only handle DISCLOSE methods).
+	  ,@(map (lambda (m)
+		   `(,%def-rec-discloser ,type-name
+		      (,%lambda ,(cdar m) . ,(cdr m))))
+		 method-specs)
+	  )))))
hunk ./init.scm 7
-(require 'macro-by-example)
+
+(load-from-path "scsh/syntax.scm")
+
hunk ./init.scm 12
+(load-from-path "scsh/receive.scm")
+
hunk ./init.scm 19
+(load-from-path "scsh/defrec.scm")
hunk ./receive.scm 1
+; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
+
+
+(define-syntax receive
+  (syntax-rules ()
+    ((receive ?vars ?producer . ?body)
+     (call-with-values (lambda () ?producer)
+       (lambda ?vars . ?body)))))
hunk ./syntax.scm 1
+; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
+; for Guile: redefined define-syntax, added syntax-error definition.
+
+; This definition of define-syntax is appropriate for Scheme-to-C.
+
+;(define-macro define-syntax
+;  (lambda (form expander)
+;    (expander `(define-macro ,(cadr form)
+;		 (let ((transformer ,(caddr form)))
+;		   (lambda (form expander)
+;		     (expander (transformer form
+;					    (lambda (x) x)
+;					    eq?)
+;			       expander))))
+;	      expander)))
+
+; This is the version for Guile.
+(defmacro define-syntax (name expander)
+  `(define ,name (defmacro:transformer (lambda form
+					 (,expander (cons ,name
+							  form)
+						    (lambda (x) x)
+						    eq?)))))
+
+
+(define syntax-error error)
+
+; Rewrite-rule compiler (a.k.a. "extend-syntax")
+
+; Example:
+;
+; (define-syntax or
+;   (syntax-rules ()
+;     ((or) #f)
+;     ((or e) e)
+;     ((or e1 e ...) (let ((temp e1))
+;		       (if temp temp (or e ...))))))
+
+(define-syntax syntax-rules
+  (let ()
+
+    (define name? symbol?)
+
+    (define (segment-pattern? pattern)
+      (and (segment-template? pattern)
+	   (or (null? (cddr pattern))
+	       (syntax-error "segment matching not implemented" pattern))))
+
+    (define (segment-template? pattern)
+      (and (pair? pattern)
+	   (pair? (cdr pattern))
+	   (memq (cadr pattern) indicators-for-zero-or-more)))
+
+    (define indicators-for-zero-or-more (list (string->symbol "...") '---))
+
+    (lambda (exp r c)
+
+      (define %input (r '%input))     ;Gensym these, if you like.
+      (define %compare (r '%compare))
+      (define %rename (r '%rename))
+      (define %tail (r '%tail))
+      (define %temp (r '%temp))
+
+      (define rules (cddr exp))
+      (define subkeywords (cadr exp))
+
+  (define (make-transformer rules)
+    `(lambda (,%input ,%rename ,%compare)
+       (let ((,%tail (cdr ,%input)))
+	 (cond ,@(map process-rule rules)
+		 (else
+		  (syntax-error
+		   "use of macro doesn't match definition"
+		   ,%input))))))
+
+  (define (process-rule rule)
+    (if (and (pair? rule)
+	     (pair? (cdr rule))
+	     (null? (cddr rule)))
+	(let ((pattern (cdar rule))
+	      (template (cadr rule)))
+	  `((and ,@(process-match %tail pattern))
+	    (let* ,(process-pattern pattern
+				      %tail
+				      (lambda (x) x))
+		    ,(process-template template
+				       0
+				       (meta-variables pattern 0 '())))))
+	(syntax-error "ill-formed syntax rule" rule)))
+
+  ; Generate code to test whether input expression matches pattern
+
+  (define (process-match input pattern)
+    (cond ((name? pattern)
+	   (if (member pattern subkeywords)
+	       `((,%compare ,input (,%rename ',pattern)))
+	       `()))
+	  ((segment-pattern? pattern)
+	   (process-segment-match input (car pattern)))
+	  ((pair? pattern)
+	   `((let ((,%temp ,input))
+	       (and (pair? ,%temp)
+		    ,@(process-match `(car ,%temp) (car pattern))
+		    ,@(process-match `(cdr ,%temp) (cdr pattern))))))
+	  ((or (null? pattern) (boolean? pattern) (char? pattern))
+	   `((eq? ,input ',pattern)))
+	  (else
+	   `((equal? ,input ',pattern)))))
+
+  (define (process-segment-match input pattern)
+    (let ((conjuncts (process-match '(car l) pattern)))
+      (if (null? conjuncts)
+	  `((list? ,input))			;+++
+	  `((let loop ((l ,input))
+	      (or (null? l)
+		  (and (pair? l)
+		       ,@conjuncts
+		       (loop (cdr l)))))))))
+
+  ; Generate code to take apart the input expression
+  ; This is pretty bad, but it seems to work (can't say why).
+
+  (define (process-pattern pattern path mapit)
+    (cond ((name? pattern)
+	   (if (memq pattern subkeywords)
+	       '()
+	       (list (list pattern (mapit path)))))
+	  ((segment-pattern? pattern)
+	   (process-pattern (car pattern)
+			    %temp
+			    (lambda (x)	;temp is free in x
+			      (mapit (if (eq? %temp x)
+					 path ;+++
+					 `(map (lambda (,%temp) ,x)
+						 ,path))))))
+	  ((pair? pattern)
+	   (append (process-pattern (car pattern) `(car ,path) mapit)
+		   (process-pattern (cdr pattern) `(cdr ,path) mapit)))
+	  (else '())))
+
+  ; Generate code to compose the output expression according to template
+
+  (define (process-template template rank env)
+    (cond ((name? template)
+	   (let ((probe (assq template env)))
+	     (if probe
+		 (if (<= (cdr probe) rank)
+		     template
+		     (syntax-error "template rank error (too few ...'s?)"
+				   template))
+		 `(,%rename ',template))))
+	  ((segment-template? template)
+	   (let ((vars
+		  (free-meta-variables (car template) (+ rank 1) env '())))
+	     (if (null? vars)
+		 (syntax-error "too many ...'s" template)
+		 (let* ((x (process-template (car template)
+					     (+ rank 1)
+					     env))
+			(gen (if (equal? (list x) vars)
+				 x	;+++
+				 `(map (lambda ,vars ,x)
+					 ,@vars))))
+		   (if (null? (cddr template))
+		       gen		;+++
+		       `(append ,gen ,(process-template (cddr template)
+							  rank env)))))))
+	  ((pair? template)
+	   `(cons ,(process-template (car template) rank env)
+		    ,(process-template (cdr template) rank env)))
+	  (else `(quote ,template))))
+
+  ; Return an association list of (var . rank)
+
+  (define (meta-variables pattern rank vars)
+    (cond ((name? pattern)
+	   (if (memq pattern subkeywords)
+	       vars
+	       (cons (cons pattern rank) vars)))
+	  ((segment-pattern? pattern)
+	   (meta-variables (car pattern) (+ rank 1) vars))
+	  ((pair? pattern)
+	   (meta-variables (car pattern) rank
+			   (meta-variables (cdr pattern) rank vars)))
+	  (else vars)))
+
+  ; Return a list of meta-variables of given higher rank
+
+  (define (free-meta-variables template rank env free)
+    (cond ((name? template)
+	   (if (and (not (memq template free))
+		    (let ((probe (assq template env)))
+		      (and probe (>= (cdr probe) rank))))
+	       (cons template free)
+	       free))
+	  ((segment-template? template)
+	   (free-meta-variables (car template)
+				rank env
+				(free-meta-variables (cddr template)
+						     rank env free)))
+	  ((pair? template)
+	   (free-meta-variables (car template)
+				rank env
+				(free-meta-variables (cdr template)
+						     rank env free)))
+	  (else free)))
+
+  c ;ignored
+
+  ;; Kludge for Scheme 48 static linker.
+  ;; `(cons ,(make-transformer rules)
+  ;;          ',(find-free-names-in-syntax-rules subkeywords rules))
+
+  (make-transformer rules))))