lib/syntax-case-prelude.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "syntax-case.scm", Time-stamp: <2008-12-15 11:35:18 feeley>
   4
   5 ;;; Copyright (c) 1998-2008 by Marc Feeley, All Rights Reserved.
   6
   7 ;;; This is version 3.2 .
   8
   9 ;; This version includes a patch which avoids quoting self-evaluating
  10 ;; constants.  This makes it possible to use some Gambit specific forms
  11 ;; such as declare, namespace and define-macro.
  12
  13 ;; This is an implementation of "syntax-case" for the Gambit-C 4.0
  14 ;; system based on the portable implementation "psyntax.ss".  At the
  15 ;; top of the file "psyntax.ss" can be found this information:
  16 ;;
  17 ;;      Portable implementation of syntax-case
  18 ;;      Extracted from Chez Scheme Version 7.3 (Feb 26, 2007)
  19 ;;      Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
  20
  21 ;; This file can be used to replace the builtin macro expander of the
  22 ;; interpreter and compiler.  Source code correlation information
  23 ;; (filename and position in file) is preserved by the expander.  The
  24 ;; expander mangles non-global variable names and this complicates
  25 ;; debugging somewhat.  Note that Gambit's normal parser processes the
  26 ;; input after expansion by the syntax-case expander.  Since the
  27 ;; syntax-case expander does not know about Gambit's syntactic
  28 ;; extensions (like DSSSL parameters) some of the syntactic
  29 ;; extensions cannot be used.  On the other hand, the syntax-case
  30 ;; expander defines some new special forms, such as "module",
  31 ;; "alias", and "eval-when".
  32
  33 ;; You can simply load this file at the REPL with:
  34 ;;
  35 ;;   (load "syntax-case")
  36 ;;
  37 ;; For faster macro processing it is worthwhile to compile the file
  38 ;; with the compiler.  You can also rename this file to "gambcext.scm"
  39 ;; and put it in the Gambit "lib" installation directory so that it is
  40 ;; loaded every time the interpreter and compiler are started.
  41 ;;
  42 ;; Alternatively, the expander can be loaded from the command line
  43 ;; like this:
  44 ;;
  45 ;;   % gsi ~~lib/syntax-case -
  46 ;;   > (pp (lambda (x y) (if (< x y) (let ((z (* x x))) z))))
  47 ;;   (lambda (%%x0 %%y1)
  48 ;;     (if (< %%x0 %%y1) ((lambda (%%z2) %%z2) (* %%x0 %%x0)) (void)))
  49
  50 ;;;============================================================================
  51
  52 (##declare
  53  (standard-bindings)
  54  (extended-bindings)
  55  (inlining-limit 100)
  56  (block)
  57 )
  58
  59 (##namespace ("sc#"))
  60
  61 (##include "~~lib/gambit#.scm")
  62
  63 (##namespace (""
  64
  65 $make-environment
  66 $sc-put-cte
  67 $syntax-dispatch
  68 bound-identifier=?
  69 datum->syntax-object
  70 environment?
  71 free-identifier=?
  72 generate-temporaries
  73 identifier?
  74 interaction-environment
  75 literal-identifier=?
  76 sc-expand
  77 syntax-error
  78 syntax-object->datum
  79 syntax->list
  80 syntax->vector
  81
  82 ))
  83
  84 (##namespace ("sc#"
  85
  86 interaction-environment
  87 eval
  88 gensym
  89
  90 ))
  91
  92 ;;;============================================================================
  93
  94 ;; The following procedures are needed by the syntax-case system.
  95
  96 (define andmap
  97   (lambda (f first . rest)
  98     (or (null? first)
  99         (if (null? rest)
 100             (let andmap ((first first))
 101               (let ((x (car first)) (first (cdr first)))
 102                 (if (null? first)
 103                     (f x)
 104                     (and (f x) (andmap first)))))
 105             (let andmap ((first first) (rest rest))
 106               (let ((x (car first))
 107                     (xr (map car rest))
 108                     (first (cdr first))
 109                     (rest (map cdr rest)))
 110                 (if (null? first)
 111                     (apply f (cons x xr))
 112                     (and (apply f (cons x xr)) (andmap first rest)))))))))
 113
 114 (define ormap
 115   (lambda (proc list1)
 116     (and (not (null? list1))
 117          (or (proc (car list1)) (ormap proc (cdr list1))))))
 118
 119 (define eval
 120   (lambda (expr)
 121     (cond ((and (##pair? expr)
 122                 (##equal? (##car expr) "noexpand")
 123                 (##pair? (##cdr expr))
 124                 (##null? (##cddr expr)))
 125            (##eval (##cadr expr)))
 126           ((and (##source? expr)
 127                 (##pair? (##source-code expr))
 128                 (##source? (##car (##source-code expr)))
 129                 (##equal? (##source-code (##car (##source-code expr))) "noexpand")
 130                 (##pair? (##cdr (##source-code expr)))
 131                 (##null? (##cddr (##source-code expr))))
 132            (##eval (##cadr (##source-code expr))))
 133           (else
 134            (##raise-error-exception
 135             "eval expects an expression of the form (\"noexpand\" <expr>)"
 136             (##list expr))))))
 137
 138 (define gensym-count 0)
 139
 140 (define gensym
 141   (lambda id
 142     (let ((n gensym-count))
 143       (set! gensym-count (+ n 1))
 144       (string->symbol
 145        (string-append "%%"
 146                       (if (null? id) "" (symbol->string (car id)))
 147                       (number->string n))))))
 148
 149 (define gensym?
 150   (lambda (obj)
 151     (and (symbol? obj)
 152          (let ((str (symbol->string obj)))
 153            (and (> (string-length str) 2)
 154                 (string=? (substring str 0 2) "%%"))))))
 155
 156 (define prop-table (##make-table))
 157
 158 (define remprop
 159   (lambda (sym key)
 160     (let ((sym-key (cons sym key)))
 161       (##table-set! prop-table sym-key))))
 162
 163 (define putprop
 164   (lambda (sym key val)
 165     (let ((sym-key (cons sym key)))
 166       (##table-set! prop-table sym-key val))))
 167
 168 (define getprop
 169   (lambda (sym key)
 170     (let ((sym-key (cons sym key)))
 171       (##table-ref prop-table sym-key #f))))
 172
 173 (define list*
 174   (lambda (arg1 . other-args)
 175
 176     (define (fix lst)
 177       (if (null? (cdr lst))
 178           (car lst)
 179           (cons (car lst) (fix (cdr lst)))))
 180
 181     (fix (cons arg1 other-args))))
 182
 183 (define remq
 184   (lambda (obj lst)
 185     (cond ((null? lst)
 186            '())
 187           ((eq? (car lst) obj)
 188            (remq obj (cdr lst)))
 189           (else
 190            (cons (car lst) (remq obj (cdr lst)))))))
 191
 192 ;;;----------------------------------------------------------------------------
 193
 194 ;; These initial definitions are needed because these variables are
 195 ;; mutated with a "set!" without a prior definition.
 196
 197 (define $sc-put-cte #f)
 198 (define sc-expand (lambda (src) src)) ; temporary definition
 199 (define $make-environment #f)
 200 (define environment? #f)
 201 (define interaction-environment #f)
 202 (define identifier? #f)
 203 (define syntax->list #f)
 204 (define syntax->vector #f)
 205 (define syntax-object->datum #f)
 206 (define datum->syntax-object #f)
 207 (define generate-temporaries #f)
 208 (define free-identifier=? #f)
 209 (define bound-identifier=? #f)
 210 (define literal-identifier=? #f)
 211 (define syntax-error #f)
 212 (define $syntax-dispatch #f)
 213
 214 ;;;----------------------------------------------------------------------------
 215
 216 ;;; Interface to Gambit's source code annotations.
 217
 218 (define annotation?
 219   (lambda (x)
 220 ;;    (pp `(annotation? ,x))
 221     (##source? x)))
 222
 223 (define annotation-expression
 224   (lambda (x)
 225 ;;    (pp `(annotation-expression ,x))
 226     (##source-code x)))
 227
 228 (define annotation-stripped
 229   (lambda (x)
 230 ;;    (pp `(annotation-stripped ,x))
 231     (##desourcify x)))
 232
 233 (define build-source
 234   (lambda (ae x)
 235 ;;    (pp `(build-source ,ae ,x))
 236     (if (##source? ae)
 237         (##make-source x (##source-locat ae))
 238         (##make-source x #f))))
 239
 240 (define build-params
 241   (lambda (ae vars)
 242
 243     (define fix
 244       (lambda (vars)
 245         (cond ((null? vars)
 246                '())
 247               ((pair? vars)
 248                (cons (build-source ae (car vars))
 249                      (fix (cdr vars))))
 250               (else
 251                (build-source ae vars)))))
 252
 253     (if (or (null? vars) (pair? vars))
 254         (build-source ae (fix vars))
 255         (fix vars))))
 256
 257 (define attach-source
 258   (lambda (ae datum)
 259 ;;    (pp `(attach-source ,ae ,datum))
 260     (let ((src
 261            (if (##source? ae)
 262                ae
 263                (##make-source ae #f))))
 264
 265       (define (datum->source x)
 266         (##make-source (cond ((pair? x)
 267                               (list-convert x))
 268                              ((box? x)
 269                               (box (datum->source (unbox x))))
 270                              ((vector? x)
 271                               (vector-convert x))
 272                              (else
 273                               x))
 274                        (##source-locat src)))
 275
 276       (define (list-convert lst)
 277         (cons (datum->source (car lst))
 278               (list-tail-convert (cdr lst))))
 279
 280       (define (list-tail-convert lst)
 281         (cond ((pair? lst)
 282                (if (quoting-form? lst)
 283                    (datum->source lst)
 284                    (cons (datum->source (car lst))
 285                          (list-tail-convert (cdr lst)))))
 286               ((null? lst)
 287                '())
 288               (else
 289                (datum->source lst))))
 290
 291       (define (quoting-form? x)
 292         (let ((first (car x))
 293               (rest (cdr x)))
 294           (and (pair? rest)
 295                (null? (cdr rest))
 296                (or (eq? first 'quote)
 297                    (eq? first 'quasiquote)
 298                    (eq? first 'unquote)
 299                    (eq? first 'unquote-splicing)))))
 300
 301       (define (vector-convert vect)
 302         (let* ((len (vector-length vect))
 303                (v (make-vector len)))
 304           (let loop ((i (- len 1)))
 305             (if (>= i 0)
 306               (begin
 307                 (vector-set! v i (datum->source (vector-ref vect i)))
 308                 (loop (- i 1)))))
 309           v))
 310
 311       (datum->source datum))))
 312
 313 ;;;----------------------------------------------------------------------------
 314
 315 (define self-eval?
 316   (lambda (x)
 317     (or (number? x)
 318         (string? x)
 319         (char? x)
 320         (keyword? x)
 321         (memq x
 322               '(#f
 323                 #t
 324                 #!eof
 325                 #!void
 326                 #!unbound
 327                 #!unbound2
 328                 #!optional
 329                 #!rest
 330                 #!key)))))
 331
 332 ;;;============================================================================