module/language/tree-il/primitives.scm

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