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 match)
  24   :use-module (ice-9 receive)
  25   :use-module (ice-9 and-let-star)
  26   :export (stack-catch match syntax-error receive and-let*))
  27
  28 \f
  29 ;;;
  30 ;;; Keywords by `:KEYWORD
  31 ;;;
  32
  33 (read-set! keywords 'prefix)
  34
  35 \f
  36 ;;;
  37 ;;; Dot expansion
  38 ;;;
  39
  40 ;; FOO.BAR -> (slot FOO 'BAR)
  41
  42 (define (expand-dot! x)
  43   (cond ((symbol? x) (expand-symbol x))
  44         ((pair? x)
  45          (cond ((eq? (car x) 'quote) x)
  46                (else (set-car! x (expand-dot! (car x)))
  47                      (set-cdr! x (expand-dot! (cdr x)))
  48                      x)))
  49         (else x)))
  50
  51 (define (expand-symbol x)
  52   (let loop ((s (symbol->string x)))
  53     (let ((i (string-rindex s #\.)))
  54       (if i
  55           `(slot ,(loop (substring s 0 i))
  56                  (quote ,(string->symbol (substring s (1+ i)))))
  57           (string->symbol s)))))
  58
  59 (export-syntax syntax)
  60 (define syntax expand-dot!)
  61
  62 \f
  63 ;;;
  64 ;;; Type
  65 ;;;
  66
  67 (export-syntax define-type)
  68 (define-macro (define-type name sig) sig)
  69
  70 ;;;
  71 ;;; Record
  72 ;;;
  73
  74 (export-syntax define-record)
  75 (define-macro (define-record def)
  76   (let ((name (car def)) (slots (cdr def)))
  77     `(begin
  78        (define (,name . args)
  79          (vector ',name (%make-struct
  80                          args
  81                          (list ,@(map (lambda (slot)
  82                                         (if (pair? slot)
  83                                           `(cons ',(car slot) ,(cadr slot))
  84                                           `',slot))
  85                                       slots)))))
  86        (define (,(symbol-append name '?) x)
  87          (and (vector? x) (eq? (vector-ref x 0) ',name)))
  88        ,@(do ((n 1 (1+ n))
  89               (slots (cdr def) (cdr slots))
  90               (ls '() (cons (let* ((slot (car slots))
  91                                    (slot (if (pair? slot) (car slot) slot)))
  92                               `(define ,(string->symbol
  93                                          (format #f "~A-~A" name n))
  94                                  (lambda (x) (slot x ',slot))))
  95                             ls)))
  96              ((null? slots) (reverse! ls))))))
  97
  98 (define *unbound* "#<unbound>")
  99
 100 (define-public (%make-struct args slots)
 101   (map (lambda (slot)
 102          (let* ((key (if (pair? slot) (car slot) slot))
 103                 (def (if (pair? slot) (cdr slot) *unbound*))
 104                 (val (get-key args (symbol->keyword key) def)))
 105            (if (eq? val *unbound*)
 106              (error "Slot unbound:" key)
 107              (cons key val))))
 108        slots))
 109
 110 (define (get-key klist key def)
 111   (do ((ls klist (cddr ls)))
 112       ((or (null? ls) (eq? (car ls) key))
 113        (if (null? ls) def (cadr ls)))))
 114
 115 (define-public slot
 116   (make-procedure-with-setter
 117    (lambda (struct name)
 118      (let ((data (assq name (vector-ref struct 1))))
 119        (cond ((not data)
 120               (error "Unknown slot:" name))
 121              (else (cdr data)))))
 122    (lambda (struct name val)
 123      (let ((data (assq name (vector-ref struct 1))))
 124        (cond ((not data)
 125               (error "Unknown slot:" name))
 126              (else (set-cdr! data val)))))))
 127
 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))))