diff --git a/ps-compiler/node/node.scm b/ps-compiler/node/node.scm index 6e34df1..1df9b6d 100644 --- a/ps-compiler/node/node.scm +++ b/ps-compiler/node/node.scm @@ -12,6 +12,10 @@ ;;; Records to represent variables. (define-module (ps-compiler node node) + #:use-module (prescheme s48-defrecord) + #:use-module (prescheme record-discloser) + #:use-module (prescheme syntax-utils) + #:use-module (ps-compiler util syntax) #:export (variable? make-variable global-variable? make-global-variable variable-name set-variable-name! @@ -428,34 +432,35 @@ ;; Syntax for defining the different types of nodes. (define-syntax define-node-type - (lambda (form rename compare) - (let ((id (cadr form)) - (slots (cddr form))) - (let ((pred (concatenate-symbol id '- 'node?))) - `(begin (define (,pred x) - (eq? ',id (node-variant x))) - . ,(do ((i 0 (+ i 1)) - (s slots (cdr s)) - (r '() (let ((n (concatenate-symbol id '- (car s))) - (f (concatenate-symbol 'node-stuff- i))) - `((define-node-field ,n ,pred ,f) - . ,r)))) - ((null? s) (reverse r)))))))) + (lambda (x) + (syntax-case x () + ((_ id slots ...) + (let* ((pred (syntax-conc #'id '-node?)) + (slots #'(slots ...)) + (indexes (iota (length slots)))) + #`(begin + (define (#,pred x) + (eq? 'id (node-variant x))) + #,@(map (lambda (slot i) + (let* ((getter (syntax-conc #'id '- slot)) + (number (string->symbol (number->string i))) + (field (datum->syntax slot (symbol-append 'node-stuff- number)))) + #`(define-node-field #,getter #,pred #,field))) + slots indexes))))))) ;; These are used to rename the NODE-STUFF fields of particular node variants. (define-syntax define-node-field - (lambda (form rename compare) - (let ((id (cadr form)) - (predicate (caddr form)) - (field (cadddr form))) - `(begin - (define (,id node) - (,field (enforce ,predicate node))) - (define (,(concatenate-symbol 'set- id '!) node val) - (,(concatenate-symbol 'set- field '!) - (enforce ,predicate node) - val)))))) + (lambda (x) + (syntax-case x () + ((_ getter pred field) + (with-syntax ((setter (syntax-conc 'set- #'getter '!)) + (set-field (syntax-conc 'set- #'field '!))) + #'(begin + (define (getter node) + (field (enforce pred node))) + (define (setter node val) + (set-field (enforce pred node) val)))))))) ;;------------------------------------------------------------------------- ;; literals