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? singly-valued-primitive?))
  32
  33 (define *interesting-primitive-names*
  34   '(apply @apply
  35     call-with-values @call-with-values
  36     call-with-current-continuation @call-with-current-continuation
  37     call/cc
  38     dynamic-wind
  39     @dynamic-wind
  40     values
  41     eq? eqv? equal?
  42     memq memv
  43     = < > <= >= zero?
  44     + * - / 1- 1+ quotient remainder modulo
  45     ash logand logior logxor
  46     not
  47     pair? null? list? symbol? vector? acons cons cons*
  48
  49     list vector
  50
  51     car cdr
  52     set-car! set-cdr!
  53
  54     caar cadr cdar cddr
  55
  56     caaar caadr cadar caddr cdaar cdadr cddar cdddr
  57
  58     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
  59     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
  60
  61     vector-ref vector-set!
  62     variable-ref variable-set!
  63     variable-bound?
  64
  65     fluid-ref fluid-set!
  66
  67     @prompt call-with-prompt @abort abort-to-prompt
  68     make-prompt-tag
  69
  70     struct? struct-vtable make-struct struct-ref struct-set!
  71
  72     bytevector-u8-ref bytevector-u8-set!
  73     bytevector-s8-ref bytevector-s8-set!
  74     u8vector-ref u8vector-set! s8vector-ref s8vector-set!
  75
  76     bytevector-u16-ref bytevector-u16-set!
  77     bytevector-u16-native-ref bytevector-u16-native-set!
  78     bytevector-s16-ref bytevector-s16-set!
  79     bytevector-s16-native-ref bytevector-s16-native-set!
  80     u16vector-ref u16vector-set! s16vector-ref s16vector-set!
  81
  82     bytevector-u32-ref bytevector-u32-set!
  83     bytevector-u32-native-ref bytevector-u32-native-set!
  84     bytevector-s32-ref bytevector-s32-set!
  85     bytevector-s32-native-ref bytevector-s32-native-set!
  86     u32vector-ref u32vector-set! s32vector-ref s32vector-set!
  87
  88     bytevector-u64-ref bytevector-u64-set!
  89     bytevector-u64-native-ref bytevector-u64-native-set!
  90     bytevector-s64-ref bytevector-s64-set!
  91     bytevector-s64-native-ref bytevector-s64-native-set!
  92     u64vector-ref u64vector-set! s64vector-ref s64vector-set!
  93
  94     bytevector-ieee-single-ref bytevector-ieee-single-set!
  95     bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
  96     bytevector-ieee-double-ref bytevector-ieee-double-set!
  97     bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
  98     f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
  99
 100 (define (add-interesting-primitive! name)
 101   (hashq-set! *interesting-primitive-vars*
 102               (or (module-variable (current-module) name)
 103                   (error "unbound interesting primitive" name))
 104               name))
 105
 106 (define *interesting-primitive-vars* (make-hash-table))
 107
 108 (for-each add-interesting-primitive! *interesting-primitive-names*)
 109
 110 (define *primitive-constructors*
 111   ;; Primitives that return a fresh object.
 112   '(acons cons cons* list vector make-struct make-struct/no-tail
 113           car cdr vector-ref struct-ref make-prompt-tag))
 114
 115 (define *effect-free-primitives*
 116   `(values
 117     eq? eqv? equal?
 118     = < > <= >= zero?
 119     + * - / 1- 1+ quotient remainder modulo
 120     not
 121     pair? null? list? symbol? vector?
 122     caar cadr cdar cddr
 123     caaar caadr cadar caddr cdaar cdadr cddar cdddr
 124     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
 125     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
 126     struct? struct-vtable
 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     ,@*primitive-constructors*))
 137
 138 ;; Like *effect-free-primitives* above, but further restricted in that they
 139 ;; cannot raise exceptions.
 140 (define *effect+exception-free-primitives*
 141   '(values
 142     eq? eqv? equal?
 143     not
 144     pair? null? list? symbol? vector? acons cons cons*
 145     list vector
 146     struct?))
 147
 148 ;; Primitives that only return one value.
 149 (define *singly-valued-primitives*
 150   '(eq? eqv? equal?
 151     memq memv
 152     = < > <= >= zero?
 153     + * - / 1- 1+ quotient remainder modulo
 154     ash logand logior logxor
 155     not
 156     pair? null? list? symbol? vector? acons cons cons*
 157     list vector
 158     car cdr
 159     set-car! set-cdr!
 160     caar cadr cdar cddr
 161     caaar caadr cadar caddr cdaar cdadr cddar cdddr
 162     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
 163     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
 164     vector-ref vector-set!
 165     variable-ref variable-set!
 166     variable-bound?
 167     fluid-ref fluid-set!
 168     make-prompt-tag
 169     struct? struct-vtable make-struct struct-ref struct-set!
 170     bytevector-u8-ref bytevector-u8-set!
 171     bytevector-s8-ref bytevector-s8-set!
 172     u8vector-ref u8vector-set! s8vector-ref s8vector-set!
 173     bytevector-u16-ref bytevector-u16-set!
 174     bytevector-u16-native-ref bytevector-u16-native-set!
 175     bytevector-s16-ref bytevector-s16-set!
 176     bytevector-s16-native-ref bytevector-s16-native-set!
 177     u16vector-ref u16vector-set! s16vector-ref s16vector-set!
 178     bytevector-u32-ref bytevector-u32-set!
 179     bytevector-u32-native-ref bytevector-u32-native-set!
 180     bytevector-s32-ref bytevector-s32-set!
 181     bytevector-s32-native-ref bytevector-s32-native-set!
 182     u32vector-ref u32vector-set! s32vector-ref s32vector-set!
 183     bytevector-u64-ref bytevector-u64-set!
 184     bytevector-u64-native-ref bytevector-u64-native-set!
 185     bytevector-s64-ref bytevector-s64-set!
 186     bytevector-s64-native-ref bytevector-s64-native-set!
 187     u64vector-ref u64vector-set! s64vector-ref s64vector-set!
 188     bytevector-ieee-single-ref bytevector-ieee-single-set!
 189     bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
 190     bytevector-ieee-double-ref bytevector-ieee-double-set!
 191     bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
 192     f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
 193
 194 (define *effect-free-primitive-table* (make-hash-table))
 195 (define *effect+exceptions-free-primitive-table* (make-hash-table))
 196 (define *singly-valued-primitive-table* (make-hash-table))
 197
 198 (for-each (lambda (x)
 199             (hashq-set! *effect-free-primitive-table* x #t))
 200           *effect-free-primitives*)
 201 (for-each (lambda (x)
 202             (hashq-set! *effect+exceptions-free-primitive-table* x #t))
 203           *effect+exception-free-primitives*)
 204 (for-each (lambda (x)
 205             (hashq-set! *singly-valued-primitive-table* x #t))
 206           *singly-valued-primitives*)
 207
 208 (define (constructor-primitive? prim)
 209   (memq prim *primitive-constructors*))
 210 (define (effect-free-primitive? prim)
 211   (hashq-ref *effect-free-primitive-table* prim))
 212 (define (effect+exception-free-primitive? prim)
 213   (hashq-ref *effect+exceptions-free-primitive-table* prim))
 214 (define (singly-valued-primitive? prim)
 215   (hashq-ref *singly-valued-primitive-table* prim))
 216
 217 (define (resolve-primitives! x mod)
 218   (post-order!
 219    (lambda (x)
 220      (record-case x
 221        ((<toplevel-ref> src name)
 222         (and=> (hashq-ref *interesting-primitive-vars*
 223                           (module-variable mod name))
 224                (lambda (name) (make-primitive-ref src name))))
 225        ((<module-ref> src mod name public?)
 226         ;; for the moment, we're disabling primitive resolution for
 227         ;; public refs because resolve-interface can raise errors.
 228         (let ((m (and (not public?) (resolve-module mod))))
 229           (and m
 230                (and=> (hashq-ref *interesting-primitive-vars*
 231                                  (module-variable m name))
 232                       (lambda (name) (make-primitive-ref src name))))))
 233        (else #f)))
 234    x))
 235
 236 \f
 237
 238 (define *primitive-expand-table* (make-hash-table))
 239
 240 (define (expand-primitives! x)
 241   (pre-order!
 242    (lambda (x)
 243      (record-case x
 244        ((<application> src proc args)
 245         (and (primitive-ref? proc)
 246              (let ((expand (hashq-ref *primitive-expand-table*
 247                                       (primitive-ref-name proc))))
 248                (and expand (apply expand src args)))))
 249        (else #f)))
 250    x))
 251
 252 ;;; I actually did spend about 10 minutes trying to redo this with
 253 ;;; syntax-rules. Patches appreciated.
 254 ;;;
 255 (define-macro (define-primitive-expander sym . clauses)
 256   (define (inline-args args)
 257     (let lp ((in args) (out '()))
 258       (cond ((null? in) `(list ,@(reverse out)))
 259             ((symbol? in) `(cons* ,@(reverse out) ,in))
 260             ((pair? (car in))
 261              (lp (cdr in)
 262                  (cons (if (eq? (caar in) 'quote)
 263                            `(make-const src ,@(cdar in))
 264                            `(make-application src (make-primitive-ref src ',(caar in))
 265                                               ,(inline-args (cdar in))))
 266                        out)))
 267             ((symbol? (car in))
 268              ;; assume it's locally bound
 269              (lp (cdr in) (cons (car in) out)))
 270             ((self-evaluating? (car in))
 271              (lp (cdr in) (cons `(make-const src ,(car in)) out)))
 272             (else
 273              (error "what what" (car in))))))
 274   (define (consequent exp)
 275     (cond
 276      ((pair? exp)
 277       (pmatch exp
 278         ((if ,test ,then ,else)
 279          `(if ,test
 280               ,(consequent then)
 281               ,(consequent else)))
 282         (else
 283          `(make-application src (make-primitive-ref src ',(car exp))
 284                             ,(inline-args (cdr exp))))))
 285      ((symbol? exp)
 286       ;; assume locally bound
 287       exp)
 288      ((number? exp)
 289       `(make-const src ,exp))
 290      ((not exp)
 291       ;; failed match
 292       #f)
 293      (else (error "bad consequent yall" exp))))
 294   `(hashq-set! *primitive-expand-table*
 295                ',sym
 296                (case-lambda
 297                 ,@(let lp ((in clauses) (out '()))
 298                     (if (null? in)
 299                         (reverse (cons '(else #f) out))
 300                         (lp (cddr in)
 301                             (cons `((src . ,(car in))
 302                                     ,(consequent (cadr in))) out)))))))
 303
 304 (define-primitive-expander zero? (x)
 305   (= x 0))
 306
 307 ;; FIXME: All the code that uses `const?' is redundant with `peval'.
 308
 309 (define-primitive-expander +
 310   () 0
 311   (x) (values x)
 312   (x y) (if (and (const? y)
 313                  (let ((y (const-exp y)))
 314                    (and (number? y) (exact? y) (= y 1))))
 315             (1+ x)
 316             (if (and (const? y)
 317                      (let ((y (const-exp y)))
 318                        (and (number? y) (exact? y) (= y -1))))
 319                 (1- x)
 320                 (if (and (const? x)
 321                          (let ((x (const-exp x)))
 322                            (and (number? x) (exact? x) (= x 1))))
 323                     (1+ y)
 324                     (+ x y))))
 325   (x y z . rest) (+ x (+ y z . rest)))
 326
 327 (define-primitive-expander *
 328   () 1
 329   (x) (values x)
 330   (x y z . rest) (* x (* y z . rest)))
 331
 332 (define-primitive-expander -
 333   (x) (- 0 x)
 334   (x y) (if (and (const? y)
 335                  (let ((y (const-exp y)))
 336                    (and (number? y) (exact? y) (= y 1))))
 337             (1- x)
 338             (- x y))
 339   (x y z . rest) (- x (+ y z . rest)))
 340
 341 (define-primitive-expander /
 342   (x) (/ 1 x)
 343   (x y z . rest) (/ x (* y z . rest)))
 344
 345 (define-primitive-expander caar (x) (car (car x)))
 346 (define-primitive-expander cadr (x) (car (cdr x)))
 347 (define-primitive-expander cdar (x) (cdr (car x)))
 348 (define-primitive-expander cddr (x) (cdr (cdr x)))
 349 (define-primitive-expander caaar (x) (car (car (car x))))
 350 (define-primitive-expander caadr (x) (car (car (cdr x))))
 351 (define-primitive-expander cadar (x) (car (cdr (car x))))
 352 (define-primitive-expander caddr (x) (car (cdr (cdr x))))
 353 (define-primitive-expander cdaar (x) (cdr (car (car x))))
 354 (define-primitive-expander cdadr (x) (cdr (car (cdr x))))
 355 (define-primitive-expander cddar (x) (cdr (cdr (car x))))
 356 (define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
 357 (define-primitive-expander caaaar (x) (car (car (car (car x)))))
 358 (define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
 359 (define-primitive-expander caadar (x) (car (car (cdr (car x)))))
 360 (define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
 361 (define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
 362 (define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
 363 (define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
 364 (define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
 365 (define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
 366 (define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
 367 (define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
 368 (define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
 369 (define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
 370 (define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
 371 (define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
 372 (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
 373
 374 (define-primitive-expander cons*
 375   (x) (values x)
 376   (x y) (cons x y)
 377   (x y . rest) (cons x (cons* y . rest)))
 378
 379 (define-primitive-expander acons (x y z)
 380   (cons (cons x y) z))
 381
 382 (define-primitive-expander apply (f a0 . args)
 383   (@apply f a0 . args))
 384
 385 (define-primitive-expander call-with-values (producer consumer)
 386   (@call-with-values producer consumer))
 387
 388 (define-primitive-expander call-with-current-continuation (proc)
 389   (@call-with-current-continuation proc))
 390
 391 (define-primitive-expander call/cc (proc)
 392   (@call-with-current-continuation proc))
 393
 394 (define-primitive-expander make-struct (vtable tail-size . args)
 395   (if (and (const? tail-size)
 396            (let ((n (const-exp tail-size)))
 397              (and (number? n) (exact? n) (zero? n))))
 398       (make-struct/no-tail vtable . args)
 399       #f))
 400
 401 (define-primitive-expander u8vector-ref (vec i)
 402   (bytevector-u8-ref vec i))
 403 (define-primitive-expander u8vector-set! (vec i x)
 404   (bytevector-u8-set! vec i x))
 405 (define-primitive-expander s8vector-ref (vec i)
 406   (bytevector-s8-ref vec i))
 407 (define-primitive-expander s8vector-set! (vec i x)
 408   (bytevector-s8-set! vec i x))
 409
 410 (define-primitive-expander u16vector-ref (vec i)
 411   (bytevector-u16-native-ref vec (* i 2)))
 412 (define-primitive-expander u16vector-set! (vec i x)
 413   (bytevector-u16-native-set! vec (* i 2) x))
 414 (define-primitive-expander s16vector-ref (vec i)
 415   (bytevector-s16-native-ref vec (* i 2)))
 416 (define-primitive-expander s16vector-set! (vec i x)
 417   (bytevector-s16-native-set! vec (* i 2) x))
 418
 419 (define-primitive-expander u32vector-ref (vec i)
 420   (bytevector-u32-native-ref vec (* i 4)))
 421 (define-primitive-expander u32vector-set! (vec i x)
 422   (bytevector-u32-native-set! vec (* i 4) x))
 423 (define-primitive-expander s32vector-ref (vec i)
 424   (bytevector-s32-native-ref vec (* i 4)))
 425 (define-primitive-expander s32vector-set! (vec i x)
 426   (bytevector-s32-native-set! vec (* i 4) x))
 427
 428 (define-primitive-expander u64vector-ref (vec i)
 429   (bytevector-u64-native-ref vec (* i 8)))
 430 (define-primitive-expander u64vector-set! (vec i x)
 431   (bytevector-u64-native-set! vec (* i 8) x))
 432 (define-primitive-expander s64vector-ref (vec i)
 433   (bytevector-s64-native-ref vec (* i 8)))
 434 (define-primitive-expander s64vector-set! (vec i x)
 435   (bytevector-s64-native-set! vec (* i 8) x))
 436
 437 (define-primitive-expander f32vector-ref (vec i)
 438   (bytevector-ieee-single-native-ref vec (* i 4)))
 439 (define-primitive-expander f32vector-set! (vec i x)
 440   (bytevector-ieee-single-native-set! vec (* i 4) x))
 441 (define-primitive-expander f32vector-ref (vec i)
 442   (bytevector-ieee-single-native-ref vec (* i 4)))
 443 (define-primitive-expander f32vector-set! (vec i x)
 444   (bytevector-ieee-single-native-set! vec (* i 4) x))
 445
 446 (define-primitive-expander f64vector-ref (vec i)
 447   (bytevector-ieee-double-native-ref vec (* i 8)))
 448 (define-primitive-expander f64vector-set! (vec i x)
 449   (bytevector-ieee-double-native-set! vec (* i 8) x))
 450 (define-primitive-expander f64vector-ref (vec i)
 451   (bytevector-ieee-double-native-ref vec (* i 8)))
 452 (define-primitive-expander f64vector-set! (vec i x)
 453   (bytevector-ieee-double-native-set! vec (* i 8) x))
 454
 455 (hashq-set! *primitive-expand-table*
 456             'dynamic-wind
 457             (case-lambda
 458               ((src pre thunk post)
 459                ;; Here we will make concessions to the fact that our inliner is
 460                ;; lame, and add a hack.
 461                (cond
 462                 ((lambda? thunk)
 463                  (let ((PRE (gensym " pre"))
 464                        (POST (gensym " post")))
 465                    (make-let
 466                     src
 467                     '(pre post)
 468                     (list PRE POST)
 469                     (list pre post)
 470                     (make-dynwind
 471                      src
 472                      (make-lexical-ref #f 'pre PRE)
 473                      (make-application #f thunk '())
 474                      (make-lexical-ref #f 'post POST)))))
 475                 (else
 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)))