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   `(begin ,@(map (lambda (def) `(define-record ,def)) rest)))
  33
  34
  35 ;;;
  36 ;;; Record
  37 ;;;
  38
  39 (define (symbol-trim-both sym pred)
  40   (string->symbol (string-trim-both (symbol->string sym) pred)))
  41
  42 (define-macro (define-record def)
  43   (let* ((name (car def)) (slots (cdr def))
  44          (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
  45                           slots))
  46          (stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
  47     `(begin
  48        (define ,name (make-record-type ,(symbol->string name) ',slot-names))
  49        (define ,(symbol-append 'make- stem)
  50          (let ((slots (list ,@(map (lambda (slot)
  51                                      (if (pair? slot)
  52                                          `(cons ',(car slot) ,(cadr slot))
  53                                          `',slot))
  54                                    slots)))
  55                (constructor (record-constructor ,name)))
  56            (lambda args
  57              (apply constructor (%compute-initargs args slots)))))
  58        (define ,(symbol-append stem '?) (record-predicate ,name))
  59        ,@(map (lambda (sname)
  60                 `(define ,(symbol-append stem '- sname)
  61                    (make-procedure-with-setter
  62                     (record-accessor ,name ',sname)
  63                     (record-modifier ,name ',sname))))
  64               slot-names))))
  65
  66 (define (%compute-initargs args slots)
  67   (define (finish out)
  68     (map (lambda (slot)
  69            (let ((name (if (pair? slot) (car slot) slot)))
  70              (cond ((assq name out) => cdr)
  71                    ((pair? slot) (cdr slot))
  72                    (else (error "unbound slot" args slots name)))))
  73          slots))
  74   (let lp ((in args) (positional slots) (out '()))
  75     (cond
  76      ((null? in)
  77       (finish out))
  78      ((keyword? (car in))
  79       (let ((sym (keyword->symbol (car in))))
  80         (cond
  81          ((and (not (memq sym slots))
  82                (not (assq sym (filter pair? slots))))
  83           (error "unknown slot" sym))
  84          ((assq sym out) (error "slot already set" sym out))
  85          (else (lp (cddr in) '() (acons sym (cadr in) out))))))
  86      ((null? positional)
  87       (error "too many initargs" args slots))
  88      (else
  89       (lp (cdr in) (cdr positional)
  90           (let ((slot (car positional)))
  91             (acons (if (pair? slot) (car slot) slot)
  92                    (car in)
  93                    out)))))))
  94
  95 (define-macro (record-case record . clauses)
  96   (let ((r (gensym)))
  97     (define (process-clause clause)
  98       (if (eq? (car clause) 'else)
  99           clause
 100           (let ((record-type (caar clause))
 101                 (slots (cdar clause))
 102                 (body (cdr clause)))
 103             `(((record-predicate ,record-type) ,r)
 104               (let ,(map (lambda (slot)
 105                            (if (pair? slot)
 106                                `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r))
 107                                `(,slot ((record-accessor ,record-type ',slot) ,r))))
 108                          slots)
 109                 ,@body)))))
 110     `(let ((,r ,record))
 111        (cond ,@(let ((clauses (map process-clause clauses)))
 112                  (if (assq 'else clauses)
 113                      clauses
 114                      (append clauses `((else (error "unhandled record" ,r))))))))))