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-length 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 vector-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   (define local-definitions
 236     (make-hash-table))
 237
 238   (let collect-local-definitions ((x x))
 239     (record-case x
 240       ((<toplevel-define> name)
 241        (hashq-set! local-definitions name #t))
 242       ((<seq> head tail)
 243        (collect-local-definitions head)
 244        (collect-local-definitions tail))
 245       (else #f)))
 246
 247   (post-order!
 248    (lambda (x)
 249      (record-case x
 250        ((<toplevel-ref> src name)
 251         (and=> (and (not (hashq-ref local-definitions name))
 252                     (hashq-ref *interesting-primitive-vars*
 253                                (module-variable mod name)))
 254                (lambda (name) (make-primitive-ref src name))))
 255        ((<module-ref> src mod name public?)
 256         ;; for the moment, we're disabling primitive resolution for
 257         ;; public refs because resolve-interface can raise errors.
 258         (let ((m (and (not public?) (resolve-module mod))))
 259           (and m
 260                (and=> (hashq-ref *interesting-primitive-vars*
 261                                  (module-variable m name))
 262                       (lambda (name) (make-primitive-ref src name))))))
 263        ((<call> src proc args)
 264         (and (primitive-ref? proc)
 265              (make-primcall src (primitive-ref-name proc) args)))
 266        (else #f)))
 267    x))
 268
 269 \f
 270
 271 (define *primitive-expand-table* (make-hash-table))
 272
 273 (define (expand-primitives! x)
 274   (pre-order!
 275    (lambda (x)
 276      (record-case x
 277        ((<primcall> src name args)
 278         (let ((expand (hashq-ref *primitive-expand-table* name)))
 279           (and expand (apply expand src args))))
 280        (else #f)))
 281    x))
 282
 283 ;;; I actually did spend about 10 minutes trying to redo this with
 284 ;;; syntax-rules. Patches appreciated.
 285 ;;;
 286 (define-macro (define-primitive-expander sym . clauses)
 287   (define (inline-args args)
 288     (let lp ((in args) (out '()))
 289       (cond ((null? in) `(list ,@(reverse out)))
 290             ((symbol? in) `(cons* ,@(reverse out) ,in))
 291             ((pair? (car in))
 292              (lp (cdr in)
 293                  (cons (if (eq? (caar in) 'quote)
 294                            `(make-const src ,@(cdar in))
 295                            `(make-primcall src ',(caar in)
 296                                            ,(inline-args (cdar in))))
 297                        out)))
 298             ((symbol? (car in))
 299              ;; assume it's locally bound
 300              (lp (cdr in) (cons (car in) out)))
 301             ((self-evaluating? (car in))
 302              (lp (cdr in) (cons `(make-const src ,(car in)) out)))
 303             (else
 304              (error "what what" (car in))))))
 305   (define (consequent exp)
 306     (cond
 307      ((pair? exp)
 308       (pmatch exp
 309         ((if ,test ,then ,else)
 310          `(if ,test
 311               ,(consequent then)
 312               ,(consequent else)))
 313         (else
 314          `(make-primcall src ',(car exp)
 315                          ,(inline-args (cdr exp))))))
 316      ((symbol? exp)
 317       ;; assume locally bound
 318       exp)
 319      ((number? exp)
 320       `(make-const src ,exp))
 321      ((not exp)
 322       ;; failed match
 323       #f)
 324      (else (error "bad consequent yall" exp))))
 325   `(hashq-set! *primitive-expand-table*
 326                ',sym
 327                (case-lambda
 328                 ,@(let lp ((in clauses) (out '()))
 329                     (if (null? in)
 330                         (reverse (cons '(else #f) out))
 331                         (lp (cddr in)
 332                             (cons `((src . ,(car in))
 333                                     ,(consequent (cadr in))) out)))))))
 334
 335 (define-primitive-expander zero? (x)
 336   (= x 0))
 337
 338 ;; FIXME: All the code that uses `const?' is redundant with `peval'.
 339
 340 (define-primitive-expander +
 341   () 0
 342   (x) (values x)
 343   (x y) (if (and (const? y)
 344                  (let ((y (const-exp y)))
 345                    (and (number? y) (exact? y) (= y 1))))
 346             (1+ x)
 347             (if (and (const? y)
 348                      (let ((y (const-exp y)))
 349                        (and (number? y) (exact? y) (= y -1))))
 350                 (1- x)
 351                 (if (and (const? x)
 352                          (let ((x (const-exp x)))
 353                            (and (number? x) (exact? x) (= x 1))))
 354                     (1+ y)
 355                     (+ x y))))
 356   (x y z . rest) (+ x (+ y z . rest)))
 357
 358 (define-primitive-expander *
 359   () 1
 360   (x) (values x)
 361   (x y z . rest) (* x (* y z . rest)))
 362
 363 (define-primitive-expander -
 364   (x) (- 0 x)
 365   (x y) (if (and (const? y)
 366                  (let ((y (const-exp y)))
 367                    (and (number? y) (exact? y) (= y 1))))
 368             (1- x)
 369             (- x y))
 370   (x y z . rest) (- x (+ y z . rest)))
 371
 372 (define-primitive-expander /
 373   (x) (/ 1 x)
 374   (x y z . rest) (/ x (* y z . rest)))
 375
 376 (define-primitive-expander caar (x) (car (car x)))
 377 (define-primitive-expander cadr (x) (car (cdr x)))
 378 (define-primitive-expander cdar (x) (cdr (car x)))
 379 (define-primitive-expander cddr (x) (cdr (cdr x)))
 380 (define-primitive-expander caaar (x) (car (car (car x))))
 381 (define-primitive-expander caadr (x) (car (car (cdr x))))
 382 (define-primitive-expander cadar (x) (car (cdr (car x))))
 383 (define-primitive-expander caddr (x) (car (cdr (cdr x))))
 384 (define-primitive-expander cdaar (x) (cdr (car (car x))))
 385 (define-primitive-expander cdadr (x) (cdr (car (cdr x))))
 386 (define-primitive-expander cddar (x) (cdr (cdr (car x))))
 387 (define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
 388 (define-primitive-expander caaaar (x) (car (car (car (car x)))))
 389 (define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
 390 (define-primitive-expander caadar (x) (car (car (cdr (car x)))))
 391 (define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
 392 (define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
 393 (define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
 394 (define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
 395 (define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
 396 (define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
 397 (define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
 398 (define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
 399 (define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
 400 (define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
 401 (define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
 402 (define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
 403 (define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
 404
 405 (define-primitive-expander cons*
 406   (x) (values x)
 407   (x y) (cons x y)
 408   (x y . rest) (cons x (cons* y . rest)))
 409
 410 (define-primitive-expander acons (x y z)
 411   (cons (cons x y) z))
 412
 413 (define-primitive-expander apply (f a0 . args)
 414   (@apply f a0 . args))
 415
 416 (define-primitive-expander call-with-values (producer consumer)
 417   (@call-with-values producer consumer))
 418
 419 (define-primitive-expander call-with-current-continuation (proc)
 420   (@call-with-current-continuation proc))
 421
 422 (define-primitive-expander call/cc (proc)
 423   (@call-with-current-continuation proc))
 424
 425 (define-primitive-expander make-struct (vtable tail-size . args)
 426   (if (and (const? tail-size)
 427            (let ((n (const-exp tail-size)))
 428              (and (number? n) (exact? n) (zero? n))))
 429       (make-struct/no-tail vtable . args)
 430       #f))
 431
 432 (define-primitive-expander u8vector-ref (vec i)
 433   (bytevector-u8-ref vec i))
 434 (define-primitive-expander u8vector-set! (vec i x)
 435   (bytevector-u8-set! vec i x))
 436 (define-primitive-expander s8vector-ref (vec i)
 437   (bytevector-s8-ref vec i))
 438 (define-primitive-expander s8vector-set! (vec i x)
 439   (bytevector-s8-set! vec i x))
 440
 441 (define-primitive-expander u16vector-ref (vec i)
 442   (bytevector-u16-native-ref vec (* i 2)))
 443 (define-primitive-expander u16vector-set! (vec i x)
 444   (bytevector-u16-native-set! vec (* i 2) x))
 445 (define-primitive-expander s16vector-ref (vec i)
 446   (bytevector-s16-native-ref vec (* i 2)))
 447 (define-primitive-expander s16vector-set! (vec i x)
 448   (bytevector-s16-native-set! vec (* i 2) x))
 449
 450 (define-primitive-expander u32vector-ref (vec i)
 451   (bytevector-u32-native-ref vec (* i 4)))
 452 (define-primitive-expander u32vector-set! (vec i x)
 453   (bytevector-u32-native-set! vec (* i 4) x))
 454 (define-primitive-expander s32vector-ref (vec i)
 455   (bytevector-s32-native-ref vec (* i 4)))
 456 (define-primitive-expander s32vector-set! (vec i x)
 457   (bytevector-s32-native-set! vec (* i 4) x))
 458
 459 (define-primitive-expander u64vector-ref (vec i)
 460   (bytevector-u64-native-ref vec (* i 8)))
 461 (define-primitive-expander u64vector-set! (vec i x)
 462   (bytevector-u64-native-set! vec (* i 8) x))
 463 (define-primitive-expander s64vector-ref (vec i)
 464   (bytevector-s64-native-ref vec (* i 8)))
 465 (define-primitive-expander s64vector-set! (vec i x)
 466   (bytevector-s64-native-set! vec (* i 8) x))
 467
 468 (define-primitive-expander f32vector-ref (vec i)
 469   (bytevector-ieee-single-native-ref vec (* i 4)))
 470 (define-primitive-expander f32vector-set! (vec i x)
 471   (bytevector-ieee-single-native-set! vec (* i 4) x))
 472 (define-primitive-expander f32vector-ref (vec i)
 473   (bytevector-ieee-single-native-ref vec (* i 4)))
 474 (define-primitive-expander f32vector-set! (vec i x)
 475   (bytevector-ieee-single-native-set! vec (* i 4) x))
 476
 477 (define-primitive-expander f64vector-ref (vec i)
 478   (bytevector-ieee-double-native-ref vec (* i 8)))
 479 (define-primitive-expander f64vector-set! (vec i x)
 480   (bytevector-ieee-double-native-set! vec (* i 8) x))
 481 (define-primitive-expander f64vector-ref (vec i)
 482   (bytevector-ieee-double-native-ref vec (* i 8)))
 483 (define-primitive-expander f64vector-set! (vec i x)
 484   (bytevector-ieee-double-native-set! vec (* i 8) x))
 485
 486 (hashq-set! *primitive-expand-table*
 487             '@dynamic-wind
 488             (case-lambda
 489               ((src pre expr post)
 490                (let ((PRE (gensym " pre"))
 491                      (POST (gensym " post")))
 492                  (make-let
 493                   src
 494                   '(pre post)
 495                   (list PRE POST)
 496                   (list pre post)
 497                   (make-dynwind
 498                    src
 499                    (make-lexical-ref #f 'pre PRE)
 500                    (make-call #f (make-lexical-ref #f 'pre PRE) '())
 501                    expr
 502                    (make-call #f (make-lexical-ref #f 'post POST) '())
 503                    (make-lexical-ref #f 'post POST)))))))
 504
 505 (hashq-set! *primitive-expand-table*
 506             'fluid-ref
 507             (case-lambda
 508               ((src fluid) (make-dynref src fluid))
 509               (else #f)))
 510
 511 (hashq-set! *primitive-expand-table*
 512             'fluid-set!
 513             (case-lambda
 514               ((src fluid exp) (make-dynset src fluid exp))
 515               (else #f)))
 516
 517 (hashq-set! *primitive-expand-table*
 518             '@prompt
 519             (case-lambda
 520               ((src tag exp handler)
 521                (let ((args-sym (gensym)))
 522                  (make-prompt
 523                   src tag exp
 524                   ;; If handler itself is a lambda, the inliner can do some
 525                   ;; trickery here.
 526                   (make-lambda-case
 527                    (tree-il-src handler) '() #f 'args #f '() (list args-sym)
 528                    (make-primcall #f 'apply
 529                                   (list handler
 530                                         (make-lexical-ref #f 'args args-sym)))
 531                    #f))))
 532               (else #f)))
 533
 534 (hashq-set! *primitive-expand-table*
 535             'call-with-prompt
 536             (case-lambda
 537               ((src tag thunk handler)
 538                ;; Sigh. Until the inliner does its job, manually inline
 539                ;; (let ((h (lambda ...))) (prompt k x h))
 540                (cond
 541                 ((lambda? handler)
 542                  (let ((args-sym (gensym)))
 543                    (make-prompt
 544                     src tag (make-call #f thunk '())
 545                     ;; If handler itself is a lambda, the inliner can do some
 546                     ;; trickery here.
 547                     (make-lambda-case
 548                      (tree-il-src handler) '() #f 'args #f '() (list args-sym)
 549                      (make-primcall #f 'apply
 550                                     (list handler
 551                                           (make-lexical-ref #f 'args args-sym)))
 552                      #f))))
 553                 (else #f)))
 554               (else #f)))
 555
 556 (hashq-set! *primitive-expand-table*
 557             '@abort
 558             (case-lambda
 559               ((src tag tail-args)
 560                (make-abort src tag '() tail-args))
 561               (else #f)))
 562 (hashq-set! *primitive-expand-table*
 563             'abort-to-prompt
 564             (case-lambda
 565               ((src tag . args)
 566                (make-abort src tag args (make-const #f '())))
 567               (else #f)))