Find file
Fetching contributors…
Cannot retrieve contributors at this time
74 lines (70 sloc) 2.21 KB
;;; cogen-ctors.scm
;;; copyright © 1996, 1997, 1998 by Peter Thiemann
;;; non-commercial use is free as long as the original copright notice
;;; remains intact
;;; definitions that implement constructors
;;; example:
;;; (define-data type-name (nil) (cons car cdr))
;;; defines a datatype with two constructors, the nullary "nil" and
;;; the binary "cons", the selectors of the latter being "car" and "cdr"
(define-syntax define-data
(lambda (x r c)
(let* ((%begin (r 'begin))
(%car (r 'car))
(%define (r 'define))
(%equal? (r 'equal?))
(%if (r 'if))
(%list (r 'list))
(%list-ref (r 'list-ref))
(rest (cddr x))
(ctor-decls (if (pair? (car rest)) rest (cdr rest))))
(cons %begin
(apply append
(map (lambda (ctor-decl)
(let* ((ctor-name (car ctor-decl))
(ctor-test (string->symbol (string-append
ctor-name) "?"))))
(,%list ',(car ctor-decl)
,@(cdr ctor-decl)))
`(,%define (,ctor-test arg)
(,%equal? (,%car arg) ',ctor-name))
(let loop ((sels (cdr ctor-decl)) (i 1))
(if (null? sels)
(,(car sels) x)
(,%if (,ctor-test x)
(,%list-ref x ,i)
(error "bad selector ~A applied to ~S" ',(car sels) x)))
(loop (cdr sels) (+ i 1)))))))))
;;;(define-syntax defctor
;;; (lambda (x r c)
;;; `(,(r 'define)
;;; ,(cadr x)
;;; (,(r 'list) ,@(cddr x)))))
;;; define-syntax does not work as a single expression must expand to
;;; another single expression
;;; no there was a format error, furthermore the form (begin <define>
;;; ...) is explicitly allowed for (essential syntax)!
(define (ctors-make-test ctor)
(string->symbol (string-append (symbol->string ctor) "?")))
(define (ctors-generate-define defconstr-clause)
(map (lambda (ctor-decl)
`(define ,ctor-decl (list ',(car ctor-decl) ,@(cdr ctor-decl)))
(let loop ((sels (cdr ctor-decl)) (i 1))
(if (null? sels)
`(define (,(car sels) x) (list-ref x ,i))
(loop (cdr sels) (+ i 1)))))))
(cdr defconstr-clause)))