ice-9/syncase.scm

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