TakeV/guile-prescheme
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Port define-node-type macro

Browse source
This commit is contained in:
Andrew Whatson 2022-07-21 23:00:03 +10:00
parent cff1539ddc
commit a6244ee560
1 changed files with 29 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

53
ps-compiler/node/node.scm
View file

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