ice-9/syncase.scm

   1 ;;;;    Copyright (C) 1997, 2000, 2001, 2002 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This program is free software; you can redistribute it and/or modify
   4 ;;;; it under the terms of the GNU General Public License as published by
   5 ;;;; the Free Software Foundation; either version 2, or (at your option)
   6 ;;;; any later version.
   7 ;;;;
   8 ;;;; This program is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 ;;;; GNU General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU General Public License
  14 ;;;; along with this software; see the file COPYING.  If not, write to
  15 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16 ;;;; Boston, MA 02111-1307 USA
  17 ;;;;
  18 ;;;; As a special exception, the Free Software Foundation gives permission
  19 ;;;; for additional uses of the text contained in its release of GUILE.
  20 ;;;;
  21 ;;;; The exception is that, if you link the GUILE library with other files
  22 ;;;; to produce an executable, this does not by itself cause the
  23 ;;;; resulting executable to be covered by the GNU General Public License.
  24 ;;;; Your use of that executable is in no way restricted on account of
  25 ;;;; linking the GUILE library code into it.
  26 ;;;;
  27 ;;;; This exception does not however invalidate any other reasons why
  28 ;;;; the executable file might be covered by the GNU General Public License.
  29 ;;;;
  30 ;;;; This exception applies only to the code released by the
  31 ;;;; Free Software Foundation under the name GUILE.  If you copy
  32 ;;;; code from other Free Software Foundation releases into a copy of
  33 ;;;; GUILE, as the General Public License permits, the exception does
  34 ;;;; not apply to the code that you add in this way.  To avoid misleading
  35 ;;;; anyone as to the status of such modified files, you must delete
  36 ;;;; this exception notice from them.
  37 ;;;;
  38 ;;;; If you write modifications of your own for GUILE, it is your choice
  39 ;;;; whether to permit this exception to apply to your modifications.
  40 ;;;; If you do not wish that, delete this exception notice.
  41 ;;;;
  42 \f
  43
  44 (define-module (ice-9 syncase)
  45   :use-module (ice-9 debug)
  46   :use-module (ice-9 threads)
  47   :export-syntax (sc-macro define-syntax define-syntax-public
  48                   eval-when fluid-let-syntax
  49                   identifier-syntax let-syntax
  50                   letrec-syntax syntax syntax-case  syntax-rules
  51                   with-syntax
  52                   include)
  53   :export (sc-expand sc-expand3 install-global-transformer
  54            syntax-dispatch syntax-error bound-identifier=?
  55            datum->syntax-object free-identifier=?
  56            generate-temporaries identifier? syntax-object->datum
  57            void eval syncase))
  58
  59 \f
  60
  61 (define expansion-eval-closure (make-fluid))
  62
  63 (define (env->eval-closure env)
  64   (or (and env
  65            (car (last-pair env)))
  66       (module-eval-closure the-root-module)))
  67
  68 (define sc-macro
  69   (procedure->memoizing-macro
  70     (lambda (exp env)
  71       (with-fluids ((expansion-eval-closure (env->eval-closure env)))
  72         (sc-expand exp)))))
  73
  74 (fluid-set! expansion-eval-closure (env->eval-closure #f))
  75
  76 ;;; Exported variables
  77
  78 (define sc-expand #f)
  79 (define sc-expand3 #f)
  80 (define install-global-transformer #f)
  81 (define syntax-dispatch #f)
  82 (define syntax-error #f)
  83
  84 (define bound-identifier=? #f)
  85 (define datum->syntax-object #f)
  86 (define define-syntax sc-macro)
  87 (define eval-when sc-macro)
  88 (define fluid-let-syntax sc-macro)
  89 (define free-identifier=? #f)
  90 (define generate-temporaries #f)
  91 (define identifier? #f)
  92 (define identifier-syntax sc-macro)
  93 (define let-syntax sc-macro)
  94 (define letrec-syntax sc-macro)
  95 (define syntax sc-macro)
  96 (define syntax-case sc-macro)
  97 (define syntax-object->datum #f)
  98 (define syntax-rules sc-macro)
  99 (define with-syntax sc-macro)
 100 (define include sc-macro)
 101
 102 (define primitive-syntax '(quote lambda letrec if set! begin define or
 103                            and let let* cond do quasiquote unquote
 104                            unquote-splicing case))
 105
 106 (for-each (lambda (symbol)
 107             (set-symbol-property! symbol 'primitive-syntax #t))
 108           primitive-syntax)
 109
 110 ;;; Hooks needed by the syntax-case macro package
 111
 112 (define (void) *unspecified*)
 113
 114 (define andmap
 115   (lambda (f first . rest)
 116     (or (null? first)
 117         (if (null? rest)
 118             (let andmap ((first first))
 119               (let ((x (car first)) (first (cdr first)))
 120                 (if (null? first)
 121                     (f x)
 122                     (and (f x) (andmap first)))))
 123             (let andmap ((first first) (rest rest))
 124               (let ((x (car first))
 125                     (xr (map car rest))
 126                     (first (cdr first))
 127                     (rest (map cdr rest)))
 128                 (if (null? first)
 129                     (apply f (cons x xr))
 130                     (and (apply f (cons x xr)) (andmap first rest)))))))))
 131
 132 (define (error who format-string why what)
 133   (start-stack 'syncase-stack
 134                (scm-error 'misc-error
 135                           who
 136                           "~A ~S"
 137                           (list why what)
 138                           '())))
 139
 140 (define the-syncase-module (current-module))
 141 (define the-syncase-eval-closure (module-eval-closure the-syncase-module))
 142
 143 (define (putprop symbol key binding)
 144   (let* ((v ((fluid-ref expansion-eval-closure) symbol #t)))
 145     (if (symbol-property symbol 'primitive-syntax)
 146         (if (eq? (fluid-ref expansion-eval-closure) the-syncase-eval-closure)
 147             (set-object-property! (module-variable the-root-module symbol)
 148                                   key
 149                                   binding))
 150         (variable-set! v sc-macro))
 151     (set-object-property! v key binding)))
 152
 153 (define (getprop symbol key)
 154   (let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
 155     (and v (or (object-property v key)
 156                (let ((root-v (module-local-variable the-root-module symbol)))
 157                  (and (equal? root-v v)
 158                       (object-property root-v key)))))))
 159
 160 (define generated-symbols (make-weak-key-hash-table 1019))
 161
 162 ;; We define our own gensym here because the Guile built-in one will
 163 ;; eventually produce uninterned and unreadable symbols (as needed for
 164 ;; safe macro expansions) and will the be inappropriate for dumping to
 165 ;; pssyntax.pp.
 166 ;;
 167 ;; syncase is supposed to only require that gensym produce unique
 168 ;; readable symbols, and they only need be unique with respect to
 169 ;; multiple calls to gensym, not globally unique.
 170 ;;
 171 (define gensym
 172   (let ((counter 0))
 173
 174     (define next-id
 175       (if (provided? 'threads)
 176           (let ((symlock (make-mutex)))
 177             (lambda ()
 178               (let ((result #f))
 179                 (with-mutex symlock
 180                   (set! result counter)
 181                   (set! counter (+ counter 1)))
 182                 result)))
 183           ;; faster, non-threaded case.
 184           (lambda ()
 185             (let ((result counter))
 186               (set! counter (+ counter 1))
 187               result))))
 188
 189     ;; actual gensym body code.
 190     (lambda (. rest)
 191       (let* ((next-val (next-id))
 192              (valstr (number->string next-val)))
 193           (cond
 194            ((null? rest)
 195             (string->symbol (string-append "syntmp-" valstr)))
 196            ((null? (cdr rest))
 197             (string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
 198            (else
 199             (error
 200              (string-append
 201               "syncase's gensym expected 0 or 1 arguments, got "
 202               (length rest)))))))))
 203
 204 ;;; Load the preprocessed code
 205
 206 (let ((old-debug #f)
 207       (old-read #f))
 208   (dynamic-wind (lambda ()
 209                   (set! old-debug (debug-options))
 210                   (set! old-read (read-options)))
 211                 (lambda ()
 212                   (debug-disable 'debug 'procnames)
 213                   (read-disable 'positions)
 214                   (load-from-path "ice-9/psyntax.pp"))
 215                 (lambda ()
 216                   (debug-options old-debug)
 217                   (read-options old-read))))
 218
 219
 220 ;;; The following lines are necessary only if we start making changes
 221 ;; (use-syntax sc-expand)
 222 ;; (load-from-path "ice-9/psyntax.ss")
 223
 224 (define internal-eval (nested-ref the-scm-module '(app modules guile eval)))
 225
 226 (define (eval x environment)
 227   (internal-eval (if (and (pair? x)
 228                           (equal? (car x) "noexpand"))
 229                      (cadr x)
 230                      (sc-expand x))
 231                  environment))
 232
 233 ;;; Hack to make syncase macros work in the slib module
 234 (let ((m (nested-ref the-root-module '(app modules ice-9 slib))))
 235   (if m
 236       (set-object-property! (module-local-variable m 'define)
 237                             '*sc-expander*
 238                             '(define))))
 239
 240 (define syncase sc-expand)
 241
 242 (set-module-transformer! the-syncase-module syncase)
 243
 244 (define-syntax define-syntax-public
 245   (syntax-rules ()
 246     ((_ name rules ...)
 247      (begin
 248        ;(eval-case ((load-toplevel) (export-syntax name)))
 249        (define-syntax name rules ...)))))