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