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   :use-module (ice-9 receive)
  24   :use-module (ice-9 and-let-star)
  25   :export (stack-catch receive and-let*))
  26
  27 \f
  28 ;;;
  29 ;;; Keywords by `:KEYWORD
  30 ;;;
  31
  32 (read-set! keywords 'prefix)
  33
  34 \f
  35 ;;;
  36 ;;; Dot expansion
  37 ;;;
  38
  39 ;; FOO.BAR -> (slot FOO 'BAR)
  40
  41 (define (expand-dot! x)
  42   (cond ((symbol? x) (expand-symbol x))
  43         ((pair? x)
  44          (cond ((eq? (car x) 'quote) x)
  45                (else (set-car! x (expand-dot! (car x)))
  46                      (set-cdr! x (expand-dot! (cdr x)))
  47                      x)))
  48         (else x)))
  49
  50 (define (expand-symbol x)
  51   (let loop ((s (symbol->string x)))
  52     (let ((i (string-rindex s #\.)))
  53       (if i
  54           `(slot ,(loop (substring s 0 i))
  55                  (quote ,(string->symbol (substring s (1+ i)))))
  56           (string->symbol s)))))
  57
  58 (export-syntax syntax)
  59 (define syntax expand-dot!)
  60
  61 \f
  62 ;;;
  63 ;;; Type
  64 ;;;
  65
  66 (export-syntax define-type)
  67 (define-macro (define-type name sig) sig)
  68
  69 ;;;
  70 ;;; Record
  71 ;;;
  72
  73 (export-syntax define-record)
  74 (define-macro (define-record def)
  75   (let ((name (car def)) (slots (cdr def)))
  76     `(begin
  77        (define (,name . args)
  78          (vector ',name (%make-struct
  79                          args
  80                          (list ,@(map (lambda (slot)
  81                                         (if (pair? slot)
  82                                           `(cons ',(car slot) ,(cadr slot))
  83                                           `',slot))
  84                                       slots)))))
  85        (define (,(symbol-append name '?) x)
  86          (and (vector? x) (eq? (vector-ref x 0) ',name)))
  87        ,@(do ((n 1 (1+ n))
  88               (slots (cdr def) (cdr slots))
  89               (ls '() (cons (let* ((slot (car slots))
  90                                    (slot (if (pair? slot) (car slot) slot)))
  91                               `(define ,(string->symbol
  92                                          (format #f "~A-~A" name n))
  93                                  (lambda (x) (slot x ',slot))))
  94                             ls)))
  95              ((null? slots) (reverse! ls))))))
  96
  97 (define *unbound* "#<unbound>")
  98
  99 (define-public (%make-struct args slots)
 100   (map (lambda (slot)
 101          (let* ((key (if (pair? slot) (car slot) slot))
 102                 (def (if (pair? slot) (cdr slot) *unbound*))
 103                 (val (get-key args (symbol->keyword key) def)))
 104            (if (eq? val *unbound*)
 105              (error "slot unbound" key)
 106              (cons key val))))
 107        slots))
 108
 109 (define (get-key klist key def)
 110   (do ((ls klist (cddr ls)))
 111       ((or (null? ls) (eq? (car ls) key))
 112        (if (null? ls) def (cadr ls)))))
 113
 114 (define-public slot
 115   (make-procedure-with-setter
 116    (lambda (struct name)
 117      (let ((data (assq name (vector-ref struct 1))))
 118        (cond ((not data)
 119               (error "unknown slot" name))
 120              (else (cdr data)))))
 121    (lambda (struct name val)
 122      (let ((data (assq name (vector-ref struct 1))))
 123        (cond ((not data)
 124               (error "unknown slot" name))
 125              (else (set-cdr! data val)))))))
 126
 127 \f
 128 ;;;
 129 ;;; Variants
 130 ;;;
 131
 132 (export-syntax |)
 133 (define-macro (| . rest)
 134   `(begin ,@(map %make-variant-type rest)))
 135
 136 (define (%make-variant-type def)
 137   (let ((name (car def)) (slots (cdr def)))
 138     `(begin
 139        (define ,def (vector ',name ,@slots))
 140        (define (,(symbol-append name '?) x)
 141          (and (vector? x) (eq? (vector-ref x 0) ',name)))
 142        ,@(do ((n 1 (1+ n))
 143               (slots slots (cdr slots))
 144               (ls '() (cons `(define ,(string->symbol
 145                                        (format #f "~A-~A" name n))
 146                                ,(string->symbol (format #f "%slot-~A" n)))
 147                             ls)))
 148              ((null? slots) (reverse! ls))))))
 149
 150 (define-public (%slot-1 x) (vector-ref x 1))
 151 (define-public (%slot-2 x) (vector-ref x 2))
 152 (define-public (%slot-3 x) (vector-ref x 3))
 153 (define-public (%slot-4 x) (vector-ref x 4))
 154 (define-public (%slot-5 x) (vector-ref x 5))
 155 (define-public (%slot-6 x) (vector-ref x 6))
 156 (define-public (%slot-7 x) (vector-ref x 7))
 157 (define-public (%slot-8 x) (vector-ref x 8))
 158 (define-public (%slot-9 x) (vector-ref x 9))
 159
 160 \f
 161 ;;;
 162 ;;; Utilities
 163 ;;;
 164
 165 (define-public (list-fold f d l)
 166   (if (null? l)
 167       d
 168       (list-fold f (f (car l) d) (cdr l))))