tests/gpgscm/init.scm

   1 ;    Initialization file for TinySCHEME 1.41
   2
   3 ; Per R5RS, up to four deep compositions should be defined
   4 (define (caar x) (car (car x)))
   5 (define (cadr x) (car (cdr x)))
   6 (define (cdar x) (cdr (car x)))
   7 (define (cddr x) (cdr (cdr x)))
   8 (define (caaar x) (car (car (car x))))
   9 (define (caadr x) (car (car (cdr x))))
  10 (define (cadar x) (car (cdr (car x))))
  11 (define (caddr x) (car (cdr (cdr x))))
  12 (define (cdaar x) (cdr (car (car x))))
  13 (define (cdadr x) (cdr (car (cdr x))))
  14 (define (cddar x) (cdr (cdr (car x))))
  15 (define (cdddr x) (cdr (cdr (cdr x))))
  16 (define (caaaar x) (car (car (car (car x)))))
  17 (define (caaadr x) (car (car (car (cdr x)))))
  18 (define (caadar x) (car (car (cdr (car x)))))
  19 (define (caaddr x) (car (car (cdr (cdr x)))))
  20 (define (cadaar x) (car (cdr (car (car x)))))
  21 (define (cadadr x) (car (cdr (car (cdr x)))))
  22 (define (caddar x) (car (cdr (cdr (car x)))))
  23 (define (cadddr x) (car (cdr (cdr (cdr x)))))
  24 (define (cdaaar x) (cdr (car (car (car x)))))
  25 (define (cdaadr x) (cdr (car (car (cdr x)))))
  26 (define (cdadar x) (cdr (car (cdr (car x)))))
  27 (define (cdaddr x) (cdr (car (cdr (cdr x)))))
  28 (define (cddaar x) (cdr (cdr (car (car x)))))
  29 (define (cddadr x) (cdr (cdr (car (cdr x)))))
  30 (define (cdddar x) (cdr (cdr (cdr (car x)))))
  31 (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
  32
  33 ;;;; Utility to ease macro creation
  34 (define (macro-expand form)
  35      ((eval (get-closure-code (eval (car form)))) form))
  36
  37 (define (macro-expand-all form)
  38    (if (macro? form)
  39       (macro-expand-all (macro-expand form))
  40       form))
  41
  42 (define *compile-hook* macro-expand-all)
  43
  44
  45 (macro (unless form)
  46      `(if (not ,(cadr form)) (begin ,@(cddr form))))
  47
  48 (macro (when form)
  49      `(if ,(cadr form) (begin ,@(cddr form))))
  50
  51 ; DEFINE-MACRO Contributed by Andy Gaynor
  52 (macro (define-macro dform)
  53   (if (symbol? (cadr dform))
  54     `(macro ,@(cdr dform))
  55     (let ((form (gensym)))
  56       `(macro (,(caadr dform) ,form)
  57          (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
  58
  59 ; Utilities for math. Notice that inexact->exact is primitive,
  60 ; but exact->inexact is not.
  61 (define exact? integer?)
  62 (define (inexact? x) (and (real? x) (not (integer? x))))
  63 (define (even? n) (= (remainder n 2) 0))
  64 (define (odd? n) (not (= (remainder n 2) 0)))
  65 (define (zero? n) (= n 0))
  66 (define (positive? n) (> n 0))
  67 (define (negative? n) (< n 0))
  68 (define complex? number?)
  69 (define rational? real?)
  70 (define (abs n) (if (>= n 0) n (- n)))
  71 (define (exact->inexact n) (* n 1.0))
  72 (define (<> n1 n2) (not (= n1 n2)))
  73
  74 ; min and max must return inexact if any arg is inexact; use (+ n 0.0)
  75 (define (max . lst)
  76   (foldr (lambda (a b)
  77            (if (> a b)
  78              (if (exact? b) a (+ a 0.0))
  79              (if (exact? a) b (+ b 0.0))))
  80          (car lst) (cdr lst)))
  81 (define (min . lst)
  82   (foldr (lambda (a b)
  83            (if (< a b)
  84              (if (exact? b) a (+ a 0.0))
  85              (if (exact? a) b (+ b 0.0))))
  86          (car lst) (cdr lst)))
  87
  88 (define (succ x) (+ x 1))
  89 (define (pred x) (- x 1))
  90 (define gcd
  91   (lambda a
  92     (if (null? a)
  93       0
  94       (let ((aa (abs (car a)))
  95             (bb (abs (cadr a))))
  96          (if (= bb 0)
  97               aa
  98               (gcd bb (remainder aa bb)))))))
  99 (define lcm
 100   (lambda a
 101     (if (null? a)
 102       1
 103       (let ((aa (abs (car a)))
 104             (bb (abs (cadr a))))
 105          (if (or (= aa 0) (= bb 0))
 106              0
 107              (abs (* (quotient aa (gcd aa bb)) bb)))))))
 108
 109
 110 (define (string . charlist)
 111      (list->string charlist))
 112
 113 (define (list->string charlist)
 114      (let* ((len (length charlist))
 115             (newstr (make-string len))
 116             (fill-string!
 117                (lambda (str i len charlist)
 118                     (if (= i len)
 119                          str
 120                          (begin (string-set! str i (car charlist))
 121                          (fill-string! str (+ i 1) len (cdr charlist)))))))
 122           (fill-string! newstr 0 len charlist)))
 123
 124 (define (string-fill! s e)
 125      (let ((n (string-length s)))
 126           (let loop ((i 0))
 127                (if (= i n)
 128                     s
 129                     (begin (string-set! s i e) (loop (succ i)))))))
 130
 131 (define (string->list s)
 132      (let loop ((n (pred (string-length s))) (l '()))
 133           (if (= n -1)
 134                l
 135                (loop (pred n) (cons (string-ref s n) l)))))
 136
 137 (define (string-copy str)
 138      (string-append str))
 139
 140 (define (string->anyatom str pred)
 141      (let* ((a (string->atom str)))
 142        (if (pred a) a
 143          (error "string->xxx: not a xxx" a))))
 144
 145 (define (string->number str . base)
 146     (let ((n (string->atom str (if (null? base) 10 (car base)))))
 147         (if (number? n) n #f)))
 148
 149 (define (anyatom->string n pred)
 150   (if (pred n)
 151       (atom->string n)
 152       (error "xxx->string: not a xxx" n)))
 153
 154 (define (number->string n . base)
 155     (atom->string n (if (null? base) 10 (car base))))
 156
 157
 158 (define (char-cmp? cmp a b)
 159      (cmp (char->integer a) (char->integer b)))
 160 (define (char-ci-cmp? cmp a b)
 161      (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
 162
 163 (define (char=? a b) (char-cmp? = a b))
 164 (define (char<? a b) (char-cmp? < a b))
 165 (define (char>? a b) (char-cmp? > a b))
 166 (define (char<=? a b) (char-cmp? <= a b))
 167 (define (char>=? a b) (char-cmp? >= a b))
 168
 169 (define (char-ci=? a b) (char-ci-cmp? = a b))
 170 (define (char-ci<? a b) (char-ci-cmp? < a b))
 171 (define (char-ci>? a b) (char-ci-cmp? > a b))
 172 (define (char-ci<=? a b) (char-ci-cmp? <= a b))
 173 (define (char-ci>=? a b) (char-ci-cmp? >= a b))
 174
 175 ; Note the trick of returning (cmp x y)
 176 (define (string-cmp? chcmp cmp a b)
 177      (let ((na (string-length a)) (nb (string-length b)))
 178           (let loop ((i 0))
 179                (cond
 180                     ((= i na)
 181                          (if (= i nb) (cmp 0 0) (cmp 0 1)))
 182                     ((= i nb)
 183                          (cmp 1 0))
 184                     ((chcmp = (string-ref a i) (string-ref b i))
 185                          (loop (succ i)))
 186                     (else
 187                          (chcmp cmp (string-ref a i) (string-ref b i)))))))
 188
 189
 190 (define (string=? a b) (string-cmp? char-cmp? = a b))
 191 (define (string<? a b) (string-cmp? char-cmp? < a b))
 192 (define (string>? a b) (string-cmp? char-cmp? > a b))
 193 (define (string<=? a b) (string-cmp? char-cmp? <= a b))
 194 (define (string>=? a b) (string-cmp? char-cmp? >= a b))
 195
 196 (define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
 197 (define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
 198 (define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
 199 (define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
 200 (define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
 201
 202 (define (list . x) x)
 203
 204 (define (foldr f x lst)
 205      (if (null? lst)
 206           x
 207           (foldr f (f x (car lst)) (cdr lst))))
 208
 209 (define (unzip1-with-cdr . lists)
 210   (unzip1-with-cdr-iterative lists '() '()))
 211
 212 (define (unzip1-with-cdr-iterative lists cars cdrs)
 213   (if (null? lists)
 214       (cons cars cdrs)
 215       (let ((car1 (caar lists))
 216             (cdr1 (cdar lists)))
 217         (unzip1-with-cdr-iterative
 218           (cdr lists)
 219           (append cars (list car1))
 220           (append cdrs (list cdr1))))))
 221
 222 (define (map proc . lists)
 223   (if (null? lists)
 224       (apply proc)
 225       (if (null? (car lists))
 226         '()
 227         (let* ((unz (apply unzip1-with-cdr lists))
 228                (cars (car unz))
 229                (cdrs (cdr unz)))
 230           (cons (apply proc cars) (apply map (cons proc cdrs)))))))
 231
 232 (define (for-each proc . lists)
 233   (if (null? lists)
 234       (apply proc)
 235       (if (null? (car lists))
 236         #t
 237         (let* ((unz (apply unzip1-with-cdr lists))
 238                (cars (car unz))
 239                (cdrs (cdr unz)))
 240           (apply proc cars) (apply map (cons proc cdrs))))))
 241
 242 (define (list-tail x k)
 243     (if (zero? k)
 244         x
 245         (list-tail (cdr x) (- k 1))))
 246
 247 (define (list-ref x k)
 248     (car (list-tail x k)))
 249
 250 (define (last-pair x)
 251     (if (pair? (cdr x))
 252         (last-pair (cdr x))
 253         x))
 254
 255 (define (head stream) (car stream))
 256
 257 (define (tail stream) (force (cdr stream)))
 258
 259 (define (vector-equal? x y)
 260      (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
 261           (let ((n (vector-length x)))
 262                (let loop ((i 0))
 263                     (if (= i n)
 264                          #t
 265                          (and (equal? (vector-ref x i) (vector-ref y i))
 266                               (loop (succ i))))))))
 267
 268 (define (list->vector x)
 269      (apply vector x))
 270
 271 (define (vector-fill! v e)
 272      (let ((n (vector-length v)))
 273           (let loop ((i 0))
 274                (if (= i n)
 275                     v
 276                     (begin (vector-set! v i e) (loop (succ i)))))))
 277
 278 (define (vector->list v)
 279      (let loop ((n (pred (vector-length v))) (l '()))
 280           (if (= n -1)
 281                l
 282                (loop (pred n) (cons (vector-ref v n) l)))))
 283
 284 ;; The following quasiquote macro is due to Eric S. Tiedemann.
 285 ;;   Copyright 1988 by Eric S. Tiedemann; all rights reserved.
 286 ;;
 287 ;; Subsequently modified to handle vectors: D. Souflis
 288
 289 (macro
 290  quasiquote
 291  (lambda (l)
 292    (define (mcons f l r)
 293      (if (and (pair? r)
 294               (eq? (car r) 'quote)
 295               (eq? (car (cdr r)) (cdr f))
 296               (pair? l)
 297               (eq? (car l) 'quote)
 298               (eq? (car (cdr l)) (car f)))
 299          (if (or (procedure? f) (number? f) (string? f))
 300                f
 301                (list 'quote f))
 302          (if (eqv? l vector)
 303                (apply l (eval r))
 304                (list 'cons l r)
 305                )))
 306    (define (mappend f l r)
 307      (if (or (null? (cdr f))
 308              (and (pair? r)
 309                   (eq? (car r) 'quote)
 310                   (eq? (car (cdr r)) '())))
 311          l
 312          (list 'append l r)))
 313    (define (foo level form)
 314      (cond ((not (pair? form))
 315                (if (or (procedure? form) (number? form) (string? form))
 316                     form
 317                     (list 'quote form))
 318                )
 319            ((eq? 'quasiquote (car form))
 320             (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
 321            (#t (if (zero? level)
 322                    (cond ((eq? (car form) 'unquote) (car (cdr form)))
 323                          ((eq? (car form) 'unquote-splicing)
 324                           (error "Unquote-splicing wasn't in a list:"
 325                                  form))
 326                          ((and (pair? (car form))
 327                                (eq? (car (car form)) 'unquote-splicing))
 328                           (mappend form (car (cdr (car form)))
 329                                    (foo level (cdr form))))
 330                          (#t (mcons form (foo level (car form))
 331                                          (foo level (cdr form)))))
 332                    (cond ((eq? (car form) 'unquote)
 333                           (mcons form ''unquote (foo (- level 1)
 334                                                      (cdr form))))
 335                          ((eq? (car form) 'unquote-splicing)
 336                           (mcons form ''unquote-splicing
 337                                       (foo (- level 1) (cdr form))))
 338                          (#t (mcons form (foo level (car form))
 339                                          (foo level (cdr form)))))))))
 340    (foo 0 (car (cdr l)))))
 341
 342 ;;;;;Helper for the dynamic-wind definition.  By Tom Breton (Tehom)
 343 (define (shared-tail x y)
 344    (let ((len-x (length x))
 345          (len-y (length y)))
 346       (define (shared-tail-helper x y)
 347          (if
 348             (eq? x y)
 349             x
 350             (shared-tail-helper (cdr x) (cdr y))))
 351
 352       (cond
 353          ((> len-x len-y)
 354             (shared-tail-helper
 355                (list-tail x (- len-x len-y))
 356                y))
 357          ((< len-x len-y)
 358             (shared-tail-helper
 359                x
 360                (list-tail y (- len-y len-x))))
 361          (#t (shared-tail-helper x y)))))
 362
 363 ;;;;;Dynamic-wind by Tom Breton (Tehom)
 364
 365 ;;Guarded because we must only eval this once, because doing so
 366 ;;redefines call/cc in terms of old call/cc
 367 (unless (defined? 'dynamic-wind)
 368    (let
 369       ;;These functions are defined in the context of a private list of
 370       ;;pairs of before/after procs.
 371       (  (*active-windings* '())
 372          ;;We'll define some functions into the larger environment, so
 373          ;;we need to know it.
 374          (outer-env (current-environment)))
 375
 376       ;;Poor-man's structure operations
 377       (define before-func car)
 378       (define after-func  cdr)
 379       (define make-winding cons)
 380
 381       ;;Manage active windings
 382       (define (activate-winding! new)
 383          ((before-func new))
 384          (set! *active-windings* (cons new *active-windings*)))
 385       (define (deactivate-top-winding!)
 386          (let ((old-top (car *active-windings*)))
 387             ;;Remove it from the list first so it's not active during its
 388             ;;own exit.
 389             (set! *active-windings* (cdr *active-windings*))
 390             ((after-func old-top))))
 391
 392       (define (set-active-windings! new-ws)
 393          (unless (eq? new-ws *active-windings*)
 394             (let ((shared (shared-tail new-ws *active-windings*)))
 395
 396                ;;Define the looping functions.
 397                ;;Exit the old list.  Do deeper ones last.  Don't do
 398                ;;any shared ones.
 399                (define (pop-many)
 400                   (unless (eq? *active-windings* shared)
 401                      (deactivate-top-winding!)
 402                      (pop-many)))
 403                ;;Enter the new list.  Do deeper ones first so that the
 404                ;;deeper windings will already be active.  Don't do any
 405                ;;shared ones.
 406                (define (push-many new-ws)
 407                   (unless (eq? new-ws shared)
 408                      (push-many (cdr new-ws))
 409                      (activate-winding! (car new-ws))))
 410
 411                ;;Do it.
 412                (pop-many)
 413                (push-many new-ws))))
 414
 415       ;;The definitions themselves.
 416       (eval
 417          `(define call-with-current-continuation
 418              ;;It internally uses the built-in call/cc, so capture it.
 419              ,(let ((old-c/cc call-with-current-continuation))
 420                  (lambda (func)
 421                     ;;Use old call/cc to get the continuation.
 422                     (old-c/cc
 423                        (lambda (continuation)
 424                           ;;Call func with not the continuation itself
 425                           ;;but a procedure that adjusts the active
 426                           ;;windings to what they were when we made
 427                           ;;this, and only then calls the
 428                           ;;continuation.
 429                           (func
 430                              (let ((current-ws *active-windings*))
 431                                 (lambda (x)
 432                                    (set-active-windings! current-ws)
 433                                    (continuation x)))))))))
 434          outer-env)
 435       ;;We can't just say "define (dynamic-wind before thunk after)"
 436       ;;because the lambda it's defined to lives in this environment,
 437       ;;not in the global environment.
 438       (eval
 439          `(define dynamic-wind
 440              ,(lambda (before thunk after)
 441                  ;;Make a new winding
 442                  (activate-winding! (make-winding before after))
 443                  (let ((result (thunk)))
 444                     ;;Get rid of the new winding.
 445                     (deactivate-top-winding!)
 446                     ;;The return value is that of thunk.
 447                     result)))
 448          outer-env)))
 449
 450 (define call/cc call-with-current-continuation)
 451
 452
 453 ;;;;; atom? and equal? written by a.k
 454
 455 ;;;; atom?
 456 (define (atom? x)
 457   (not (pair? x)))
 458
 459 ;;;;    equal?
 460 (define (equal? x y)
 461      (cond
 462           ((pair? x)
 463                (and (pair? y)
 464                     (equal? (car x) (car y))
 465                     (equal? (cdr x) (cdr y))))
 466           ((vector? x)
 467                (and (vector? y) (vector-equal? x y)))
 468           ((string? x)
 469                (and (string? y) (string=? x y)))
 470           (else (eqv? x y))))
 471
 472 ;;;; (do ((var init inc) ...) (endtest result ...) body ...)
 473 ;;
 474 (macro do
 475   (lambda (do-macro)
 476     (apply (lambda (do vars endtest . body)
 477              (let ((do-loop (gensym)))
 478                `(letrec ((,do-loop
 479                            (lambda ,(map (lambda (x)
 480                                            (if (pair? x) (car x) x))
 481                                       `,vars)
 482                              (if ,(car endtest)
 483                                (begin ,@(cdr endtest))
 484                                (begin
 485                                  ,@body
 486                                  (,do-loop
 487                                    ,@(map (lambda (x)
 488                                             (cond
 489                                               ((not (pair? x)) x)
 490                                               ((< (length x) 3) (car x))
 491                                               (else (car (cdr (cdr x))))))
 492                                        `,vars)))))))
 493                   (,do-loop
 494                     ,@(map (lambda (x)
 495                              (if (and (pair? x) (cdr x))
 496                                (car (cdr x))
 497                                '()))
 498                         `,vars)))))
 499       do-macro)))
 500
 501 ;;;; generic-member
 502 (define (generic-member cmp obj lst)
 503   (cond
 504     ((null? lst) #f)
 505     ((cmp obj (car lst)) lst)
 506     (else (generic-member cmp obj (cdr lst)))))
 507
 508 (define (memq obj lst)
 509      (generic-member eq? obj lst))
 510 (define (memv obj lst)
 511      (generic-member eqv? obj lst))
 512 (define (member obj lst)
 513      (generic-member equal? obj lst))
 514
 515 ;;;; generic-assoc
 516 (define (generic-assoc cmp obj alst)
 517      (cond
 518           ((null? alst) #f)
 519           ((cmp obj (caar alst)) (car alst))
 520           (else (generic-assoc cmp obj (cdr alst)))))
 521
 522 (define (assq obj alst)
 523      (generic-assoc eq? obj alst))
 524 (define (assv obj alst)
 525      (generic-assoc eqv? obj alst))
 526 (define (assoc obj alst)
 527      (generic-assoc equal? obj alst))
 528
 529 (define (acons x y z) (cons (cons x y) z))
 530
 531 ;;;; Handy for imperative programs
 532 ;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
 533 (macro (define-with-return form)
 534      `(define ,(cadr form)
 535           (call/cc (lambda (return) ,@(cddr form)))))
 536
 537 ;; Print the given history.
 538 (define (vm-history-print history)
 539   (let loop ((n 0) (skip 0) (frames history))
 540     (cond
 541      ((null? frames)
 542       #t)
 543      ((> skip 0)
 544       (loop 0 (- skip 1) (cdr frames)))
 545      (else
 546       (let ((f (car frames)))
 547         (display n)
 548         (display ": ")
 549         (let ((tag (get-tag f)))
 550           (unless (null? tag)
 551                   (display (basename (car tag)))
 552                   (display ":")
 553                   (display (+ 1 (cdr tag)))
 554                   (display ": ")))
 555         (write f))
 556         (newline)
 557         (loop (+ n 1) skip (cdr frames))))))
 558
 559 ;;;; Simple exception handling
 560 ;
 561 ;    Exceptions are caught as follows:
 562 ;
 563 ;         (catch (do-something to-recover and-return meaningful-value)
 564 ;              (if-something goes-wrong)
 565 ;              (with-these calls))
 566 ;
 567 ;    "Catch" establishes a scope spanning multiple call-frames until
 568 ;    another "catch" is encountered.  Within the recovery expression
 569 ;    the thrown exception is bound to *error*.  Errors can be rethrown
 570 ;    using (rethrow *error*).
 571 ;
 572 ;    Exceptions are thrown with:
 573 ;
 574 ;         (throw "message")
 575 ;
 576 ;    If used outside a (catch ...), reverts to (error "message")
 577
 578 (define *handlers* (list))
 579
 580 (define (push-handler proc)
 581      (set! *handlers* (cons proc *handlers*)))
 582
 583 (define (pop-handler)
 584      (let ((h (car *handlers*)))
 585           (set! *handlers* (cdr *handlers*))
 586           h))
 587
 588 (define (more-handlers?)
 589      (pair? *handlers*))
 590
 591 ;; This throws an exception.
 592 (define (throw message . args)
 593   (throw' message args (cdr (*vm-history*))))
 594
 595 ;; This is used by the vm to throw exceptions.
 596 (define (throw' message args history)
 597   (cond
 598    ((more-handlers?)
 599     ((pop-handler) message args history))
 600    ((and args (list? args) (= 2 (length args))
 601          (equal? *interpreter-exit* (car args)))
 602     (*run-atexit-handlers*)
 603     (quit (cadr args)))
 604    (else
 605     (display message)
 606     (if args (begin
 607               (display ": ")
 608               (write args)))
 609     (newline)
 610     (vm-history-print history)
 611     (quit 1))))
 612
 613 ;; Convenience function to rethrow the error.
 614 (define (rethrow e)
 615   (apply throw' e))
 616
 617 (macro (catch form)
 618      (let ((label (gensym)))
 619           `(call/cc (lambda (**exit**)
 620                (push-handler (lambda *error* (**exit** ,(cadr form))))
 621                (let ((,label (begin ,@(cddr form))))
 622                     (pop-handler)
 623                     ,label)))))
 624
 625 ;; Make the vm use throw'.
 626 (define *error-hook* throw')
 627
 628 \f
 629
 630 ;; High-level mechanism to terminate the process is to throw an error
 631 ;; of the form (*interpreter-exit* status).  This gives automatic
 632 ;; resource management a chance to clean up.
 633 (define *interpreter-exit* (gensym))
 634
 635 ;; Terminate the process returning STATUS to the parent.
 636 (define (exit status)
 637   (throw "interpreter exit" *interpreter-exit* status))
 638
 639 ;; A list of functions run at interpreter shutdown.
 640 (define *atexit-handlers* (list))
 641
 642 ;; Execute all these functions.
 643 (define (*run-atexit-handlers*)
 644   (unless (null? *atexit-handlers*)
 645           (let ((proc (car *atexit-handlers*)))
 646             ;; Drop proc from the list so that it will not get
 647             ;; executed again even if it raises an exception.
 648             (set! *atexit-handlers* (cdr *atexit-handlers*))
 649             (proc)
 650             (*run-atexit-handlers*))))
 651
 652 ;; Register a function to be run at interpreter shutdown.
 653 (define (atexit proc)
 654   (set! *atexit-handlers* (cons proc *atexit-handlers*)))
 655
 656 \f
 657
 658 ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
 659
 660 (macro (make-environment form)
 661      `(apply (lambda ()
 662                ,@(cdr form)
 663                (current-environment))))
 664
 665 (define-macro (eval-polymorphic x . envl)
 666   (display envl)
 667   (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
 668          (xval (eval x env)))
 669     (if (closure? xval)
 670       (make-closure (get-closure-code xval) env)
 671       xval)))
 672
 673 ; Redefine this if you install another package infrastructure
 674 ; Also redefine 'package'
 675 (define *colon-hook* eval)
 676
 677 (macro (package form)
 678   `(apply (lambda ()
 679             ,@(cdr form)
 680             (current-environment))))
 681
 682 ;;;;; I/O
 683
 684 (define (input-output-port? p)
 685      (and (input-port? p) (output-port? p)))
 686
 687 (define (close-port p)
 688      (cond
 689           ((input-output-port? p) (close-input-port p) (close-output-port p))
 690           ((input-port? p) (close-input-port p))
 691           ((output-port? p) (close-output-port p))
 692           (else (throw "Not a port" p))))
 693
 694 (define (call-with-input-file s p)
 695      (let ((inport (open-input-file s)))
 696           (if (eq? inport #f)
 697                #f
 698                (let ((res (p inport)))
 699                     (close-input-port inport)
 700                     res))))
 701
 702 (define (call-with-output-file s p)
 703      (let ((outport (open-output-file s)))
 704           (if (eq? outport #f)
 705                #f
 706                (let ((res (p outport)))
 707                     (close-output-port outport)
 708                     res))))
 709
 710 (define (with-input-from-file s p)
 711      (let ((inport (open-input-file s)))
 712           (if (eq? inport #f)
 713                #f
 714                (let ((prev-inport (current-input-port)))
 715                     (set-input-port inport)
 716                     (let ((res (p)))
 717                          (close-input-port inport)
 718                          (set-input-port prev-inport)
 719                          res)))))
 720
 721 (define (with-output-to-file s p)
 722      (let ((outport (open-output-file s)))
 723           (if (eq? outport #f)
 724                #f
 725                (let ((prev-outport (current-output-port)))
 726                     (set-output-port outport)
 727                     (let ((res (p)))
 728                          (close-output-port outport)
 729                          (set-output-port prev-outport)
 730                          res)))))
 731
 732 (define (with-input-output-from-to-files si so p)
 733      (let ((inport (open-input-file si))
 734            (outport (open-input-file so)))
 735           (if (not (and inport outport))
 736                (begin
 737                     (close-input-port inport)
 738                     (close-output-port outport)
 739                     #f)
 740                (let ((prev-inport (current-input-port))
 741                      (prev-outport (current-output-port)))
 742                     (set-input-port inport)
 743                     (set-output-port outport)
 744                     (let ((res (p)))
 745                          (close-input-port inport)
 746                          (close-output-port outport)
 747                          (set-input-port prev-inport)
 748                          (set-output-port prev-outport)
 749                          res)))))
 750
 751 ; Random number generator (maximum cycle)
 752 (define *seed* 1)
 753 (define (random-next)
 754      (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
 755           (set! *seed*
 756                (-   (* a (- *seed*
 757                          (* (quotient *seed* q) q)))
 758                     (* (quotient *seed* q) r)))
 759           (if (< *seed* 0) (set! *seed* (+ *seed* m)))
 760           *seed*))
 761 ;; SRFI-0
 762 ;; COND-EXPAND
 763 ;; Implemented as a macro
 764 (define *features* '(srfi-0 tinyscheme))
 765
 766 (define-macro (cond-expand . cond-action-list)
 767   (cond-expand-runtime cond-action-list))
 768
 769 (define (cond-expand-runtime cond-action-list)
 770   (if (null? cond-action-list)
 771       #t
 772       (if (cond-eval (caar cond-action-list))
 773           `(begin ,@(cdar cond-action-list))
 774           (cond-expand-runtime (cdr cond-action-list)))))
 775
 776 (define (cond-eval-and cond-list)
 777   (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
 778
 779 (define (cond-eval-or cond-list)
 780   (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
 781
 782 (define (cond-eval condition)
 783   (cond
 784     ((symbol? condition)
 785        (if (member condition *features*) #t #f))
 786     ((eq? condition #t) #t)
 787     ((eq? condition #f) #f)
 788     (else (case (car condition)
 789             ((and) (cond-eval-and (cdr condition)))
 790             ((or) (cond-eval-or (cdr condition)))
 791             ((not) (if (not (null? (cddr condition)))
 792                      (error "cond-expand : 'not' takes 1 argument")
 793                      (not (cond-eval (cadr condition)))))
 794             (else (error "cond-expand : unknown operator" (car condition)))))))
 795
 796 (gc-verbose #f)