123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300 |
- ;;; Guile VM specific syntaxes and utilities
- ;; Copyright (C) 2001, 2009, 2016, 2019 Free Software Foundation, Inc
- ;;; This library is free software; you can redistribute it and/or
- ;;; modify it under the terms of the GNU Lesser General Public
- ;;; License as published by the Free Software Foundation; either
- ;;; version 3 of the License, or (at your option) any later version.
- ;;;
- ;;; This library is distributed in the hope that it will be useful,
- ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- ;;; Lesser General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU Lesser General Public
- ;;; License along with this library; if not, write to the Free Software
- ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
- ;;; Code:
- (define-module (system base syntax)
- #:export (%compute-initargs)
- #:export-syntax (define-type define-record define-record/keywords
- record-case transform-record))
- (define (symbol-trim-both sym pred)
- (string->symbol (string-trim-both (symbol->string sym) pred)))
- (define (trim-brackets sym)
- (symbol-trim-both sym (list->char-set '(#\< #\>))))
- ;;;
- ;;; Type
- ;;;
- (define-macro (define-type name . rest)
- (let ((name (if (pair? name) (car name) name))
- (opts (if (pair? name) (cdr name) '())))
- (let ((printer (kw-arg-ref opts #:printer))
- (common-slots (or (kw-arg-ref opts #:common-slots) '())))
- `(begin ,@(map (lambda (def)
- `(define-record ,(if printer
- `(,(car def) ,printer)
- (car def))
- ,@common-slots
- ,@(cdr def)))
- rest)
- ,@(map (lambda (common-slot i)
- `(define ,(symbol-append (trim-brackets name)
- '- common-slot)
- (make-procedure-with-setter
- (lambda (x) (struct-ref x ,i))
- (lambda (x v) (struct-set! x ,i v)))))
- common-slots (iota (length common-slots)))))))
- ;;;
- ;;; Record
- ;;;
- (define-macro (define-record name-form . slots)
- (let* ((name (if (pair? name-form) (car name-form) name-form))
- (printer (and (pair? name-form) (cadr name-form)))
- (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
- slots))
- (stem (trim-brackets name)))
- `(begin
- (define ,name (make-record-type ',name ',slot-names
- ,@(if printer (list printer) '())))
- ,(let* ((reqs (let lp ((slots slots))
- (if (or (null? slots) (not (symbol? (car slots))))
- '()
- (cons (car slots) (lp (cdr slots))))))
- (opts (list-tail slots (length reqs)))
- (tail (module-gensym "defrec")))
- `(define (,(symbol-append 'make- stem) ,@reqs . ,tail)
- (let ,(map (lambda (o)
- `(,(car o) (cond ((null? ,tail) ,(cadr o))
- (else (let ((_x (car ,tail)))
- (set! ,tail (cdr ,tail))
- _x)))))
- opts)
- (make-struct/no-tail ,name ,@slot-names))))
- (define ,(symbol-append stem '?) (record-predicate ,name))
- ,@(map (lambda (sname)
- `(define ,(symbol-append stem '- sname)
- (make-procedure-with-setter
- (record-accessor ,name ',sname)
- (record-modifier ,name ',sname))))
- slot-names))))
- ;; like the former, but accepting keyword arguments in addition to
- ;; optional arguments
- (define-macro (define-record/keywords name-form . slots)
- (let* ((name (if (pair? name-form) (car name-form) name-form))
- (printer (and (pair? name-form) (cadr name-form)))
- (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
- slots))
- (stem (trim-brackets name)))
- `(begin
- (define ,name (make-record-type ',name ',slot-names
- ,@(if printer (list printer) '())))
- (define ,(symbol-append 'make- stem)
- (let ((slots (list ,@(map (lambda (slot)
- (if (pair? slot)
- `(cons ',(car slot) ,(cadr slot))
- `',slot))
- slots)))
- (constructor (record-constructor ,name)))
- (lambda args
- (apply constructor (%compute-initargs args slots)))))
- (define ,(symbol-append stem '?) (record-predicate ,name))
- ,@(map (lambda (sname)
- `(define ,(symbol-append stem '- sname)
- (make-procedure-with-setter
- (record-accessor ,name ',sname)
- (record-modifier ,name ',sname))))
- slot-names))))
- (define (%compute-initargs args slots)
- (define (finish out)
- (map (lambda (slot)
- (let ((name (if (pair? slot) (car slot) slot)))
- (cond ((assq name out) => cdr)
- ((pair? slot) (cdr slot))
- (else (error "unbound slot" args slots name)))))
- slots))
- (let lp ((in args) (positional slots) (out '()))
- (cond
- ((null? in)
- (finish out))
- ((keyword? (car in))
- (let ((sym (keyword->symbol (car in))))
- (cond
- ((and (not (memq sym slots))
- (not (assq sym (filter pair? slots))))
- (error "unknown slot" sym))
- ((assq sym out) (error "slot already set" sym out))
- (else (lp (cddr in) '() (acons sym (cadr in) out))))))
- ((null? positional)
- (error "too many initargs" args slots))
- (else
- (lp (cdr in) (cdr positional)
- (let ((slot (car positional)))
- (acons (if (pair? slot) (car slot) slot)
- (car in)
- out)))))))
- ;;; FIXME: Re-write uses of `record-case' to use `match' instead.
- (define-syntax record-case
- (lambda (x)
- (syntax-case x ()
- ((_ record clause ...)
- (let ((r (syntax r))
- (rtd (syntax rtd)))
- (define (process-clause tag fields exprs)
- (let ((infix (trim-brackets (syntax->datum tag))))
- (with-syntax ((tag tag)
- (((f . accessor) ...)
- (let lp ((fields fields))
- (syntax-case fields ()
- (() (syntax ()))
- (((v0 f0) f1 ...)
- (acons (syntax v0)
- (datum->syntax x
- (symbol-append infix '- (syntax->datum
- (syntax f0))))
- (lp (syntax (f1 ...)))))
- ((f0 f1 ...)
- (acons (syntax f0)
- (datum->syntax x
- (symbol-append infix '- (syntax->datum
- (syntax f0))))
- (lp (syntax (f1 ...))))))))
- ((e0 e1 ...)
- (syntax-case exprs ()
- (() (syntax (#t)))
- ((e0 e1 ...) (syntax (e0 e1 ...))))))
- (syntax
- ((eq? rtd tag)
- (let ((f (accessor r))
- ...)
- e0 e1 ...))))))
- (with-syntax
- ((r r)
- (rtd rtd)
- ((processed ...)
- (let lp ((clauses (syntax (clause ...)))
- (out '()))
- (syntax-case clauses (else)
- (()
- (reverse! (cons (syntax
- (else (error "unhandled record" r)))
- out)))
- (((else e0 e1 ...))
- (reverse! (cons (syntax (else e0 e1 ...)) out)))
- (((else e0 e1 ...) . rest)
- (syntax-violation 'record-case
- "bad else clause placement"
- (syntax x)
- (syntax (else e0 e1 ...))))
- ((((<foo> f0 ...) e0 ...) . rest)
- (lp (syntax rest)
- (cons (process-clause (syntax <foo>)
- (syntax (f0 ...))
- (syntax (e0 ...)))
- out)))))))
- (syntax
- (let* ((r record)
- (rtd (struct-vtable r)))
- (cond processed ...)))))))))
- ;; Here we take the terrorism to another level. Nasty, but the client
- ;; code looks good.
- (define-macro (transform-record type-and-common record . clauses)
- (let ((r (module-gensym "rec"))
- (rtd (module-gensym "rtd"))
- (type-stem (trim-brackets (car type-and-common))))
- (define (make-stem s)
- (symbol-append type-stem '- s))
- (define (further-predicates x record-stem slots)
- (define (access slot)
- `(,(symbol-append (make-stem record-stem) '- slot) ,x))
- (let lp ((in slots) (out '()))
- (cond ((null? in) out)
- ((pair? (car in))
- (let ((slot (caar in))
- (arg (cadar in)))
- (cond ((symbol? arg)
- (lp (cdr in) out))
- ((pair? arg)
- (lp (cdr in)
- (append (further-predicates (access slot)
- (car arg)
- (cdr arg))
- out)))
- (else (lp (cdr in) (cons `(eq? ,(access slot) ',arg)
- out))))))
- (else (lp (cdr in) out)))))
- (define (let-clauses x record-stem slots)
- (define (access slot)
- `(,(symbol-append (make-stem record-stem) '- slot) ,x))
- (let lp ((in slots) (out '()))
- (cond ((null? in) out)
- ((pair? (car in))
- (let ((slot (caar in))
- (arg (cadar in)))
- (cond ((symbol? arg)
- (lp (cdr in)
- (cons `(,arg ,(access slot)) out)))
- ((pair? arg)
- (lp (cdr in)
- (append (let-clauses (access slot)
- (car arg)
- (cdr arg))
- out)))
- (else
- (lp (cdr in) out)))))
- (else
- (lp (cdr in)
- (cons `(,(car in) ,(access (car in))) out))))))
- (define (transform-expr x)
- (cond ((not (pair? x)) x)
- ((eq? (car x) '->)
- (if (= (length x) 2)
- (let ((form (cadr x)))
- `(,(symbol-append 'make- (make-stem (car form)))
- ,@(cdr type-and-common)
- ,@(map (lambda (y)
- (if (and (pair? y) (eq? (car y) 'unquote))
- (transform-expr (cadr y))
- y))
- (cdr form))))
- (error "bad -> form" x)))
- (else (cons (car x) (map transform-expr (cdr x))))))
- (define (process-clause clause)
- (if (eq? (car clause) 'else)
- clause
- (let ((stem (caar clause))
- (slots (cdar clause))
- (body (cdr clause)))
- (let ((record-type (symbol-append '< (make-stem stem) '>)))
- `((and (eq? ,rtd ,record-type)
- ,@(reverse (further-predicates r stem slots)))
- (let ,(reverse (let-clauses r stem slots))
- ,@(if (pair? body)
- (map transform-expr body)
- '((if #f #f)))))))))
- `(let* ((,r ,record)
- (,rtd (struct-vtable ,r))
- ,@(map (lambda (slot)
- `(,slot (,(make-stem slot) ,r)))
- (cdr type-and-common)))
- (cond ,@(let ((clauses (map process-clause clauses)))
- (if (assq 'else clauses)
- clauses
- (append clauses `((else (error "unhandled record" ,r))))))))))
|