module/language/tree-il/primitives.scm

   1 ;;; open-coding primitive procedures
   2
   3 ;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language tree-il primitives)
  22   #:use-module (system base pmatch)
  23   #:use-module (rnrs bytevectors)
  24   #:use-module (system base syntax)
  25   #:use-module (language tree-il)
  26   #:use-module (srfi srfi-4)
  27   #:use-module (srfi srfi-16)
  28   #:export (resolve-primitives! add-interesting-primitive!
  29             expand-primitives!
  30             effect-free-primitive? effect+exception-free-primitive?
  31             constructor-primitive? accessor-primitive?
  32             singly-valued-primitive?))
  33
  34 (define *interesting-primitive-names*
  35   '(apply @apply
  36     call-with-values @call-with-values
  37     call-with-current-continuation @call-with-current-continuation
  38     call/cc
  39     dynamic-wind
  40     @dynamic-wind
  41     values
  42     eq? eqv? equal?
  43     memq memv
  44     = < > <= >= zero?
  45     + * - / 1- 1+ quotient remainder modulo
  46     ash logand logior logxor
  47     not
  48     pair? null? list? symbol? vector? string? struct?
  49     acons cons cons*
  50
  51     list vector
  52
  53     car cdr
  54     set-car! set-cdr!
  55
  56     caar cadr cdar cddr
  57
  58     caaar caadr cadar caddr cdaar cdadr cddar cdddr
  59
  60     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
  61     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
  62
  63     vector-ref vector-set!
  64     variable-ref variable-set!
  65     variable-bound?
  66
  67     fluid-ref fluid-set!
  68
  69     @prompt call-with-prompt @abort abort-to-prompt
  70     make-prompt-tag
  71
  72     string-length string-ref string-set!
  73
  74     struct-vtable make-struct struct-ref struct-set!
  75
  76     bytevector-u8-ref bytevector-u8-set!
  77     bytevector-s8-ref bytevector-s8-set!
  78     u8vector-ref u8vector-set! s8vector-ref s8vector-set!
  79
  80     bytevector-u16-ref bytevector-u16-set!
  81     bytevector-u16-native-ref bytevector-u16-native-set!
  82     bytevector-s16-ref bytevector-s16-set!
  83     bytevector-s16-native-ref bytevector-s16-native-set!
  84     u16vector-ref u16vector-set! s16vector-ref s16vector-set!
  85
  86     bytevector-u32-ref bytevector-u32-set!
  87     bytevector-u32-native-ref bytevector-u32-native-set!
  88     bytevector-s32-ref bytevector-s32-set!
  89     bytevector-s32-native-ref bytevector-s32-native-set!
  90     u32vector-ref u32vector-set! s32vector-ref s32vector-set!
  91
  92     bytevector-u64-ref bytevector-u64-set!
  93     bytevector-u64-native-ref bytevector-u64-native-set!
  94     bytevector-s64-ref bytevector-s64-set!
  95     bytevector-s64-native-ref bytevector-s64-native-set!
  96     u64vector-ref u64vector-set! s64vector-ref s64vector-set!
  97
  98     bytevector-ieee-single-ref bytevector-ieee-single-set!
  99     bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
 100     bytevector-ieee-double-ref bytevector-ieee-double-set!
 101     bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
 102     f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
 103
 104 (define (add-interesting-primitive! name)
 105   (hashq-set! *interesting-primitive-vars*
 106               (or (module-variable (current-module) name)
 107                   (error "unbound interesting primitive" name))
 108               name))
 109
 110 (define *interesting-primitive-vars* (make-hash-table))
 111
 112 (for-each add-interesting-primitive! *interesting-primitive-names*)
 113
 114 (define *primitive-constructors*
 115   ;; Primitives that return a fresh object.
 116   '(acons cons cons* list vector make-struct make-struct/no-tail
 117     make-prompt-tag))
 118
 119 (define *primitive-accessors*
 120   ;; Primitives that are pure, but whose result depends on the mutable
 121   ;; memory pointed to by their operands.
 122   '(vector-ref
 123     car cdr
 124     memq memv
 125     struct-vtable struct-ref
 126     string-ref
 127     bytevector-u8-ref bytevector-s8-ref
 128     bytevector-u16-ref bytevector-u16-native-ref
 129     bytevector-s16-ref bytevector-s16-native-ref
 130     bytevector-u32-ref bytevector-u32-native-ref
 131     bytevector-s32-ref bytevector-s32-native-ref
 132     bytevector-u64-ref bytevector-u64-native-ref
 133     bytevector-s64-ref bytevector-s64-native-ref
 134     bytevector-ieee-single-ref bytevector-ieee-single-native-ref
 135     bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
 136
 137 (define *effect-free-primitives*
 138   `(values
 139     eq? eqv? equal?
 140     = < > <= >= zero?
 141     + * - / 1- 1+ quotient remainder modulo
 142     not
 143     pair? null? list? symbol? vector? struct? string?
 144     string-length
 145     ;; These all should get expanded out by expand-primitives!.
 146     caar cadr cdar cddr
 147     caaar caadr cadar caddr cdaar cdadr cddar cdddr
 148     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
 149     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
 150     ,@*primitive-constructors*
 151     ,@*primitive-accessors*))
 152
 153 ;; Like *effect-free-primitives* above, but further restricted in that they
 154 ;; cannot raise exceptions.
 155 (define *effect+exception-free-primitives*
 156   '(values
 157     eq? eqv? equal?
 158     not
 159     pair? null? list? symbol? vector? struct? string?
 160     acons cons cons* list vector))
 161
 162 ;; Primitives that only return one value.
 163 (define *singly-valued-primitives*
 164   '(eq? eqv? equal?
 165     memq memv
 166     = < > <= >= zero?
 167     + * - / 1- 1+ quotient remainder modulo
 168     ash logand logior logxor
 169     not
 170     pair? null? list? symbol? vector? acons cons cons*
 171     list vector
 172     car cdr
 173     set-car! set-cdr!
 174     caar cadr cdar cddr
 175     caaar caadr cadar caddr cdaar cdadr cddar cdddr
 176     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
 177     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
 178     vector-ref vector-set!
 179     variable-ref variable-set!
 180     variable-bound?
 181     fluid-ref fluid-set!
 182     make-prompt-tag
 183     struct? struct-vtable make-struct struct-ref struct-set!
 184     string-length string-ref string-set!
 185     bytevector-u8-ref bytevector-u8-set!
 186     bytevector-s8-ref bytevector-s8-set!
 187     u8vector-ref u8vector-set! s8vector-ref s8vector-set!
 188     bytevector-u16-ref bytevector-u16-set!
 189     bytevector-u16-native-ref bytevector-u16-native-set!
 190     bytevector-s16-ref bytevector-s16-set!
 191     bytevector-s16-native-ref bytevector-s16-native-set!
 192     u16vector-ref u16vector-set! s16vector-ref s16vector-set!
 193     bytevector-u32-ref bytevector-u32-set!
 194     bytevector-u32-native-ref bytevector-u32-native-set!
 195     bytevector-s32-ref bytevector-s32-set!
 196     bytevector-s32-native-ref bytevector-s32-native-set!
 197     u32vector-ref u32vector-set! s32vector-ref s32vector-set!
 198     bytevector-u64-ref bytevector-u64-set!
 199     bytevector-u64-native-ref bytevector-u64-native-set!
 200     bytevector-s64-ref bytevector-s64-set!
 201     bytevector-s64-native-ref bytevector-s64-native-set!
 202     u64vector-ref u64vector-set! s64vector-ref s64vector-set!
 203     bytevector-ieee-single-ref bytevector-ieee-single-set!
 204     bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
 205     bytevector-ieee-double-ref bytevector-ieee-double-set!
 206     bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
 207     f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
 208
 209 (define *effect-free-primitive-table* (make-hash-table))
 210 (define *effect+exceptions-free-primitive-table* (make-hash-table))
 211 (define *singly-valued-primitive-table* (make-hash-table))
 212
 213 (for-each (lambda (x)
 214             (hashq-set! *effect-free-primitive-table* x #t))
 215           *effect-free-primitives*)
 216 (for-each (lambda (x)
 217             (hashq-set! *effect+exceptions-free-primitive-table* x #t))
 218           *effect+exception-free-primitives*)
 219 (for-each (lambda (x)
 220             (hashq-set! *singly-valued-primitive-table* x #t))
 221           *singly-valued-primitives*)
 222
 223 (define (constructor-primitive? prim)
 224   (memq prim *primitive-constructors*))
 225 (define (accessor-primitive? prim)
 226   (memq prim *primitive-accessors*))
 227 (define (effect-free-primitive? prim)
 228   (hashq-ref *effect-free-primitive-table* prim))
 229 (define (effect+exception-free-primitive? prim)
 230   (hashq-ref *effect+exceptions-free-primitive-table* prim))
 231 (define (singly-valued-primitive? prim)
 232   (hashq-ref *singly-valued-primitive-table* prim))
 233
 234 (define (resolve-primitives! x mod)
 235   (post-order!
 236    (lambda (x)
 237      (record-case x
 238        ((<toplevel-ref> src name)
 239         (and=> (hashq-ref *interesting-primitive-vars*
 240                           (module-variable mod name))
 241                (lambda (name) (make-primitive-ref src name))))
 242        ((<module-ref> src mod name public?)
 243         ;; for the moment, we're disabling primitive resolution for
 244         ;; public refs because resolve-interface can raise errors.
 245         (let ((m (and (not public?) (resolve-module mod))))
 246           (and m
 247                (and=> (hashq-ref *interesting-primitive-vars*
 248                                  (module-variable m name))
 249                       (lambda (name) (make-primitive-ref src name))))))
 250        (else #f)))
 251    x))
 252
 253 \f
 254
 255 (define *primitive-expand-table* (make-hash-table))
 256
 257 (define (expand-primitives! x)
 258   (pre-order!
 259    (lambda (x)
 260      (record-case x
 261        ((<application> src proc args)
 262         (and (primitive-ref? proc)
 263              (let ((expand (hashq-ref *primitive-expand-table*
 264                                       (primitive-ref-name proc))))
 265                (and expand (apply expand src args)))))
 266        (else #f)))
 267    x))
 268
 269 ;;; I actually did spend about 10 minutes trying to redo this with
 270 ;;; syntax-rules. Patches appreciated.
 271 ;;;
 272 (define-macro (define-primitive-expander sym . clauses)
 273   (define (inline-args args)
 274     (let lp ((in args) (out '()))
 275       (cond ((null? in) `(list ,@(reverse out)))
 276             ((symbol? in) `(cons* ,@(reverse out) ,in))
 277             ((pair? (car in))
 278              (lp (cdr in)
 279                  (cons (if (eq? (caar in) 'quote)
 280                            `(make-const src ,@(cdar in))
 281                            `(make-application src (make-primitive-ref src ',(caar in))
 282                                               ,(inline-args (cdar in))))
 283                        out)))
 284             ((symbol? (car in))
 285              ;; assume it's locally bound
 286              (lp (cdr in) (cons (car in) out)))
 287             ((self-evaluating? (car in))
 288              (lp (cdr in) (cons `(make-const src ,(car in)) out)))
 289             (else
 290              (error "what what" (car in))))))
 291   (define (consequent exp)
 292     (cond
 293      ((pair? exp)
 294       (pmatch exp
 295         ((if ,test ,then ,else)
 296          `(if ,test
 297               ,(consequent then)
 298               ,(consequent else)))
 299         (else
 300          `(make-application src (make-primitive-ref src ',(car exp))
 301                             ,(inline-args (cdr exp))))))
 302      ((symbol? exp)
 303       ;; assume locally bound
 304       exp)
 305      ((number? exp)
 306       `(make-const src ,exp))
 307      ((not exp)
 308       ;; failed match
 309       #f)
 310      (else (error "bad consequent yall" exp))))
 311   `(hashq-set! *primitive-expand-table*
 312                ',sym
 313                (case-lambda
 314                 ,@(let lp ((in clauses) (out '()))
 315                     (if (null? in)
 316                         (reverse (cons '(else #f) out))
 317                         (lp (cddr in)
 318                             (cons `((src . ,(car in))
 319                                     ,(consequent (cadr in))) out)))))))
 320
 321 (define-primitive-expander zero? (x)
 322   (= x 0))
 323
 324 ;; FIXME: All the code that uses `const?' is redundant with `peval'.
 325
 326 (define-primitive-expander +
 327   () 0
 328   (x) (values x)
 329   (x y) (if (and (const? y)
 330                  (let ((y (const-exp y)))
 331                    (and (number? y) (exact? y) (= y 1))))
 332             (1+ x)
 333             (if (and (const? y)
 334                      (let ((y (const-exp y)))
 335                        (and (number? y) (exact? y) (= y -1))))
 336                 (1- x)
 337                 (if (and (const? x)
 338                          (let ((x (const-exp x)))
 339                            (and (number? x) (exact? x) (= x 1))))
 340                     (1+ y)
 341                     (+ x y))))
 342   (x y z . rest) (+ x (+ y z . rest)))
 343
 344 (define-primitive-expander *
 345   () 1
 346   (x) (values x)
 347   (x y z . rest) (* x (* y z . rest)))
 348
 349 (define-primitive-expander -
 350   (x) (- 0 x)
 351   (x y) (if (and (const? y)
 352                  (let ((y (const-exp y)))
 353                    (and (number? y) (exact? y) (= y 1))))
 354             (1- x)
 355             (- x y))
 356   (x y z . rest) (- x (+ y z . rest)))
 357
 358 (define-primitive-expander /
 359   (x) (/ 1 x)
 360   (x y z . rest) (/ x (* y z . rest)))
 361
 362 (define-primitive-expander caar (x) (car (car x)))
 363 (define-primitive-expander cadr (x) (car (cdr x)))
 364 (define-primitive-expander cdar (x) (cdr (car x)))
 365 (define-primitive-expander cddr (x) (cdr (cdr x)))
 366 (define-primitive-expander caaar (x) (car (car (car x))))
 367 (define-primitive-expander caadr (x) (car (car (cdr x))))
 368 (define-primitive-expander cadar (x) (car (cdr (car x))))
 369 (define-primitive-expander caddr (x) (car (cdr (cdr x))))
 370 (define-primitive-expander cdaar (x) (cdr (car (car x))))
 371 (define-primitive-expander cdadr (x) (cdr (car (cdr x))))
 372 (define-primitive-expander cddar (x) (cdr (cdr (car x))))
 373 (define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
 374 (define-primitive-expander caaaar (x) (car (car (car (car x)))))
 375 (define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
 376 (define-primitive-expander caadar (x) (car (car (cdr (car x)))))
 377 (define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
 378 (define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
 379 (define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
 380 (define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
 381 (define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
 382 (define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
 383 (define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
 384 (define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
 385 (define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
 386 (define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
 387 (define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
 388 (define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
 389 (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
 390
 391 (define-primitive-expander cons*
 392   (x) (values x)
 393   (x y) (cons x y)
 394   (x y . rest) (cons x (cons* y . rest)))
 395
 396 (define-primitive-expander acons (x y z)
 397   (cons (cons x y) z))
 398
 399 (define-primitive-expander apply (f a0 . args)
 400   (@apply f a0 . args))
 401
 402 (define-primitive-expander call-with-values (producer consumer)
 403   (@call-with-values producer consumer))
 404
 405 (define-primitive-expander call-with-current-continuation (proc)
 406   (@call-with-current-continuation proc))
 407
 408 (define-primitive-expander call/cc (proc)
 409   (@call-with-current-continuation proc))
 410
 411 (define-primitive-expander make-struct (vtable tail-size . args)
 412   (if (and (const? tail-size)
 413            (let ((n (const-exp tail-size)))
 414              (and (number? n) (exact? n) (zero? n))))
 415       (make-struct/no-tail vtable . args)
 416       #f))
 417
 418 (define-primitive-expander u8vector-ref (vec i)
 419   (bytevector-u8-ref vec i))
 420 (define-primitive-expander u8vector-set! (vec i x)
 421   (bytevector-u8-set! vec i x))
 422 (define-primitive-expander s8vector-ref (vec i)
 423   (bytevector-s8-ref vec i))
 424 (define-primitive-expander s8vector-set! (vec i x)
 425   (bytevector-s8-set! vec i x))
 426
 427 (define-primitive-expander u16vector-ref (vec i)
 428   (bytevector-u16-native-ref vec (* i 2)))
 429 (define-primitive-expander u16vector-set! (vec i x)
 430   (bytevector-u16-native-set! vec (* i 2) x))
 431 (define-primitive-expander s16vector-ref (vec i)
 432   (bytevector-s16-native-ref vec (* i 2)))
 433 (define-primitive-expander s16vector-set! (vec i x)
 434   (bytevector-s16-native-set! vec (* i 2) x))
 435
 436 (define-primitive-expander u32vector-ref (vec i)
 437   (bytevector-u32-native-ref vec (* i 4)))
 438 (define-primitive-expander u32vector-set! (vec i x)
 439   (bytevector-u32-native-set! vec (* i 4) x))
 440 (define-primitive-expander s32vector-ref (vec i)
 441   (bytevector-s32-native-ref vec (* i 4)))
 442 (define-primitive-expander s32vector-set! (vec i x)
 443   (bytevector-s32-native-set! vec (* i 4) x))
 444
 445 (define-primitive-expander u64vector-ref (vec i)
 446   (bytevector-u64-native-ref vec (* i 8)))
 447 (define-primitive-expander u64vector-set! (vec i x)
 448   (bytevector-u64-native-set! vec (* i 8) x))
 449 (define-primitive-expander s64vector-ref (vec i)
 450   (bytevector-s64-native-ref vec (* i 8)))
 451 (define-primitive-expander s64vector-set! (vec i x)
 452   (bytevector-s64-native-set! vec (* i 8) x))
 453
 454 (define-primitive-expander f32vector-ref (vec i)
 455   (bytevector-ieee-single-native-ref vec (* i 4)))
 456 (define-primitive-expander f32vector-set! (vec i x)
 457   (bytevector-ieee-single-native-set! vec (* i 4) x))
 458 (define-primitive-expander f32vector-ref (vec i)
 459   (bytevector-ieee-single-native-ref vec (* i 4)))
 460 (define-primitive-expander f32vector-set! (vec i x)
 461   (bytevector-ieee-single-native-set! vec (* i 4) x))
 462
 463 (define-primitive-expander f64vector-ref (vec i)
 464   (bytevector-ieee-double-native-ref vec (* i 8)))
 465 (define-primitive-expander f64vector-set! (vec i x)
 466   (bytevector-ieee-double-native-set! vec (* i 8) x))
 467 (define-primitive-expander f64vector-ref (vec i)
 468   (bytevector-ieee-double-native-ref vec (* i 8)))
 469 (define-primitive-expander f64vector-set! (vec i x)
 470   (bytevector-ieee-double-native-set! vec (* i 8) x))
 471
 472 (hashq-set! *primitive-expand-table*
 473             'dynamic-wind
 474             (case-lambda
 475               ((src pre thunk post)
 476                (let ((PRE (gensym " pre"))
 477                      (THUNK (gensym " thunk"))
 478                      (POST (gensym " post")))
 479                  (make-let
 480                   src
 481                   '(pre thunk post)
 482                   (list PRE THUNK POST)
 483                   (list pre thunk post)
 484                   (make-dynwind
 485                    src
 486                    (make-lexical-ref #f 'pre PRE)
 487                    (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
 488                    (make-lexical-ref #f 'post POST)))))
 489               (else #f)))
 490
 491 (hashq-set! *primitive-expand-table*
 492             '@dynamic-wind
 493             (case-lambda
 494               ((src pre expr post)
 495                (let ((PRE (gensym " pre"))
 496                      (POST (gensym " post")))
 497                  (make-let
 498                   src
 499                   '(pre post)
 500                   (list PRE POST)
 501                   (list pre post)
 502                   (make-dynwind
 503                    src
 504                    (make-lexical-ref #f 'pre PRE)
 505                    expr
 506                    (make-lexical-ref #f 'post POST)))))))
 507
 508 (hashq-set! *primitive-expand-table*
 509             'fluid-ref
 510             (case-lambda
 511               ((src fluid) (make-dynref src fluid))
 512               (else #f)))
 513
 514 (hashq-set! *primitive-expand-table*
 515             'fluid-set!
 516             (case-lambda
 517               ((src fluid exp) (make-dynset src fluid exp))
 518               (else #f)))
 519
 520 (hashq-set! *primitive-expand-table*
 521             '@prompt
 522             (case-lambda
 523               ((src tag exp handler)
 524                (let ((args-sym (gensym)))
 525                  (make-prompt
 526                   src tag exp
 527                   ;; If handler itself is a lambda, the inliner can do some
 528                   ;; trickery here.
 529                   (make-lambda-case
 530                    (tree-il-src handler) '() #f 'args #f '() (list args-sym)
 531                    (make-application #f (make-primitive-ref #f 'apply)
 532                                      (list handler
 533                                            (make-lexical-ref #f 'args args-sym)))
 534                    #f))))
 535               (else #f)))
 536
 537 (hashq-set! *primitive-expand-table*
 538             'call-with-prompt
 539             (case-lambda
 540               ((src tag thunk handler)
 541                ;; Sigh. Until the inliner does its job, manually inline
 542                ;; (let ((h (lambda ...))) (prompt k x h))
 543                (cond
 544                 ((lambda? handler)
 545                  (let ((args-sym (gensym)))
 546                    (make-prompt
 547                     src tag (make-application #f thunk '())
 548                     ;; If handler itself is a lambda, the inliner can do some
 549                     ;; trickery here.
 550                     (make-lambda-case
 551                      (tree-il-src handler) '() #f 'args #f '() (list args-sym)
 552                      (make-application #f (make-primitive-ref #f 'apply)
 553                                        (list handler
 554                                              (make-lexical-ref #f 'args args-sym)))
 555                      #f))))
 556                 (else #f)))
 557               (else #f)))
 558
 559 (hashq-set! *primitive-expand-table*
 560             '@abort
 561             (case-lambda
 562               ((src tag tail-args)
 563                (make-abort src tag '() tail-args))
 564               (else #f)))
 565 (hashq-set! *primitive-expand-table*
 566             'abort-to-prompt
 567             (case-lambda
 568               ((src tag . args)
 569                (make-abort src tag args (make-const #f '())))
 570               (else #f)))