module/system/base/syntax.scm

   1 ;;; Guile VM specific syntaxes and utilities
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA
  19
  20 ;;; Code:
  21
  22 (define-module (system base syntax)
  23   #:export (%compute-initargs)
  24   #:export-syntax (define-type define-record record-case))
  25
  26 \f
  27 ;;;
  28 ;;; Type
  29 ;;;
  30
  31 (define-macro (define-type name . rest)
  32   (let ((name (if (pair? name) (car name) name))
  33         (opts (if (pair? name) (cdr name) '())))
  34     (let ((printer (kw-arg-ref opts #:printer)))
  35       `(begin ,@(map (lambda (def)
  36                        `(define-record ,(if printer
  37                                             `(,(car def) ,printer)
  38                                             (car def))
  39                           ,@(cdr def)))
  40                      rest)))))
  41
  42
  43 ;;;
  44 ;;; Record
  45 ;;;
  46
  47 (define (symbol-trim-both sym pred)
  48   (string->symbol (string-trim-both (symbol->string sym) pred)))
  49
  50 (define-macro (define-record name-form . slots)
  51   (let* ((name (if (pair? name-form) (car name-form) name-form))
  52          (printer (and (pair? name-form) (cadr name-form)))
  53          (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
  54                           slots))
  55          (stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
  56     `(begin
  57        (define ,name (make-record-type ,(symbol->string name) ',slot-names
  58                                        ,@(if printer (list printer) '())))
  59        (define ,(symbol-append 'make- stem)
  60          (let ((slots (list ,@(map (lambda (slot)
  61                                      (if (pair? slot)
  62                                          `(cons ',(car slot) ,(cadr slot))
  63                                          `',slot))
  64                                    slots)))
  65                (constructor (record-constructor ,name)))
  66            (lambda args
  67              (apply constructor (%compute-initargs args slots)))))
  68        (define ,(symbol-append stem '?) (record-predicate ,name))
  69        ,@(map (lambda (sname)
  70                 `(define ,(symbol-append stem '- sname)
  71                    (make-procedure-with-setter
  72                     (record-accessor ,name ',sname)
  73                     (record-modifier ,name ',sname))))
  74               slot-names))))
  75
  76 (define (%compute-initargs args slots)
  77   (define (finish out)
  78     (map (lambda (slot)
  79            (let ((name (if (pair? slot) (car slot) slot)))
  80              (cond ((assq name out) => cdr)
  81                    ((pair? slot) (cdr slot))
  82                    (else (error "unbound slot" args slots name)))))
  83          slots))
  84   (let lp ((in args) (positional slots) (out '()))
  85     (cond
  86      ((null? in)
  87       (finish out))
  88      ((keyword? (car in))
  89       (let ((sym (keyword->symbol (car in))))
  90         (cond
  91          ((and (not (memq sym slots))
  92                (not (assq sym (filter pair? slots))))
  93           (error "unknown slot" sym))
  94          ((assq sym out) (error "slot already set" sym out))
  95          (else (lp (cddr in) '() (acons sym (cadr in) out))))))
  96      ((null? positional)
  97       (error "too many initargs" args slots))
  98      (else
  99       (lp (cdr in) (cdr positional)
 100           (let ((slot (car positional)))
 101             (acons (if (pair? slot) (car slot) slot)
 102                    (car in)
 103                    out)))))))
 104
 105 (define-macro (record-case record . clauses)
 106   (let ((r (gensym)))
 107     (define (process-clause clause)
 108       (if (eq? (car clause) 'else)
 109           clause
 110           (let ((record-type (caar clause))
 111                 (slots (cdar clause))
 112                 (body (cdr clause)))
 113             `(((record-predicate ,record-type) ,r)
 114               (let ,(map (lambda (slot)
 115                            (if (pair? slot)
 116                                `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r))
 117                                `(,slot ((record-accessor ,record-type ',slot) ,r))))
 118                          slots)
 119                 ,@body)))))
 120     `(let ((,r ,record))
 121        (cond ,@(let ((clauses (map process-clause clauses)))
 122                  (if (assq 'else clauses)
 123                      clauses
 124                      (append clauses `((else (error "unhandled record" ,r))))))))))