Port define-node-type macro
This commit is contained in:
parent
cff1539ddc
commit
a6244ee560
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue