module/language/tree-il/primitives.scm

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