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