cgen/pmacros.scm

   1 ; Preprocessor-like macro support.
   2 ; Copyright (C) 2000, 2009 Red Hat, Inc.
   3 ; This file is part of CGEN.
   4 ; See file COPYING.CGEN for details.
   5
   6 ; TODO:
   7 ; - Like C preprocessor macros, there is no scoping [one can argue
   8 ;   there should be].  Maybe in time (??? Hmmm... done?)
   9 ; - Support for multiple macro tables.
  10
  11 ; Non-standard required routines:
  12 ; Provided by Guile:
  13 ;   make-hash-table, hashq-ref, hashq-set!, symbol-append,
  14 ;   source-properties
  15 ; Provided by CGEN:
  16 ;   location-property, location-property-set!,
  17 ;   source-properties-location->string,
  18 ;   single-location->string, location-top, unspecified-location,
  19 ;   reader-process-expanded!, num-args-ok?, *UNSPECIFIED*.
  20
  21 ; The convention we use says `-' begins "local" objects.
  22 ; At some point this might also use the Guile module system.
  23
  24 ; This uses Guile's source-properties system to track source location.
  25 ; The chain of macro invocations is tracked and stored in the result as
  26 ; object property "location-property".
  27
  28 ; Exported routines:
  29 ;
  30 ; pmacro-init! - initialize the pmacro system
  31 ;
  32 ; define-pmacro - define a symbolic or procedural pmacro
  33 ;
  34 ;       (define-pmacro symbol ["comment"] expansion)
  35 ;       (define-pmacro (symbol [args]) ["comment"] (expansion))
  36 ;
  37 ; ARGS is a list of `symbol' or `(symbol default-value)' elements.
  38 ;
  39 ; pmacro-expand - expand all pmacros in an expression
  40 ;
  41 ;       (pmacro-expand expression loc)
  42 ;
  43 ; pmacro-trace - same as pmacro-expand, but trace macro expansion
  44 ;                Output is sent to current-error-port.
  45 ;
  46 ;       (pmacro-trace expression loc)
  47 ;
  48 ; pmacro-dump - expand all pmacros in an expression, for debugging purposes
  49 ;
  50 ;       (pmacro-dump expression)
  51
  52 ; pmacro-debug - expand all pmacros in an expression,
  53 ;                printing various debugging messages.
  54 ;                This does not process $exec.
  55 ;
  56 ;       (pmacro-debug expression)
  57
  58 ; Builtin pmacros:
  59 ;
  60 ; ($sym symbol1 symbol2 ...)          - symbolstr-append
  61 ; ($str string1 string2 ...)          - stringsym-append
  62 ; ($hex number [width])               - convert to hex string
  63 ; ($upcase string)
  64 ; ($downcase string)
  65 ; ($substring string start end)       - get part of a string
  66 ; ($splice a b ($unsplice c) d e ...) - splice list into another list
  67 ; ($iota count [start [increment]])   - number generator
  68 ; ($map pmacro arg1 . arg-rest)
  69 ; ($for-each pmacro arg1 . arg-rest)
  70 ; ($eval expr)                        - expand (or evaluate it) expr
  71 ; ($exec expr)                        - execute expr immediately
  72 ; ($apply pmacro-name arg)
  73 ; ($pmacro (arg-list) expansion)      - akin go lambda in Scheme
  74 ; ($pmacro? arg)
  75 ; ($let (var-list) expr1 . expr-rest) - akin to let in Scheme
  76 ; ($let* (var-list) expr1 . expr-rest) - akin to let* in Scheme
  77 ; ($if expr then [else])
  78 ; ($case expr ((case-list1) stmt) [case-expr-stmt-list] [(else stmt)])
  79 ; ($cond (expr stmt) [(cond-expr-stmt-list)] [(else stmt)])
  80 ; ($begin . stmt-list)
  81 ; ($print . exprs)                    - for debugging messages
  82 ; ($dump expr)                        - dump expr in readable format
  83 ; ($error . message)                  - print error message and exit
  84 ; ($list . exprs)
  85 ; ($ref l n)                          - extract the n'th element of list l
  86 ; ($length x)                         - length of symbol, string, or list
  87 ; ($replicate n expr)                 - return list of expr replicated n times
  88 ; ($find pred l)                      - return elements of list l matching pred
  89 ; ($equal? x y)                       - deep comparison
  90 ; ($andif expr . rest)                - && in C
  91 ; ($orif expr . rest)                 - || in C
  92 ; ($not expr)                         - ! in C
  93 ; ($eq x y)
  94 ; ($ne x y)
  95 ; ($lt x y)
  96 ; ($gt x y)
  97 ; ($le x y)
  98 ; ($ge x y)
  99 ; ($add x y)
 100 ; ($sub x y)
 101 ; ($mul x y)
 102 ; ($div x y)                          - integer division
 103 ; ($rem x y)                          - integer remainder
 104 ; ($sll x n)                          - shift left logical
 105 ; ($srl x n)                          - shift right logical
 106 ; ($sra x n)                          - shift right arithmetic
 107 ; ($and x y)                          - bitwise and
 108 ; ($or x y)                           - bitwise or
 109 ; ($xor x y)                          - bitwise xor
 110 ; ($inv x)                            - bitwise invert
 111 ; ($car l)
 112 ; ($cdr l)
 113 ; ($caar l)
 114 ; ($cadr l)
 115 ; ($cdar l)
 116 ; ($cddr l)
 117 ; ($internal-test expr)               - testsuite internal use only
 118 ;
 119 ; NOTE: $cons currently absent on purpose
 120 ;
 121 ; $sym and $str convert numbers to symbols/strings as necessary (base 10).
 122 ;
 123 ; $pmacro is for constructing pmacros on-the-fly, like lambda, and is currently
 124 ; only valid as arguments to other pmacros or assigned to a local in a {$let}
 125 ; or {$let*}.
 126 ;
 127 ; NOTE: While Scheme requires tail recursion to be implemented as a loop,
 128 ; we do not.  We might some day, but not today.
 129 ;
 130 ; ??? Methinks .foo isn't a valid R5RS symbol.  May need to change
 131 ; to something else.
 132
 133 ; True if doing pmacro expansion via pmacro-debug.
 134 (define /pmacro-debug? #f)
 135 ; True if doing pmacro expansion via pmacro-trace.
 136 (define /pmacro-trace? #f)
 137
 138 ; The pmacro table.
 139 (define /pmacro-table #f)
 140 (define (/pmacro-lookup name) (hashq-ref /pmacro-table name #f))
 141 (define (/pmacro-set! name val) (hashq-set! /pmacro-table name val))
 142
 143 ; A copy of syntactic pmacros is kept separately.
 144 (define /smacro-table #f)
 145 (define (/smacro-lookup name) (hashq-ref /smacro-table name #f))
 146 (define (/smacro-set! name val) (hashq-set! /smacro-table name val))
 147
 148 ; Marker to indicate a value is a pmacro.
 149 ; NOTE: Naming this "<pmacro>" is intentional.  It makes them look like
 150 ; objects of class <pmacro>.  However we don't use COS in part to avoid
 151 ; a dependency on COS and in part because displaying COS objects isn't well
 152 ; supported (displaying them in debugging dumps adds a lot of noise).
 153 (define /pmacro-marker '<pmacro>)
 154
 155 ; Utilities to create and access pmacros.
 156 (define (/pmacro-make name arg-spec default-values
 157                       syntactic-form? transformer comment)
 158   (vector /pmacro-marker name arg-spec default-values
 159           syntactic-form? transformer comment)
 160 )
 161 (define (/pmacro? x) (and (vector? x) (eq? (vector-ref x 0) /pmacro-marker)))
 162 (define (/pmacro-name pmac) (vector-ref pmac 1))
 163 (define (/pmacro-arg-spec pmac) (vector-ref pmac 2))
 164 (define (/pmacro-default-values pmac) (vector-ref pmac 3))
 165 (define (/pmacro-syntactic-form? pmac) (vector-ref pmac 4))
 166 (define (/pmacro-transformer pmac) (vector-ref pmac 5))
 167 (define (/pmacro-comment pmac) (vector-ref pmac 6))
 168
 169 ;; Create a new environment, prepending NAMES to PREV-ENV.
 170
 171 (define (/pmacro-env-make loc prev-env names values)
 172   (if (= (length names) (length values))
 173       (append! (map cons names values) prev-env)
 174       (/pmacro-loc-error loc
 175                          (string-append "invalid number of parameters, expected "
 176                                         (number->string (length names)))
 177                          values))
 178 )
 179
 180 ;; Look up NAME in ENV.
 181
 182 (define (/pmacro-env-ref env name) (assq name env))
 183
 184 ; Error message generator.
 185
 186 (define (/pmacro-error msg expr)
 187   (error (string-append
 188           (or (port-filename (current-input-port)) "<input>")
 189           ":"
 190           (number->string (port-line (current-input-port)))
 191           ":"
 192           msg
 193           ":")
 194          expr)
 195 )
 196
 197 ; Error message generator when we have a location.
 198
 199 (define (/pmacro-loc-error loc errmsg expr)
 200   (let* ((top-sloc (location-top loc))
 201          (intro "During pmacro expansion")
 202          (text (string-append "Error: " errmsg)))
 203     (error (simple-format
 204             #f
 205             "\n~A:\n@ ~A:\n\n~A: ~A:"
 206             intro
 207             (location->string loc)
 208             (single-location->simple-string top-sloc)
 209             text)
 210            expr))
 211 )
 212
 213 ; Issue an error where a number was expected.
 214
 215 (define (/pmacro-expected-number op n)
 216   (/pmacro-error (string-append "invalid arg for " op ", expected number") n)
 217 )
 218
 219 ; Verify N is a number.
 220
 221 (define (/pmacro-verify-number op n)
 222   (if (not (number? n))
 223       (/pmacro-expected-number op n))
 224 )
 225
 226 ; Issue an error where an integer was expected.
 227
 228 (define (/pmacro-expected-integer op n)
 229   (/pmacro-error (string-append "invalid arg for " op ", expected integer") n)
 230 )
 231
 232 ; Verify N is an integer.
 233
 234 (define (/pmacro-verify-integer op n)
 235   (if (not (integer? n))
 236       (/pmacro-expected-integer op n))
 237 )
 238
 239 ; Issue an error where a non-negative integer was expected.
 240
 241 (define (/pmacro-expected-non-negative-integer op n)
 242   (/pmacro-error (string-append "invalid arg for " op ", expected non-negative integer") n)
 243 )
 244
 245 ; Verify N is a non-negative integer.
 246
 247 (define (/pmacro-verify-non-negative-integer op n)
 248   (if (or (not (integer? n))
 249           (< n 0))
 250       (/pmacro-expected-non-negative-integer op n))
 251 )
 252
 253 ; Expand a list of expressions, in order.
 254 ; The result is the value of the last one.
 255
 256 (define (/pmacro-expand-expr-list exprs env loc)
 257   (let ((result nil))
 258     (for-each (lambda (expr)
 259                 (set! result (/pmacro-expand expr env loc)))
 260               exprs)
 261     result)
 262 )
 263
 264 ; Process list of keyword/value specified arguments.
 265
 266 (define (/pmacro-process-keyworded-args arg-spec default-values args)
 267   ; Build a list of default values, then override ones specified in ARGS,
 268   (let ((result-alist (alist-copy default-values)))
 269     (let loop ((args args))
 270       (cond ((null? args)
 271              #f) ; done
 272             ((and (pair? args) (keyword? (car args)))
 273              (let ((elm (assq (car args) result-alist)))
 274                (if (not elm)
 275                    (/pmacro-error "not an argument name" (car args)))
 276                (if (null? (cdr args))
 277                    (/pmacro-error "missing argument to #:keyword" (car args)))
 278                (set-cdr! elm (cadr args))
 279                (loop (cddr args))))
 280             (else
 281              (/pmacro-error "bad keyword/value argument list" args))))
 282
 283     ; Ensure each element has a value.
 284     (let loop ((to-scan result-alist))
 285       (if (null? to-scan)
 286           #f ; done
 287           (begin
 288             (if (not (cdar to-scan))
 289                 (/pmacro-error "argument value not specified" (caar to-scan)))
 290             (loop (cdr to-scan)))))
 291
 292     ; If varargs pmacro, adjust result.
 293     (if (list? arg-spec)
 294         (map cdr result-alist) ; not varargs
 295         (let ((nr-args (length (result-alist))))
 296           (append! (map cdr (list-head result-alist (- nr-args 1)))
 297                    (cdr (list-tail result-alist (- nr-args 1)))))))
 298 )
 299
 300 ; Process a pmacro argument list.
 301 ; ARGS is either a fully specified position dependent argument list,
 302 ; or is a list of keyword/value pairs with missing values coming from
 303 ; DEFAULT-VALUES.
 304
 305 (define (/pmacro-process-args-1 arg-spec default-values args)
 306   (if (and (pair? args) (keyword? (car args)))
 307       (/pmacro-process-keyworded-args arg-spec default-values args)
 308       args)
 309 )
 310
 311 ; Subroutine of /pmacro-apply,/smacro-apply to simplify them.
 312 ; Process the arguments, verify the correct number is present.
 313
 314 (define (/pmacro-process-args macro args)
 315   (let ((arg-spec (/pmacro-arg-spec macro))
 316         (default-values (/pmacro-default-values macro)))
 317     (let ((processed-args (/pmacro-process-args-1 arg-spec default-values args)))
 318       (if (not (num-args-ok? (length processed-args) arg-spec))
 319           (/pmacro-error (string-append
 320                           "wrong number of arguments to pmacro "
 321                           (with-output-to-string
 322                             (lambda ()
 323                               (write (cons (/pmacro-name macro)
 324                                            (/pmacro-arg-spec macro))))))
 325                          args))
 326       processed-args))
 327 )
 328
 329 ; Invoke a pmacro.
 330
 331 (define (/pmacro-apply macro args)
 332   (apply (/pmacro-transformer macro)
 333          (/pmacro-process-args macro args))
 334 )
 335
 336 ; Invoke a syntactic-form pmacro.
 337 ; ENV, LOC are handed down from /pmacro-expand.
 338
 339 (define (/smacro-apply macro args env loc)
 340   (apply (/pmacro-transformer macro)
 341          (cons loc (cons env (/pmacro-process-args macro args))))
 342 )
 343
 344 ;; Expand expression EXP using ENV, an alist of variable assignments.
 345 ;; LOC is the location stack thus far.
 346
 347 (define (/pmacro-expand exp env loc)
 348
 349   (define cep (current-error-port))
 350
 351   ;; If the symbol is in `env', return its value.
 352   ;; Otherwise see if symbol is a globally defined pmacro.
 353   ;; Otherwise return the symbol unchanged.
 354
 355   (define (scan-symbol sym)
 356     (let ((val (/pmacro-env-ref env sym)))
 357       (if val
 358           (cdr val) ;; cdr is value of (name . value) pair
 359           (let ((val (/pmacro-lookup sym)))
 360             (if val
 361                 ;; Symbol is a pmacro.
 362                 ;; If this is a procedural pmacro, let caller perform expansion.
 363                 ;; Otherwise, return the pmacro's value.
 364                 (if (procedure? (/pmacro-transformer val))
 365                     val
 366                     (/pmacro-transformer val))
 367                 ;; Return symbol unchanged.
 368                 sym)))))
 369
 370   ;; See if (car exp) is a pmacro.
 371   ;; Return pmacro or #f.
 372
 373   (define (check-pmacro exp)
 374     (if /pmacro-debug?
 375         (begin
 376           (display "Checking for pmacro: " cep)
 377           (write exp cep)
 378           (newline cep)))
 379     (and (/pmacro? (car exp)) (car exp)))
 380
 381   ;; Subroutine of scan-list to simplify it.
 382   ;; Macro expand EXP which is known to be a non-null list.
 383   ;; LOC is the location stack thus far.
 384
 385   (define (scan-list1 exp loc)
 386     ;; Check for syntactic forms.
 387     ;; They are handled differently in that we leave it to the transformer
 388     ;; routine to evaluate the arguments.
 389     ;; Note that we also don't support passing syntactic form functions
 390     ;; as arguments: We look up (car exp) here, not its expansion.
 391     (let ((sform (/smacro-lookup (car exp))))
 392       (if sform
 393           (begin
 394             ;; ??? Is it useful to trace these?
 395             (/smacro-apply sform (cdr exp) env loc))
 396           ;; Not a syntactic form.
 397           ;; See if we have a pmacro.  Do this before evaluating all the
 398           ;; arguments (even though we will eventually evaluate all the
 399           ;; arguments before invoking the pmacro) so that tracing is more
 400           ;; legible (we print the expression we're about to evaluate *before*
 401           ;; we evaluate its arguments).
 402           (let ((scanned-car (scan (car exp) loc)))
 403             (if (/pmacro? scanned-car)
 404                 (begin
 405                   ;; Trace expansion here, we know we have a pmacro.
 406                   (if /pmacro-trace?
 407                       (let ((src-props (source-properties exp))
 408                             (indent (spaces (* 2 (length (location-list loc))))))
 409                         ;; We use `write' to display `exp' to see strings quoted.
 410                         (display indent cep)
 411                         (display "Expanding: " cep)
 412                         (write exp cep)
 413                         (newline cep)
 414                         (display indent cep)
 415                         (display "      env: " cep)
 416                         (write env cep)
 417                         (newline cep)
 418                         (if (not (null? src-props))
 419                             (begin
 420                               (display indent cep)
 421                               (display " location: " cep)
 422                               (display (source-properties-location->string src-props) cep)
 423                               (newline cep)))))
 424                   ;; Evaluate all the arguments before invoking the pmacro.
 425                   (let* ((scanned-args (map (lambda (e) (scan e loc))
 426                                             (cdr exp)))
 427                          (result (if (procedure? (/pmacro-transformer scanned-car))
 428                                      (/pmacro-apply scanned-car scanned-args)
 429                                      (cons (/pmacro-transformer scanned-car) scanned-args))))
 430                     (if /pmacro-trace?
 431                         (let ((indent (spaces (* 2 (length (location-list loc))))))
 432                           (display indent cep)
 433                           (display "   result: " cep)
 434                           (write result cep)
 435                           (newline cep)))
 436                     result))
 437                 ;; Not a pmacro.
 438                 (cons scanned-car (map (lambda (e) (scan e loc))
 439                                        (cdr exp))))))))
 440
 441   ;; Macro expand EXP which is known to be a non-null list.
 442   ;; LOC is the location stack thus far.
 443   ;;
 444   ;; This uses scan-list1 to do the real work, this handles location tracking.
 445
 446   (define (scan-list exp loc)
 447     (let ((src-props (source-properties exp))
 448           (new-loc loc))
 449       (if (not (null? src-props))
 450           (let ((file (assq-ref src-props 'filename))
 451                 (line (assq-ref src-props 'line))
 452                 (column (assq-ref src-props 'column)))
 453             (set! new-loc (location-push-single loc file line column #f))))
 454       (let ((result (scan-list1 exp new-loc)))
 455         (if (pair? result) ;; pair? -> cheap non-null-list?
 456             (begin
 457               ;; Copy source location to new expression.
 458               (if (null? (source-properties result))
 459                   (set-source-properties! result src-props))
 460               (let ((loc-prop (location-property result)))
 461                 (if loc-prop
 462                     (location-property-set! result (location-push new-loc loc-prop))
 463                     (location-property-set! result new-loc)))))
 464         result)))
 465
 466   ;; Scan EXP, an arbitrary value.
 467   ;; LOC is the location stack thus far.
 468
 469   (define (scan exp loc)
 470     (let ((result (cond ((symbol? exp)
 471                          (scan-symbol exp))
 472                         ((pair? exp) ;; pair? -> cheap non-null-list?
 473                          (scan-list exp loc))
 474                         ;; Not a symbol or expression, return unchanged.
 475                         (else
 476                          exp))))
 477       ;; Re-examining `result' to see if it is another pmacro invocation
 478       ;; allows doing things like (($sym a b c) arg1 arg2)
 479       ;; where `abc' is a pmacro.  Scheme doesn't work this way, but then
 480       ;; this is CGEN.
 481       (if (symbol? result) (scan-symbol result) result)))
 482
 483   (scan exp loc)
 484 )
 485
 486 ; Return the argument spec from ARGS.
 487 ; ARGS is a [possibly improper] list of `symbol' or `(symbol default-value)'
 488 ; elements.  For varargs pmacros, ARGS must be an improper list
 489 ; (e.g. (a b . c)) with the last element being a symbol.
 490
 491 (define (/pmacro-get-arg-spec args)
 492   (let ((parse-arg
 493          (lambda (arg)
 494            (cond ((symbol? arg)
 495                   arg)
 496                  ((and (pair? arg) (symbol? (car arg)))
 497                   (car arg))
 498                  (else
 499                   (/pmacro-error "argument not `symbol' or `(symbol . default-value)'"
 500                                  arg))))))
 501     (if (list? args)
 502         (map parse-arg args)
 503         (letrec ((parse-improper-list
 504                   (lambda (args)
 505                     (cond ((symbol? args)
 506                            args)
 507                           ((pair? args)
 508                            (cons (parse-arg (car args))
 509                                  (parse-improper-list (cdr args))))
 510                           (else
 511                            (/pmacro-error "argument not `symbol' or `(symbol . default-value)'"
 512                                           args))))))
 513           (parse-improper-list args))))
 514 )
 515
 516 ; Return the default values specified in ARGS.
 517 ; The result is an alist of (#:arg-name . default-value) elements.
 518 ; ARGS is a [possibly improper] list of `symbol' or `(symbol . default-value)'
 519 ; elements.  For varargs pmacros, ARGS must be an improper list
 520 ; (e.g. (a b . c)) with the last element being a symbol.
 521 ; Unspecified default values are recorded as #f.
 522
 523 (define (/pmacro-get-default-values args)
 524   (let ((parse-arg
 525          (lambda (arg)
 526            (cond ((symbol? arg)
 527                   (cons (symbol->keyword arg) #f))
 528                  ((and (pair? arg) (symbol? (car arg)))
 529                   (cons (symbol->keyword (car arg)) (cdr arg)))
 530                  (else
 531                   (/pmacro-error "argument not `symbol' or `(symbol . default-value)'"
 532                                  arg))))))
 533     (if (list? args)
 534         (map parse-arg args)
 535         (letrec ((parse-improper-list
 536                   (lambda (args)
 537                     (cond ((symbol? args)
 538                            (cons (parse-arg args) nil))
 539                           ((pair? args)
 540                            (cons (parse-arg (car args))
 541                                  (parse-improper-list (cdr args))))
 542                           (else
 543                            (/pmacro-error "argument not `symbol' or `(symbol . default-value)'"
 544                                           args))))))
 545           (parse-improper-list args))))
 546 )
 547
 548 ; Build a procedure that performs a pmacro expansion.
 549
 550 ; Earlier version, doesn't work with LOC as a <location> object,
 551 ; COS objects don't pass through eval1.
 552 ;(define (/pmacro-build-lambda prev-env params expansion)
 553 ;  (eval1 `(lambda ,params
 554 ;           (/pmacro-expand ',expansion
 555 ;                           (/pmacro-env-make ',prev-env
 556 ;                                             ',params (list ,@params))))
 557 ;)
 558
 559 (define (/pmacro-build-lambda loc prev-env params expansion)
 560   (lambda args
 561     (/pmacro-expand expansion
 562                     (/pmacro-env-make loc prev-env params args)
 563                     loc))
 564 )
 565
 566 ; While using `define-macro' seems preferable, boot-9.scm uses it and
 567 ; I'd rather not risk a collision.  I could of course make the association
 568 ; during parsing, maybe later.
 569 ; On the other hand, calling them pmacros removes all ambiguity.
 570 ; In the end the ambiguity removal is the deciding win.
 571 ;
 572 ; The syntax is one of:
 573 ; (define-pmacro symbol expansion)
 574 ; (define-pmacro symbol ["comment"] expansion)
 575 ; (define-pmacro (name args ...) expansion)
 576 ; (define-pmacro (name args ...) "documentation" expansion)
 577 ;
 578 ; If `expansion' is the name of a pmacro, its value is used (rather than its
 579 ; name).
 580 ; ??? The goal here is to follow Scheme's define/lambda, but not all variants
 581 ; are supported yet.  There's also the difference that we treat undefined
 582 ; symbols as being themselves (i.e. "self quoting" so-to-speak).
 583 ;
 584 ; ??? We may want user-definable "syntactic" pmacros some day.  Later.
 585
 586 (define (define-pmacro header arg1 . arg-rest)
 587   (if (and (not (symbol? header))
 588            (not (list? header)))
 589       (/pmacro-error "invalid pmacro header" header))
 590   (let ((name (if (symbol? header) header (car header)))
 591         (arg-spec (if (symbol? header) #f (/pmacro-get-arg-spec (cdr header))))
 592         (default-values (if (symbol? header) #f (/pmacro-get-default-values (cdr header))))
 593         (comment (if (null? arg-rest) "" arg1))
 594         (expansion (if (null? arg-rest) arg1 (car arg-rest))))
 595     ;;(if (> (length arg-rest) 1)
 596         ;;(/pmacro-error "extraneous arguments to define-pmacro" (cdr arg-rest)))
 597     ;;(if (not (string? comment))
 598         ;;(/pmacro-error "invalid pmacro comment, expected string" comment))
 599     (if (symbol? header)
 600         (if (symbol? expansion)
 601             (let ((maybe-pmacro (/pmacro-lookup expansion)))
 602               (if maybe-pmacro
 603                   (/pmacro-set! name
 604                                 (/pmacro-make name
 605                                               (/pmacro-arg-spec maybe-pmacro)
 606                                               (/pmacro-default-values maybe-pmacro)
 607                                               #f ; syntactic-form?
 608                                               (/pmacro-transformer maybe-pmacro)
 609                                               comment))
 610                   (/pmacro-set! name (/pmacro-make name #f #f #f expansion comment))))
 611             (/pmacro-set! name (/pmacro-make name #f #f #f expansion comment)))
 612         (/pmacro-set! name
 613                       (/pmacro-make name arg-spec default-values #f
 614                                     (/pmacro-build-lambda (current-reader-location)
 615                                                           nil
 616                                                           arg-spec
 617                                                           expansion)
 618                                     comment))))
 619     *UNSPECIFIED*
 620 )
 621
 622 ; Expand any pmacros in EXPR.
 623 ; LOC is the <location> of EXPR.
 624
 625 (define (pmacro-expand expr loc)
 626   (/pmacro-expand expr '() loc)
 627 )
 628
 629 ; Debugging routine to trace pmacro expansion.
 630
 631 (define (pmacro-trace expr loc)
 632   ; FIXME: Need unwind protection.
 633   (let ((old-trace /pmacro-trace?)
 634         (src-props (and (pair? expr) (source-properties expr)))
 635         (cep (current-error-port)))
 636     (set! /pmacro-trace? #t)
 637     ;; We use `write' to display `expr' to see strings quoted.
 638     (display "Pmacro expanding: " cep) (write expr cep) (newline cep)
 639     ;;(display "Top level env: " cep) (display nil cep) (newline cep)
 640     (display "Pmacro location: " cep)
 641     (if (and src-props (not (null? src-props)))
 642         (display (source-properties-location->string src-props) cep)
 643         (display (single-location->string (location-top loc)) cep))
 644     (newline cep)
 645     (let ((result (/pmacro-expand expr '() loc)))
 646       (display "Pmacro result: " cep) (write result cep) (newline cep)
 647       (set! /pmacro-trace? old-trace)
 648       result))
 649 )
 650
 651 ; Debugging utility to expand a pmacro, with no initial source location.
 652
 653 (define (pmacro-dump expr)
 654   (/pmacro-expand expr '() (unspecified-location))
 655 )
 656
 657 ; Expand any pmacros in EXPR, printing various debugging messages.
 658 ; This does not process $exec.
 659
 660 (define (pmacro-debug expr)
 661   ; FIXME: Need unwind protection.
 662   (let ((old-debug /pmacro-debug?))
 663     (set! /pmacro-debug? #t)
 664     (let ((result (pmacro-trace expr (unspecified-location))))
 665       (set! /pmacro-debug? old-debug)
 666       result))
 667 )
 668 \f
 669 ; Builtin pmacros.
 670
 671 ; ($sym symbol1 symbol2 ...) - symbol-append, auto-convert numbers
 672
 673 (define /pmacro-builtin-sym
 674   (lambda args
 675     (string->symbol
 676      (apply string-append
 677             (map (lambda (elm)
 678                    (cond ((number? elm) (number->string elm))
 679                          ((symbol? elm) (symbol->string elm))
 680                          ((string? elm) elm)
 681                          (else
 682                           (/pmacro-error "invalid argument to $sym" elm))))
 683                  args))))
 684 )
 685
 686 ; ($str string1 string2 ...) - string-append, auto-convert numbers
 687
 688 (define /pmacro-builtin-str
 689   (lambda args
 690     (apply string-append
 691            (map (lambda (elm)
 692                   (cond ((number? elm) (number->string elm))
 693                         ((symbol? elm) (symbol->string elm))
 694                         ((string? elm) elm)
 695                         (else
 696                          (/pmacro-error "invalid argument to $str" elm))))
 697                 args)))
 698 )
 699
 700 ; ($hex number [width]) - convert number to hex string
 701 ; WIDTH, if present, is the number of characters in the result, beginning
 702 ; from the least significant digit.
 703
 704 (define (/pmacro-builtin-hex num . width)
 705   (if (> (length width) 1)
 706       (/pmacro-error "wrong number of arguments to $hex"
 707                      (cons '$hex (cons num width))))
 708   (let ((str (number->string num 16)))
 709     (if (null? width)
 710         str
 711         (let ((len (string-length str)))
 712           (substring (string-append (make-string (car width) #\0) str)
 713                      len (+ len (car width))))))
 714 )
 715
 716 ; ($upcase string) - convert a string or symbol to uppercase
 717
 718 (define (/pmacro-builtin-upcase str)
 719   (cond
 720    ((string? str) (string-upcase str))
 721    ((symbol? str) (string->symbol (string-upcase (symbol->string str))))
 722    (else (/pmacro-error "invalid argument to $upcase" str)))
 723 )
 724
 725 ; ($downcase string) - convert a string or symbol to lowercase
 726
 727 (define (/pmacro-builtin-downcase str)
 728   (cond
 729    ((string? str) (string-downcase str))
 730    ((symbol? str) (string->symbol (string-downcase (symbol->string str))))
 731    (else (/pmacro-error "invalid argument to $downcase" str)))
 732 )
 733
 734 ; ($substring string start end) - get part of a string
 735 ; `end' can be the symbol `end'.
 736
 737 (define (/pmacro-builtin-substring str start end)
 738   (if (not (integer? start)) ;; FIXME: non-negative-integer
 739       (/pmacro-error "start not an integer" start))
 740   (if (and (not (integer? end))
 741            (not (eq? end 'end)))
 742       (/pmacro-error "end not an integer nor symbol `end'" end))
 743   (cond ((string? str)
 744          (if (eq? end 'end)
 745              (substring str start)
 746              (substring str start end)))
 747         ((symbol? str)
 748          (if (eq? end 'end)
 749              (string->symbol (substring (symbol->string str) start))
 750              (string->symbol (substring (symbol->string str) start end))))
 751         (else
 752          (/pmacro-error "invalid argument to $substring" str)))
 753 )
 754
 755 ; $splice - splicing support
 756 ; Splice lists into the outer list.
 757 ;
 758 ; E.g. (define-pmacro '(splice-test a b c) '($splice a ($unsplice b) c))
 759 ; (pmacro-expand '(splice-test (1 (2) 3))) --> (1 2 3)
 760 ;
 761 ; Similar to `(1 ,@'(2) 3) in Scheme, though the terminology is slightly
 762 ; different (??? may need to revisit).  In Scheme there's quasi-quote,
 763 ; unquote, unquote-splicing.  Here we have splice, unsplice; with the proviso
 764 ; that pmacros don't have the concept of "quoting", thus all subexpressions
 765 ; are macro-expanded first, before performing any unsplicing.
 766 ; [??? Some may want a quoting facility, but I'd like to defer adding it as
 767 ; long as possible (and ideally never add it).]
 768 ;
 769 ; NOTE: The implementation relies on $unsplice being undefined so that
 770 ; ($unsplice (42)) is expanded unchanged.
 771
 772 (define /pmacro-builtin-splice
 773   (lambda arg-list
 774     ; ??? Not the most efficient implementation.
 775     (let* ((unsplice-str (if (rtl-version-at-least? 0 9) "$unsplice" ".unsplice"))
 776            (unsplice-sym (string->symbol unsplice-str)))
 777       (let loop ((arg-list arg-list) (result '()))
 778         (cond ((null? arg-list) result)
 779               ((and (pair? (car arg-list)) (eq? unsplice-sym (caar arg-list)))
 780                (if (= (length (car arg-list)) 2)
 781                    (if (list? (cadar arg-list))
 782                        (loop (cdr arg-list) (append result (cadar arg-list)))
 783                        (/pmacro-error (string-append "argument to " unsplice-str " must be a list")
 784                                       (car arg-list)))
 785                    (/pmacro-error (string-append "wrong number of arguments to " unsplice-str)
 786                                   (car arg-list))))
 787               (else
 788                (loop (cdr arg-list) (append result (list (car arg-list)))))))))
 789 )
 790
 791 ; $iota
 792 ; Usage:
 793 ; ($iota count)            ; start=0, incr=1
 794 ; ($iota count start)      ; incr=1
 795 ; ($iota count start incr)
 796
 797 (define (/pmacro-builtin-iota count . start-incr)
 798   (if (> (length start-incr) 2)
 799       (/pmacro-error "wrong number of arguments to $iota"
 800                      (cons '$iota (cons count start-incr))))
 801   (if (< count 0)
 802       (/pmacro-error "count must be non-negative"
 803                      (cons '$iota (cons count start-incr))))
 804   (let ((start (if (pair? start-incr) (car start-incr) 0))
 805         (incr (if (= (length start-incr) 2) (cadr start-incr) 1)))
 806     (let loop ((i start) (count count) (result '()))
 807       (if (= count 0)
 808           (reverse! result)
 809           (loop (+ i incr) (- count 1) (cons i result)))))
 810 )
 811
 812 ; ($map pmacro arg1 . arg-rest)
 813
 814 (define (/pmacro-builtin-map pmacro arg1 . arg-rest)
 815   (if (not (/pmacro? pmacro))
 816       (/pmacro-error "not a pmacro" pmacro))
 817   (let ((transformer (/pmacro-transformer pmacro)))
 818     (if (not (procedure? transformer))
 819         (/pmacro-error "not a procedural pmacro" pmacro))
 820     (apply map (cons transformer (cons arg1 arg-rest))))
 821 )
 822
 823 ; ($for-each pmacro arg1 . arg-rest)
 824
 825 (define (/pmacro-builtin-for-each pmacro arg1 . arg-rest)
 826   (if (not (/pmacro? pmacro))
 827       (/pmacro-error "not a pmacro" pmacro))
 828   (let ((transformer (/pmacro-transformer pmacro)))
 829     (if (not (procedure? transformer))
 830         (/pmacro-error "not a procedural pmacro" pmacro))
 831     (apply for-each (cons transformer (cons arg1 arg-rest)))
 832     nil) ; need to return something the reader will accept and ignore
 833 )
 834
 835 ; ($eval expr)
 836 ; NOTE: This is implemented as a syntactic form in order to get ENV and LOC.
 837 ; That's an implementation detail, and this is not really a syntactic form.
 838 ;
 839 ; ??? I debated whether to call this $expand, $eval has been a source of
 840 ; confusion/headaches.
 841
 842 (define (/pmacro-builtin-eval loc env expr)
 843   ;; /pmacro-expand is invoked twice because we're implemented as a syntactic
 844   ;; form:  We *want* to be passed an evaluated expression, and then we
 845   ;; re-evaluate it.  But syntactic forms pass parameters unevaluated, so we
 846   ;; have to do the first one ourselves.
 847   (/pmacro-expand (/pmacro-expand expr env loc) env loc)
 848 )
 849
 850 ; ($exec expr)
 851
 852 (define (/pmacro-builtin-exec expr)
 853   ;; If we're expanding pmacros for debugging purposes, don't execute,
 854   ;; just return unchanged.
 855   (if /pmacro-debug?
 856       (list '$exec expr)
 857       (begin
 858         (reader-process-expanded! expr)
 859         nil)) ;; need to return something the reader will accept and ignore
 860 )
 861
 862 ; ($apply pmacro-name arg)
 863
 864 (define (/pmacro-builtin-apply pmacro arg-list)
 865   (if (not (/pmacro? pmacro))
 866       (/pmacro-error "not a pmacro" pmacro))
 867   (let ((transformer (/pmacro-transformer pmacro)))
 868     (if (not (procedure? transformer))
 869         (/pmacro-error "not a procedural pmacro" pmacro))
 870     (apply transformer arg-list))
 871 )
 872
 873 ; ($pmacro (arg-list) expansion)
 874 ; NOTE: syntactic form
 875
 876 (define (/pmacro-builtin-pmacro loc env params expansion)
 877   ;; ??? Prohibiting improper lists seems unnecessarily restrictive here.
 878   ;; e.g. (define (foo bar . baz) ...)
 879   (if (not (list? params))
 880       (/pmacro-error "$pmacro parameter-spec is not a list" params))
 881   (/pmacro-make '$anonymous params #f #f
 882                 (/pmacro-build-lambda loc env params expansion) "")
 883 )
 884
 885 ; ($pmacro? arg)
 886
 887 (define (/pmacro-builtin-pmacro? arg)
 888   (/pmacro? arg)
 889 )
 890
 891 ; ($let (var-list) expr1 . expr-rest)
 892 ; NOTE: syntactic form
 893
 894 (define (/pmacro-builtin-let loc env locals expr1 . expr-rest)
 895   (if (not (list? locals))
 896       (/pmacro-error "locals is not a list" locals))
 897   (if (not (all-true? (map (lambda (l)
 898                              (and (list? l)
 899                                   (= (length l) 2)
 900                                   (symbol? (car l))))
 901                            locals)))
 902       (/pmacro-error "syntax error in locals list" locals))
 903   (let* ((evald-locals (map (lambda (l)
 904                               (cons (car l) (/pmacro-expand (cadr l) env loc)))
 905                             locals))
 906          (new-env (append! evald-locals env)))
 907     (/pmacro-expand-expr-list (cons expr1 expr-rest) new-env loc))
 908 )
 909
 910 ; ($let* (var-list) expr1 . expr-rest)
 911 ; NOTE: syntactic form
 912
 913 (define (/pmacro-builtin-let* loc env locals expr1 . expr-rest)
 914   (if (not (list? locals))
 915       (/pmacro-error "locals is not a list" locals))
 916   (if (not (all-true? (map (lambda (l)
 917                              (and (list? l)
 918                                   (= (length l) 2)
 919                                   (symbol? (car l))))
 920                            locals)))
 921       (/pmacro-error "syntax error in locals list" locals))
 922   (let loop ((locals locals) (new-env env))
 923     (if (null? locals)
 924         (/pmacro-expand-expr-list (cons expr1 expr-rest) new-env loc)
 925         (loop (cdr locals) (acons (caar locals)
 926                                   (/pmacro-expand (cadar locals) new-env loc)
 927                                   new-env))))
 928 )
 929
 930 ; ($if expr then [else])
 931 ; NOTE: syntactic form
 932
 933 (define (/pmacro-builtin-if loc env expr then-clause . else-clause)
 934   (case (length else-clause)
 935     ((0) (if (/pmacro-expand expr env loc)
 936              (/pmacro-expand then-clause env loc)
 937              nil))
 938     ((1) (if (/pmacro-expand expr env loc)
 939              (/pmacro-expand then-clause env loc)
 940              (/pmacro-expand (car else-clause) env loc)))
 941     (else (/pmacro-error "too many elements in else-clause, expecting 0 or 1" else-clause)))
 942 )
 943
 944 ; ($case expr ((case-list1) stmt) [case-expr-stmt-list] [(else stmt)])
 945 ; NOTE: syntactic form
 946 ; NOTE: this uses "member" for case comparison (Scheme uses memq I think)
 947
 948 (define (/pmacro-builtin-case loc env expr case1 . rest)
 949   (let ((evald-expr (/pmacro-expand expr env loc)))
 950     (let loop ((cases (cons case1 rest)))
 951       (if (null? cases)
 952           nil
 953           (begin
 954             (if (not (list? (car cases)))
 955                 (/pmacro-error "case statement not a list" (car cases)))
 956             (if (= (length (car cases)) 1)
 957                 (/pmacro-error "case statement has case but no expr" (car cases)))
 958             (if (and (not (eq? (caar cases) 'else))
 959                      (not (list? (caar cases))))
 960                 (/pmacro-error "case must be \"else\" or list of choices" (caar cases)))
 961             (cond ((eq? (caar cases) 'else)
 962                    (/pmacro-expand-expr-list (cdar cases) env loc))
 963                   ((member evald-expr (caar cases))
 964                    (/pmacro-expand-expr-list (cdar cases) env loc))
 965                   (else
 966                    (loop (cdr cases))))))))
 967 )
 968
 969 ; ($cond (expr stmt) [(cond-expr-stmt-list)] [(else stmt)])
 970 ; NOTE: syntactic form
 971
 972 (define (/pmacro-builtin-cond loc env expr1 . rest)
 973   (let loop ((exprs (cons expr1 rest)))
 974     (cond ((null? exprs)
 975            nil)
 976           ((eq? (car exprs) 'else)
 977            (/pmacro-expand-expr-list (cdar exprs) env loc))
 978           (else
 979            (let ((evald-expr (/pmacro-expand (caar exprs) env loc)))
 980              (if evald-expr
 981                  (/pmacro-expand-expr-list (cdar exprs) env loc)
 982                  (loop (cdr exprs)))))))
 983 )
 984
 985 ; ($begin . stmt-list)
 986 ; NOTE: syntactic form
 987
 988 (define (/pmacro-builtin-begin loc env . rest)
 989   (/pmacro-expand-expr-list rest env loc)
 990 )
 991
 992 ; ($print . expr)
 993 ; Strings have quotes removed.
 994
 995 (define (/pmacro-builtin-print . exprs)
 996   (apply message exprs)
 997   nil ; need to return something the reader will accept and ignore
 998 )
 999
1000 ; ($dump expr)
1001 ; Strings do not have quotes removed.
1002
1003 (define (/pmacro-builtin-dump expr)
1004   (write expr (current-error-port))
1005   nil ; need to return something the reader will accept and ignore
1006 )
1007
1008 ; ($error . expr)
1009
1010 (define (/pmacro-builtin-error . exprs)
1011   (apply error exprs)
1012 )
1013
1014 ; ($list expr1 ...)
1015
1016 (define (/pmacro-builtin-list . exprs)
1017   exprs
1018 )
1019
1020 ; ($ref expr index)
1021
1022 (define (/pmacro-builtin-ref l n)
1023   (if (not (list? l))
1024       (/pmacro-error "invalid arg for $ref, expected list" l))
1025   (if (not (integer? n)) ;; FIXME: call non-negative-integer?
1026       (/pmacro-error "invalid arg for $ref, expected non-negative integer" n))
1027   (list-ref l n)
1028 )
1029
1030 ; ($length x)
1031
1032 (define (/pmacro-builtin-length x)
1033   (cond ((symbol? x) (string-length (symbol->string x)))
1034         ((string? x) (string-length x))
1035         ((list? x) (length x))
1036         (else
1037          (/pmacro-error "invalid arg for $length, expected symbol, string, or list" x)))
1038 )
1039
1040 ; ($replicate n expr)
1041
1042 (define (/pmacro-builtin-replicate n expr)
1043   (if (not (integer? n)) ;; FIXME: call non-negative-integer?
1044       (/pmacro-error "invalid arg for $replicate, expected non-negative integer" n))
1045   (make-list n expr)
1046 )
1047
1048 ; ($find pred l)
1049
1050 (define (/pmacro-builtin-find pred l)
1051   (if (not (/pmacro? pred))
1052       (/pmacro-error "not a pmacro" pred))
1053   (if (not (list? l))
1054       (/pmacro-error "not a list" l))
1055   (let ((transformer (/pmacro-transformer pred)))
1056     (if (not (procedure? transformer))
1057         (/pmacro-error "not a procedural macro" pred))
1058     (find transformer l))
1059 )
1060
1061 ; ($equal? x y)
1062
1063 (define (/pmacro-builtin-equal? x y)
1064   (equal? x y)
1065 )
1066
1067 ; ($andif . rest)
1068 ; NOTE: syntactic form
1069 ; Elements of EXPRS are evaluated one at a time.
1070 ; Unprocessed elements are not evaluated.
1071
1072 (define (/pmacro-builtin-andif loc env . exprs)
1073   (if (null? exprs)
1074       #t
1075       (let loop ((exprs exprs))
1076         (let ((evald-expr (/pmacro-expand (car exprs) env loc)))
1077           (cond ((null? (cdr exprs)) evald-expr)
1078                 (evald-expr (loop (cdr exprs)))
1079                 (else #f)))))
1080 )
1081
1082 ; ($orif . rest)
1083 ; NOTE: syntactic form
1084 ; Elements of EXPRS are evaluated one at a time.
1085 ; Unprocessed elements are not evaluated.
1086
1087 (define (/pmacro-builtin-orif loc env . exprs)
1088   (let loop ((exprs exprs))
1089     (if (null? exprs)
1090         #f
1091         (let ((evald-expr (/pmacro-expand (car exprs) env loc)))
1092           (if evald-expr
1093               evald-expr
1094               (loop (cdr exprs))))))
1095 )
1096
1097 ; ($not expr)
1098
1099 (define (/pmacro-builtin-not x)
1100   (not x)
1101 )
1102
1103 ; Verify x,y are compatible for eq/ne comparisons.
1104
1105 (define (/pmacro-compatible-for-equality x y)
1106   (or (and (symbol? x) (symbol? y))
1107       (and (string? x) (string? y))
1108       (and (number? x) (number? y)))
1109 )
1110
1111 ; ($eq expr)
1112
1113 (define (/pmacro-builtin-eq x y)
1114   (cond ((symbol? x)
1115          (if (symbol? y)
1116              (eq? x y)
1117              (/pmacro-error "incompatible args for $eq, expected symbol" y)))
1118         ((string? x)
1119          (if (string? y)
1120              (string=? x y)
1121              (/pmacro-error "incompatible args for $eq, expected string" y)))
1122         ((number? x)
1123          (if (number? y)
1124              (= x y)
1125              (/pmacro-error "incompatible args for $eq, expected number" y)))
1126         (else
1127          (/pmacro-error "unsupported args for $eq" (list x y))))
1128 )
1129
1130 ; ($ne expr)
1131
1132 (define (/pmacro-builtin-ne x y)
1133   (cond ((symbol? x)
1134          (if (symbol? y)
1135              (not (eq? x y))
1136              (/pmacro-error "incompatible args for $ne, expected symbol" y)))
1137         ((string? x)
1138          (if (string? y)
1139              (not (string=? x y))
1140              (/pmacro-error "incompatible args for $ne, expected string" y)))
1141         ((number? x)
1142          (if (number? y)
1143              (not (= x y))
1144              (/pmacro-error "incompatible args for $ne, expected number" y)))
1145         (else
1146          (/pmacro-error "unsupported args for $ne" (list x y))))
1147 )
1148
1149 ; ($lt expr)
1150
1151 (define (/pmacro-builtin-lt x y)
1152   (/pmacro-verify-number "$lt" x)
1153   (/pmacro-verify-number "$lt" y)
1154   (< x y)
1155 )
1156
1157 ; ($gt expr)
1158
1159 (define (/pmacro-builtin-gt x y)
1160   (/pmacro-verify-number "$gt" x)
1161   (/pmacro-verify-number "$gt" y)
1162   (> x y)
1163 )
1164
1165 ; ($le expr)
1166
1167 (define (/pmacro-builtin-le x y)
1168   (/pmacro-verify-number "$le" x)
1169   (/pmacro-verify-number "$le" y)
1170   (<= x y)
1171 )
1172
1173 ; ($ge expr)
1174
1175 (define (/pmacro-builtin-ge x y)
1176   (/pmacro-verify-number "$ge" x)
1177   (/pmacro-verify-number "$ge" y)
1178   (>= x y)
1179 )
1180
1181 ; ($add x y)
1182
1183 (define (/pmacro-builtin-add x y)
1184   (/pmacro-verify-number "$add" x)
1185   (/pmacro-verify-number "$add" y)
1186   (+ x y)
1187 )
1188
1189 ; ($sub x y)
1190
1191 (define (/pmacro-builtin-sub x y)
1192   (/pmacro-verify-number "$sub" x)
1193   (/pmacro-verify-number "$sub" y)
1194   (- x y)
1195 )
1196
1197 ; ($mul x y)
1198
1199 (define (/pmacro-builtin-mul x y)
1200   (/pmacro-verify-number "$mul" x)
1201   (/pmacro-verify-number "$mul" y)
1202   (* x y)
1203 )
1204
1205 ; ($div x y) - integer division
1206
1207 (define (/pmacro-builtin-div x y)
1208   (/pmacro-verify-integer "$div" x)
1209   (/pmacro-verify-integer "$div" y)
1210   (quotient x y)
1211 )
1212
1213 ; ($rem x y) - integer remainder
1214 ; ??? Need to decide behavior.
1215
1216 (define (/pmacro-builtin-rem x y)
1217   (/pmacro-verify-integer "$rem" x)
1218   (/pmacro-verify-integer "$rem" y)
1219   (remainder x y)
1220 )
1221
1222 ; ($sll x n) - shift left logical
1223
1224 (define (/pmacro-builtin-sll x n)
1225   (/pmacro-verify-integer "$sll" x)
1226   (/pmacro-verify-non-negative-integer "$sll" n)
1227   (ash x n)
1228 )
1229
1230 ; ($srl x n) - shift right logical
1231 ; X must be non-negative, otherwise behavior is undefined.
1232 ; [Unless we introduce a size argument: How do you logical shift right
1233 ; an arbitrary precision negative number?]
1234
1235 (define (/pmacro-builtin-srl x n)
1236   (/pmacro-verify-non-negative-integer "$srl" x)
1237   (/pmacro-verify-non-negative-integer "$srl" n)
1238   (ash x (- n))
1239 )
1240
1241 ; ($sra x n) - shift right arithmetic
1242
1243 (define (/pmacro-builtin-sra x n)
1244   (/pmacro-verify-integer "$sra" x)
1245   (/pmacro-verify-non-negative-integer "$sra" n)
1246   (ash x (- n))
1247 )
1248
1249 ; ($and x y) - bitwise and
1250
1251 (define (/pmacro-builtin-and x y)
1252   (/pmacro-verify-integer "$and" x)
1253   (/pmacro-verify-integer "$and" y)
1254   (logand x y)
1255 )
1256
1257 ; ($or x y) - bitwise or
1258
1259 (define (/pmacro-builtin-or x y)
1260   (/pmacro-verify-integer "$or" x)
1261   (/pmacro-verify-integer "$or" y)
1262   (logior x y)
1263 )
1264
1265 ; ($xor x y) - bitwise xor
1266
1267 (define (/pmacro-builtin-xor x y)
1268   (/pmacro-verify-integer "$xor" x)
1269   (/pmacro-verify-integer "$xor" y)
1270   (logxor x y)
1271 )
1272
1273 ; ($inv x) - bitwise invert
1274
1275 (define (/pmacro-builtin-inv x)
1276   (/pmacro-verify-integer "$inv" x)
1277   (lognot x)
1278 )
1279
1280 ; ($car expr)
1281
1282 (define (/pmacro-builtin-car l)
1283   (if (pair? l)
1284       (car l)
1285       (/pmacro-error "invalid arg for $car, expected pair" l))
1286 )
1287
1288 ; ($cdr expr)
1289
1290 (define (/pmacro-builtin-cdr l)
1291   (if (pair? l)
1292       (cdr l)
1293       (/pmacro-error "invalid arg for $cdr, expected pair" l))
1294 )
1295
1296 ; ($caar expr)
1297
1298 (define (/pmacro-builtin-caar l)
1299   (if (and (pair? l) (pair? (car l)))
1300       (caar l)
1301       (/pmacro-error "invalid arg for $caar" l))
1302 )
1303
1304 ; ($cadr expr)
1305
1306 (define (/pmacro-builtin-cadr l)
1307   (if (and (pair? l) (pair? (cdr l)))
1308       (cadr l)
1309       (/pmacro-error "invalid arg for $cadr" l))
1310 )
1311
1312 ; ($cdar expr)
1313
1314 (define (/pmacro-builtin-cdar l)
1315   (if (and (pair? l) (pair? (car l)))
1316       (cdar l)
1317       (/pmacro-error "invalid arg for $cdar" l))
1318 )
1319
1320 ; ($cddr expr)
1321
1322 (define (/pmacro-builtin-cddr l)
1323   (if (and (pair? l) (pair? (cdr l)))
1324       (cddr l)
1325       (/pmacro-error "invalid arg for $cddr" l))
1326 )
1327
1328 ; ($internal-test expr)
1329 ; This is an internal builtin for use by the testsuite.
1330 ; EXPR is a Scheme expression that is executed to verify proper
1331 ; behaviour of something.  It must return #f for FAIL, non-#f for PASS.
1332 ; The result is #f for FAIL, #t for PASS.
1333 ; This must be used in an expression, it is not sufficient to do
1334 ; ($internal-test mumble) because the reader will see #f or #t and complain.
1335
1336 (define (/pmacro-builtin-internal-test expr)
1337   (and (eval1 expr) #t)
1338 )
1339 \f
1340 ; Initialization.
1341
1342 (define (pmacros-init!)
1343   (set! /pmacro-table (make-hash-table 127))
1344   (set! /smacro-table (make-hash-table 41))
1345
1346   ; Some "predefined" pmacros.
1347
1348   (let ((macros
1349          ;; name arg-spec syntactic? function description
1350          (list
1351           (list 'sym 'symbols #f /pmacro-builtin-sym "symbol-append")
1352           (list 'str 'strings #f /pmacro-builtin-str "string-append")
1353           (list 'hex '(number . width) #f /pmacro-builtin-hex "convert to -hex, with optional width")
1354           (list 'upcase '(string) #f /pmacro-builtin-upcase "string-upcase")
1355           (list 'downcase '(string) #f /pmacro-builtin-downcase "string-downcase")
1356           (list 'substring '(string start end) #f /pmacro-builtin-substring "get start of a string")
1357           (list 'splice 'arg-list #f /pmacro-builtin-splice "splice lists into the outer list")
1358           (list 'iota '(count . start-incr) #f /pmacro-builtin-iota "iota number generator")
1359           (list 'map '(pmacro list1 . rest) #f /pmacro-builtin-map "map a pmacro over a list of arguments")
1360           (list 'for-each '(pmacro list1 . rest) #f /pmacro-builtin-for-each "execute a pmacro over a list of arguments")
1361           (list 'eval '(expr) #t /pmacro-builtin-eval "expand(evaluate) expr")
1362           (list 'exec '(expr) #f /pmacro-builtin-exec "execute expr immediately")
1363           (list 'apply '(pmacro arg-list) #f /pmacro-builtin-apply "apply a pmacro to a list of arguments")
1364           (list 'pmacro '(params expansion) #t /pmacro-builtin-pmacro "create a pmacro on-the-fly")
1365           (list 'pmacro? '(arg) #f /pmacro-builtin-pmacro? "return true if arg is a pmacro")
1366           (list 'let '(locals expr1 . rest) #t /pmacro-builtin-let "create a binding context, let-style")
1367           (list 'let* '(locals expr1 . rest) #t /pmacro-builtin-let* "create a binding context, let*-style")
1368           (list 'if '(expr then . else) #t /pmacro-builtin-if "if expr is true, process then, else else")
1369           (list 'case '(expr case1 . rest) #t /pmacro-builtin-case "process statement that matches expr")
1370           (list 'cond '(expr1 . rest) #t /pmacro-builtin-cond "process first statement whose expr succeeds")
1371           (list 'begin 'rest #t /pmacro-builtin-begin "process a sequence of statements")
1372           (list 'print 'exprs #f /pmacro-builtin-print "print exprs, for debugging purposes")
1373           (list 'dump '(expr)  #f /pmacro-builtin-dump "dump expr, for debugging purposes")
1374           (list 'error 'message #f /pmacro-builtin-error "print error message and exit")
1375           (list 'list 'exprs #f /pmacro-builtin-list "return a list of exprs")
1376           (list 'ref '(l n) #f /pmacro-builtin-ref "return n'th element of list l")
1377           (list 'length '(x) #f /pmacro-builtin-length "return length of symbol, string, or list")
1378           (list 'replicate '(n expr) #f /pmacro-builtin-replicate "return list of expr replicated n times")
1379           (list 'find '(pred l) #f /pmacro-builtin-find "return elements of list l matching pred")
1380           (list 'equal? '(x y) #f /pmacro-builtin-equal? "deep comparison of x and y")
1381           (list 'andif 'rest #t /pmacro-builtin-andif "return first #f element, otherwise return last element")
1382           (list 'orif 'rest #t /pmacro-builtin-orif "return first non-#f element found, otherwise #f")
1383           (list 'not '(x) #f /pmacro-builtin-not "return !x")
1384           (list 'eq '(x y) #f /pmacro-builtin-eq "return true if x == y")
1385           (list 'ne '(x y) #f /pmacro-builtin-ne "return true if x != y")
1386           (list 'lt '(x y) #f /pmacro-builtin-lt "return true if x < y")
1387           (list 'gt '(x y) #f /pmacro-builtin-gt "return true if x > y")
1388           (list 'le '(x y) #f /pmacro-builtin-le "return true if x <= y")
1389           (list 'ge '(x y) #f /pmacro-builtin-ge "return true if x >= y")
1390           (list 'add '(x y) #f /pmacro-builtin-add "return x + y")
1391           (list 'sub '(x y) #f /pmacro-builtin-sub "return x - y")
1392           (list 'mul '(x y) #f /pmacro-builtin-mul "return x * y")
1393           (list 'div '(x y) #f /pmacro-builtin-div "return x / y")
1394           (list 'rem '(x y) #f /pmacro-builtin-rem "return x % y")
1395           (list 'sll '(x n) #f /pmacro-builtin-sll "return logical x << n")
1396           (list 'srl '(x n) #f /pmacro-builtin-srl "return logical x >> n")
1397           (list 'sra '(x n) #f /pmacro-builtin-sra "return arithmetic x >> n")
1398           (list 'and '(x y) #f /pmacro-builtin-and "return x & y")
1399           (list 'or '(x y) #f /pmacro-builtin-or "return x | y")
1400           (list 'xor '(x y) #f /pmacro-builtin-xor "return x ^ y")
1401           (list 'inv '(x) #f /pmacro-builtin-inv "return ~x")
1402           (list 'car '(x) #f /pmacro-builtin-car "return (car x)")
1403           (list 'cdr '(x) #f /pmacro-builtin-cdr "return (cdr x)")
1404           (list 'caar '(x) #f /pmacro-builtin-caar "return (caar x)")
1405           (list 'cadr '(x) #f /pmacro-builtin-cadr "return (cadr x)")
1406           (list 'cdar '(x) #f /pmacro-builtin-cdar "return (cdar x)")
1407           (list 'cddr '(x) #f /pmacro-builtin-cddr "return (cddr x)")
1408           (list 'internal-test '(expr) #f /pmacro-builtin-internal-test "testsuite use only")
1409           )))
1410     (for-each (lambda (x)
1411                 (let ((name (string->symbol (string-append "." (symbol->string (list-ref x 0)))))
1412                       (arg-spec (list-ref x 1))
1413                       (syntactic? (list-ref x 2))
1414                       (pmacro (list-ref x 3))
1415                       (comment (list-ref x 4)))
1416                   (/pmacro-set! name
1417                                 (/pmacro-make name arg-spec #f syntactic? pmacro comment))
1418                   (if syntactic?
1419                       (/smacro-set! name
1420                                     (/pmacro-make name arg-spec #f syntactic? pmacro comment)))))
1421               macros))
1422 )
1423
1424 ; Initialize so we're ready to use after loading.
1425 (pmacros-init!)