"Fossies" - the Fresh Open Source Software Archive

Member "scm/Init5f3.scm" (16 Feb 2020, 52437 Bytes) of package /linux/privat/scm-5f3.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 ;;;; "Init.scm", Scheme initialization code for SCM.
    2 ;; Copyright (C) 1991-2008 Free Software Foundation, Inc.
    3 ;;
    4 ;; This program is free software: you can redistribute it and/or modify
    5 ;; it under the terms of the GNU Lesser General Public License as
    6 ;; published by the Free Software Foundation, either version 3 of the
    7 ;; License, or (at your option) any later version.
    8 ;;
    9 ;; This program is distributed in the hope that it will be useful, but
   10 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
   11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   12 ;; Lesser General Public License for more details.
   13 ;;
   14 ;; You should have received a copy of the GNU Lesser General Public
   15 ;; License along with this program.  If not, see
   16 ;; <http://www.gnu.org/licenses/>.
   17 
   18 ;;; Author: Aubrey Jaffer.
   19 
   20 (define (scheme-implementation-type) 'scm)
   21 (define (scheme-implementation-version) "5f3")
   22 (define (scheme-implementation-home-page)
   23   "http://people.csail.mit.edu/jaffer/SCM")
   24 
   25 ;@
   26 (define in-vicinity string-append)
   27 ;@
   28 (define (user-vicinity)
   29   (case (software-type)
   30     ((vms)  "[.]")
   31     (else   "")))
   32 ;@
   33 (define vicinity:suffix?
   34   (let ((suffi
   35      (case (software-type)
   36        ((amiga)             '(#\: #\/))
   37        ((macos thinkc)          '(#\:))
   38        ((ms-dos windows atarist os/2)   '(#\\ #\/))
   39        ((nosve)             '(#\: #\.))
   40        ((unix coherent plan9)       '(#\/))
   41        ((vms)               '(#\: #\]))
   42        (else
   43         (slib:warn "require.scm" 'unknown 'software-type (software-type))
   44         "/"))))
   45     (lambda (chr) (and (memv chr suffi) #t))))
   46 ;@
   47 (define (pathname->vicinity pathname)
   48   (let loop ((i (- (string-length pathname) 1)))
   49     (cond ((negative? i) "")
   50       ((vicinity:suffix? (string-ref pathname i))
   51        (substring pathname 0 (+ i 1)))
   52       (else (loop (- i 1))))))
   53 (define (program-vicinity)
   54   (if *load-pathname*
   55       (pathname->vicinity *load-pathname*)
   56       (slib:error 'program-vicinity " called; use slib:load to load")))
   57 ;@
   58 (define sub-vicinity
   59   (case (software-type)
   60     ((vms) (lambda
   61            (vic name)
   62          (let ((l (string-length vic)))
   63            (if (or (zero? (string-length vic))
   64                (not (char=? #\] (string-ref vic (- l 1)))))
   65            (string-append vic "[" name "]")
   66            (string-append (substring vic 0 (- l 1))
   67                   "." name "]")))))
   68     (else (let ((*vicinity-suffix*
   69          (case (software-type)
   70            ((nosve) ".")
   71            ((macos thinkc) ":")
   72            ((ms-dos windows atarist os/2) "\\")
   73            ((unix coherent plan9 amiga) "/"))))
   74         (lambda (vic name)
   75           (string-append vic name *vicinity-suffix*))))))
   76 ;@
   77 (define (make-vicinity <pathname>) <pathname>)
   78 ;@
   79 (define with-load-pathname
   80   (let ((exchange
   81      (lambda (new)
   82        (let ((old *load-pathname*))
   83          (set! *load-pathname* new)
   84          old))))
   85     (lambda (path thunk)
   86       (let ((old #f))
   87     (dynamic-wind
   88         (lambda () (set! old (exchange path)))
   89         thunk
   90         (lambda () (exchange old)))))))
   91 
   92 (define slib:features
   93   (append '(ed getenv tmpnam abort transcript with-file
   94            ieee-p1178 rev4-report rev4-optional-procedures
   95            hash object-hash delay dynamic-wind fluid-let
   96            multiarg-apply multiarg/and- logical defmacro
   97            string-port source current-time sharp:semi
   98            math-integer ;math-real and srfi-94 provided in "Transcen.scm"
   99            vicinity srfi-59 srfi-96 srfi-23
  100            srfi-60)         ;logical
  101       (if (defined? *features*) *features* slib:features)))
  102 (if (defined? *features*) (set! *features* slib:features))
  103 
  104 (define eval
  105   (let ((@eval @eval)
  106     (@copy-tree @copy-tree))
  107     (lambda (x) (@eval (@copy-tree x)))))
  108 
  109 (define (exec-self)
  110   (require 'i/o-extensions)
  111   (execv (execpath) (if *script*
  112             (cons (car (program-arguments))
  113                   (cons "\\"
  114                     (member *script* (program-arguments))))
  115             (program-arguments))))
  116 
  117 (define (display-file file . port)
  118   (call-with-input-file file
  119     (lambda (inport)
  120       (do ((c (read-char inport) (read-char inport)))
  121       ((eof-object? c))
  122     (apply write-char c port)))))
  123 (define (terms)
  124   (display-file (in-vicinity (implementation-vicinity) "COPYING")))
  125 
  126 ;;; Read integer up to first non-digit
  127 (define (read:try-number port . ic)
  128   (define chr0 (char->integer #\0))
  129   (let loop ((arg (and (not (null? ic)) (- (char->integer (car ic)) chr0))))
  130     (let ((c (peek-char port)))
  131       (cond ((eof-object? c) #f)
  132         ((char-numeric? c)
  133          (loop (+ (* 10 (or arg 0))
  134               (- (char->integer (read-char port)) chr0))))
  135         (else arg)))))
  136 
  137 (define (read-array-type port)
  138   (define (bomb pc wid)
  139     (error 'array 'syntax? (symbol-append "#" rank "A" pc wid)))
  140   (case (char-downcase (peek-char port))
  141     ((#\:) (read-char port)
  142      (let ((typ (let loop ((arg '()))
  143           (if (= 4 (length arg))
  144               (string->symbol (list->string (reverse arg)))
  145               (let ((c (read-char port)))
  146             (and (not (eof-object? c))
  147                  (loop (cons (char-downcase c) arg))))))))
  148        (define wid (and typ (not (eq? 'bool typ)) (read:try-number port)))
  149        (define (check-suffix chrs)
  150      (define chr (read-char port))
  151      (if (and (char? chr) (not (memv (char-downcase chr) chrs)))
  152          (error 'array-type? (symbol-append ":" typ wid chr))))
  153        (define prot (assq typ '((floc (128 . +64.0i)
  154                       (64  . +64.0i)
  155                       (32  . +32.0i)
  156                       (16  . +32.0i))
  157                 (flor (128 . 64.0)
  158                       (64  . 64.0)
  159                       (32  . 32.0)
  160                       (16  . 32.0))
  161                 (fixz (64 . -64)
  162                       (32 . -32)
  163                       (16 . -16)
  164                       (8  . -8))
  165                 (fixn (64 . 64)
  166                       (32 . 32)
  167                       (16 . 16)
  168                       (8  . 8))
  169                 (char . #\a)
  170                 (bool . #t))))
  171        (if prot (set! prot (cdr prot)))
  172        (cond ((pair? prot)
  173           (set! prot (assv wid (cdr prot)))
  174           (if (pair? prot) (set! prot (cdr prot)))
  175           (if wid (check-suffix (if (and (inexact? prot) (real? prot))
  176                     '(#\b #\d)
  177                     '(#\b)))))
  178          (prot)
  179          (else (check-suffix '())))
  180        prot))
  181     ((#\\) (read-char port) #\a)
  182     ((#\t) (read-char port) #t)
  183     ((#\c #\r) (let* ((pc (read-char port)) (wid (read:try-number port)))
  184          (case wid
  185            ((64 32) (case pc
  186                   ((#\c) (* +i wid))
  187                   (else (exact->inexact wid))))
  188            (else (bomb pc wid)))))
  189     ((#\s #\u) (let* ((pc (read-char port)) (wid (read:try-number port)))
  190          (case (or wid (peek-char port))
  191            ((32 16 8) (case pc
  192                 ((#\s) (- wid))
  193                 (else wid)))
  194            (else (bomb pc wid)))))
  195     (else #f)))
  196 
  197 ;;; We come into read:array with number or #f for RANK.
  198 (define (read:array rank dims port)
  199   (define (make-it rank dims typ)
  200     (list->uniform-array (cond (rank)
  201                                ((null? dims) 1)
  202                                (else (length dims)))
  203                          typ
  204                          (read port)))
  205   (let loop ((dims dims))
  206     (define dim (read:try-number port))
  207     (if dim
  208     (loop (cons dim dims))
  209     (case (peek-char port)
  210       ((#\*) (read-char port) (loop dims))
  211       ((#\: #\\ #\t #\c #\r #\s #\u #\T #\C #\R #\S #\U)
  212            (make-it rank dims (read-array-type port)))
  213       (else
  214            (make-it rank dims #f))))))
  215 
  216 ;;; read-macros valid for LOAD and READ.
  217 (define (read:sharp c port reader) ; ignore reader
  218   (case c
  219     ;; Used in "implcat" and "slibcat"
  220     ((#\+) (if (slib:provided? (read port))
  221            (read port)
  222            (begin (read port) (if #f #f))))
  223     ;; Used in "implcat" and "slibcat"
  224     ((#\-) (if (slib:provided? (read port))
  225            (begin (read port) (if #f #f))
  226            (read port)))
  227     ((#\a #\A) (read:array #f '() port))
  228     ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  229      (let* ((num (read:try-number port c))
  230         (chr (peek-char port)))
  231        (case chr
  232      ((#\a #\A) (read-char port)
  233       (read:array num '() port))
  234      ((#\*) (read-char port)
  235       (read:array #f (list num) port))
  236      (else
  237       (read:array 1 (list num) port))
  238      ;;(else (error 'sharp 'syntax? (symbol-append "#" num chr)))
  239      )))
  240     (else (error "unknown # object" c))))
  241 
  242 ;;; read-macros valid only in LOAD.
  243 (define (load:sharp c port reader) ;reader used only for #.
  244   (case c
  245     ((#\') (read port))
  246     ((#\.) (eval (reader port)))
  247     ((#\!) (let skip ((metarg? #f))
  248          (let ((c (read-char port)))
  249            (case c
  250          ((#\newline) (if metarg? (skip #t)))
  251          ((#\\) (skip #t))
  252          ((#\!) (cond ((eqv? #\# (peek-char port))
  253                    (read-char port)
  254                    (if #f #f))
  255                   (else (skip metarg?))))
  256          (else (if (char? c) (skip metarg?) c))))))
  257     ;; Make #; convert the rest of the line to a (comment ...) form.
  258     ;; "build.scm" uses this.
  259     ((#\;) (let skip-semi ()
  260          (cond ((eqv? #\; (peek-char port))
  261             (read-char port)
  262             (skip-semi))
  263            (else (require 'line-i/o)
  264              `(comment ,(read-line port))))))
  265     ((#\?) (case (read port)
  266          ((line) (port-line port))
  267          ((column) (port-column port))
  268          ((file) (port-filename port))
  269          (else #f)))
  270     (else (read:sharp c port read))))
  271 
  272 ;;; We can assume TOK has at least 2 characters.
  273 (define char:sharp
  274   (letrec ((numeric-1
  275             (lambda (tok radix)
  276               (numeric (substring tok 1 (string-length tok)) radix)))
  277            (numeric
  278             (lambda (tok radix)
  279               (cond ((string->number tok radix) => integer->char))))
  280            (compose
  281         (lambda (modifier tok)
  282           (and (char=? #\- (string-ref tok 1))
  283            (if (= 3 (string-length tok))
  284                (modifier (string-ref tok 2))
  285                (let ((c (char:sharp
  286                  (substring tok 2 (string-length tok)))))
  287              (and c (modifier c)))))))
  288        (control
  289         (lambda (c)
  290           (and (char? c)
  291            (if (eqv? c #\?)
  292                (integer->char 127)
  293                (integer->char (logand #o237 (char->integer c)))))))
  294        (meta
  295         (lambda (c)
  296           (and (char? c)
  297            (integer->char (logior 128 (char->integer c)))))))
  298     (lambda (tok)
  299       (case (string-ref tok 0)
  300         ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) (numeric tok 8))
  301         ((#\O #\o) (numeric-1 tok 8))
  302         ((#\D #\d) (numeric-1 tok 10))
  303         ((#\X #\x) (numeric-1 tok 16))
  304     ((#\C #\c) (compose control tok))
  305     ((#\^) (and (= 2 (string-length tok)) (control (string-ref tok 1))))
  306     ((#\M #\m) (compose meta tok))))))
  307 
  308 ;;;; Function used to accumulate comments before a definition.
  309 (define comment
  310   (let ((*accumulated-comments* '()))
  311     (lambda args
  312       (cond ((null? args)
  313          (let ((ans
  314             (apply string-append
  315                (map (lambda (comment)
  316                   (string-append (or comment "") "\n"))
  317                 (reverse *accumulated-comments*)))))
  318            (set! *accumulated-comments* '())
  319            (if (equal? "" ans)
  320            "no-comment"     ;#f
  321            (substring ans 0 (+ -1 (string-length ans))))))
  322         (else (set! *accumulated-comments*
  323             (append (reverse args) *accumulated-comments*)))))))
  324 
  325 (define : ':)               ;for /bin/sh hack.
  326 (define !#(if #f #f))           ;for scsh hack.
  327 
  328 ;;;; Here are some Revised^2 Scheme functions:
  329 (define 1+ (let ((+ +)) (lambda (n) (+ n 1))))
  330 (define -1+ (let ((+ +)) (lambda (n) (+ n -1))))
  331 (define 1- -1+)
  332 (define <? <)
  333 (define <=? <=)
  334 (define =? =)
  335 (define >? >)
  336 (define >=? >=)
  337 (define t #t)
  338 (define nil #f)
  339 (define identity cr)
  340 
  341 (cond ((defined? defsyntax)
  342 (defsyntax define-syntax (the-macro defsyntax)))
  343       (else
  344 (define defsyntax define)
  345 (define the-macro identity)))
  346 (defsyntax sequence (the-macro begin))
  347 (define copy-tree @copy-tree)
  348 
  349 ;;; VMS does something strange when output is sent to both
  350 ;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT.
  351 (case (software-type) ((vms) (set-current-error-port (current-output-port))))
  352 
  353 ;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
  354 ;;; mode to open files in.  MS-DOS does carriage return - newline
  355 ;;; translation if not opened in `b' mode.
  356 
  357 (define open_read (case (software-type)
  358             ((ms-dos windows atarist) 'rb)
  359             (else 'r)))
  360 (define open_write (case (software-type)
  361              ((ms-dos windows) 'wbc)
  362              ((atarist) 'wb)
  363              (else 'w)))
  364 (define open_both (case (software-type)
  365             ((ms-dos windows) 'r+bc)
  366             ((atarist) 'r+b)
  367             (else 'r+)))
  368 (define ((make-moder str) mode)
  369   (if (symbol? mode)
  370       (string->symbol (string-append (symbol->string mode) str))
  371       (string-append mode str)))
  372 (define _ionbf (make-moder "0"))
  373 (define _tracked (make-moder "?"))
  374 (define _exclusive (make-moder "x"))
  375 
  376 (define could-not-open #f)
  377 
  378 (define (open-output-file str)
  379   (or (open-file str open_write)
  380       (and (procedure? could-not-open) (could-not-open) #f)
  381       (error "OPEN-OUTPUT-FILE couldn't open file " str)))
  382 (define (open-input-file str)
  383   (or (open-file str open_read)
  384       (and (procedure? could-not-open) (could-not-open) #f)
  385       (error "OPEN-INPUT-FILE couldn't open file " str)))
  386 
  387 (define (string-index str chr)
  388   (define len (string-length str))
  389   (do ((pos 0 (+ 1 pos)))
  390       ((or (>= pos len) (char=? chr (string-ref str pos)))
  391        (and (< pos len) pos))))
  392 
  393 (if (not (defined? try-create-file))
  394 (define (try-create-file str modes . perms)
  395   (if (symbol? modes) (set! modes (symbol->string modes)))
  396   (let ((idx (string-index modes #\x)))
  397     (cond ((slib:in-catalog? 'i/o-extensions)
  398        (require 'i/o-extensions)
  399        (apply try-create-file str modes perms))
  400       ((not idx)
  401        (warn "not exclusive modes?" modes str)
  402        (try-open-file str modes))
  403       (else (set! modes (string-append (substring modes 0 idx)
  404                        (substring modes (+ 1 idx)
  405                               (string-length modes))))
  406         (cond ((not (string-index modes #\w))
  407                (warn 'try-create-file "not writing?" modes str)
  408                (try-open-file str modes))
  409               (else
  410                (cond ((and (not (null? perms))
  411                    (not (eqv? #o666 (car perms))))
  412                   (warn "perms?" (car perms) str)))
  413                (cond ((file-exists? str) #f)
  414                  (else (try-open-file str modes))))))))))
  415 
  416 (if (not (defined? file-position))
  417 (define (file-position . args) #f))
  418 (if (not (defined? file-set-position))
  419 (define file-set-position file-position))
  420 
  421 (define close-input-port close-port)
  422 (define close-output-port close-port)
  423 
  424 (define (call-with-open-ports . ports)
  425   (define proc (car ports))
  426   (cond ((procedure? proc) (set! ports (cdr ports)))
  427     (else (set! ports (reverse ports))
  428           (set! proc (car ports))
  429           (set! ports (reverse (cdr ports)))))
  430   (let ((ans (apply proc ports)))
  431     (for-each close-port ports)
  432     ans))
  433 
  434 (define (call-with-input-file str proc)
  435   (call-with-open-ports (open-input-file str) proc))
  436 
  437 (define (call-with-output-file str proc)
  438   (call-with-open-ports (open-output-file str) proc))
  439 
  440 (define (with-input-from-port port thunk)
  441   (dynamic-wind (lambda () (set! port (set-current-input-port port)))
  442         thunk
  443         (lambda () (set! port (set-current-input-port port)))))
  444 
  445 (define (with-output-to-port port thunk)
  446   (dynamic-wind (lambda () (set! port (set-current-output-port port)))
  447         thunk
  448         (lambda () (set! port (set-current-output-port port)))))
  449 
  450 (define (with-error-to-port port thunk)
  451   (dynamic-wind (lambda () (set! port (set-current-error-port port)))
  452         thunk
  453         (lambda () (set! port (set-current-error-port port)))))
  454 
  455 (define (with-input-from-file file thunk)
  456   (let* ((nport (open-input-file file))
  457      (ans (with-input-from-port nport thunk)))
  458     (close-port nport)
  459     ans))
  460 
  461 (define (with-output-to-file file thunk)
  462   (let* ((nport (open-output-file file))
  463      (ans (with-output-to-port nport thunk)))
  464     (close-port nport)
  465     ans))
  466 
  467 (define (with-error-to-file file thunk)
  468   (let* ((nport (open-output-file file))
  469      (ans (with-error-to-port nport thunk)))
  470     (close-port nport)
  471     ans))
  472 
  473 (define (call-with-outputs thunk proc)
  474   (define stdout #f)
  475   (define stderr #f)
  476   (define status #f)
  477   (set! stdout
  478     (call-with-output-string
  479      (lambda (stdout)
  480        (set! stderr
  481          (call-with-output-string
  482           (lambda (stderr)
  483             (call-with-current-continuation
  484              (lambda (escape)
  485                (dynamic-wind
  486                (lambda ()
  487                  (set! status #f)
  488                  (set! stdout (set-current-output-port stdout))
  489                  (set! stderr (set-current-error-port stderr)))
  490                (lambda () (set! status (list (thunk))))
  491                (lambda ()
  492                  (set! stdout (set-current-output-port stdout))
  493                  (set! stderr (set-current-error-port stderr))
  494                  (if (not status) (escape #f))))))))))))
  495   (apply proc stdout stderr (or status '())))
  496 
  497 (define browse-url
  498   (case (software-type)
  499     ((unix coherent plan9)
  500      (lambda (url)
  501        (define (try cmd end) (zero? (system (string-append cmd url end))))
  502        (or (try "netscape-remote -remote 'openURL(" ")'")
  503        (try "netscape -remote 'openURL(" ")'")
  504        (try "netscape '" "'&")
  505        (try "netscape '" "'"))))
  506     (else
  507      (lambda (url)
  508        (slib:warn 'define (software-type) 'case 'of 'browse-url 'in
  509           *load-pathname*)))))
  510 
  511 (define (warn . args)
  512   (define cep (current-error-port))
  513   (if (defined? print-call-stack) (print-call-stack cep))
  514   (perror "WARN")
  515   (errno 0)
  516   (display "WARN:" cep)
  517   (for-each (lambda (x) (display #\space cep) (write x cep)) args)
  518   (newline cep)
  519   (force-output cep))
  520 
  521 (define (error . args)
  522   (define cep (current-error-port))
  523   (if (defined? print-call-stack) (print-call-stack cep))
  524   (perror "ERROR")
  525   (errno 0)
  526   (display "ERROR:" cep)
  527   (for-each (lambda (x) (display #\space cep) (write x cep)) args)
  528   (newline cep)
  529   (force-output cep)
  530   (abort))
  531 
  532 (define set-errno errno)
  533 (define slib:exit quit)
  534 (define exit quit)
  535 
  536 (define (print . args)
  537   (define result #f)
  538   (for-each (lambda (x) (set! result x) (write x) (display #\space)) args)
  539   (newline)
  540   result)
  541 (define (pprint . args)
  542   (define result #f)
  543   (for-each (lambda (x) (set! result x) (pretty-print x)) args)
  544   result)
  545 (define (pp . args)
  546   (for-each pretty-print args)
  547   (if #f #f))
  548 
  549 (if (not (defined? file-exists?))
  550 (define (file-exists? str)
  551   (let ((port (open-file str open_read)))
  552     (errno 0)
  553     (and port (close-port port) #t))))
  554 (define (file-readable? str)
  555   (let ((port (open-file str open_read)))
  556     (errno 0)
  557     (and port
  558      (char-ready? port)
  559      (do ((c (read-char port)
  560          (and (char-ready? port) (read-char port)))
  561           (i 0 (+ 1 i))
  562           (l '() (cons c l)))
  563          ((or (not c) (eof-object? c) (<= 2 i))
  564           (if (null? l) #f (list->string (reverse l))))))))
  565 
  566 (define difftime -)
  567 (define offset-time +)
  568 
  569 (if (not (defined? ed))
  570 (define (ed . args)
  571   (system (apply string-append
  572          (or (getenv "EDITOR") "ed")
  573          (map (lambda (s) (string-append " " s)) args)))))
  574 
  575 (if (not (defined? output-port-width))
  576 (define (output-port-width . arg) 80))
  577 
  578 (if (not (defined? output-port-height))
  579 (define (output-port-height . arg) 24))
  580 
  581 (if (not (defined? last-pair))
  582 (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)))
  583 
  584 (define slib:error error)
  585 (define slib:warn warn)
  586 (define slib:tab #\tab)
  587 (define slib:form-feed #\page)
  588 (define slib:eval eval)
  589 
  590 (define (make-exchanger . pair) (lambda (rep) (swap-car! pair rep)))
  591 
  592 ;;;; Load.
  593 (define load:indent 0)
  594 (define (load:pre op file)
  595   (define cep (current-error-port))
  596   (cond ((> (verbose) 1)
  597      (display
  598       (string-append ";" (make-string load:indent #\space)
  599              (symbol->string op) "ing " file)
  600       cep)
  601      (set! load:indent (modulo (+ 2 load:indent) 16))
  602      (newline cep)))
  603   (force-output cep))
  604 
  605 (define (load:post op filesuf)
  606   (define cep (current-error-port))
  607   (errno 0)
  608   (cond ((> (verbose) 1)
  609      (set! load:indent (modulo (+ -2 load:indent) 16))
  610      (display (string-append ";" (make-string load:indent #\space)
  611                  "done " (symbol->string op) "ing " filesuf)
  612           cep)
  613      (newline cep)
  614      (force-output cep))))
  615 
  616 ;;; Here for backward compatibility
  617 (define scheme-file-suffix
  618   (case (software-type)
  619     ((NOSVE) (lambda () "_scm"))
  620     (else (lambda () ".scm"))))
  621 
  622 (define (has-suffix? str suffix)
  623   (let ((sufl (string-length suffix))
  624     (sl (string-length str)))
  625     (and (> sl sufl)
  626      (string=? (substring str (- sl sufl) sl) suffix))))
  627 
  628 (define *load-reader* #f)
  629 (define (scm:load file . libs)
  630   (define filesuf file)
  631   (define hss (has-suffix? file (scheme-file-suffix)))
  632   (load:pre 'load file)
  633   (or (and (defined? link:link) (not hss)
  634        (or (let ((s2 (file-readable? file)))
  635          (and s2 (not (equal? "#!" s2)) (apply link:link file libs)))
  636            (and link:able-suffix
  637             (let* ((fs (string-append file link:able-suffix))
  638                (fs2 (file-readable? fs)))
  639               (and fs2 (apply link:link fs libs) (set! filesuf fs) #t)
  640               ))))
  641       (and (null? libs) (try-load file *load-reader*))
  642       ;;HERE is where the suffix gets specified
  643       (and (not hss) (errno 0)      ; clean up error from TRY-LOAD above
  644        (set! filesuf (string-append file (scheme-file-suffix)))
  645        (try-load filesuf *load-reader*))
  646       (and (procedure? could-not-open) (could-not-open) #f)
  647       (begin (set! load:indent 0)
  648          (error "LOAD couldn't find file " file)))
  649   (load:post 'load filesuf))
  650 (define load scm:load)
  651 (define slib:load load)
  652 
  653 (define (scm:load-source file)
  654   (define sfs (scheme-file-suffix))
  655   (define filesuf file)
  656   (load:pre 'load file)
  657   (or (and (or (try-load file *load-reader*)
  658            ;;HERE is where the suffix gets specified
  659            (and (not (has-suffix? file sfs))
  660             (begin (set! filesuf (string-append file sfs))
  661                (try-load filesuf *load-reader*)))))
  662       (and (procedure? could-not-open) (could-not-open) #f)
  663       (error "LOAD couldn't find file " file))
  664   (load:post 'load filesuf))
  665 (define slib:load-source scm:load-source)
  666 
  667 ;;; This is the vicinity where this file resides.
  668 (define implementation-vicinity #f)
  669 
  670 ;;; (library-vicinity) should be defined to be the pathname of the
  671 ;;; directory where files of Scheme library functions reside.
  672 (define library-vicinity #f)
  673 
  674 ;;; (home-vicinity) should return the vicinity of the user's HOME
  675 ;;; directory, the directory which typically contains files which
  676 ;;; customize a computer environment for a user.
  677 (define home-vicinity #f)
  678 
  679 (if (not (defined? getpw))
  680     (define read-line
  681       (if (defined? read-line)
  682       read-line
  683       (lambda port
  684         (let* ((chr (apply read-char port)))
  685           (if (eof-object? chr)
  686           chr
  687           (do ((chr chr (apply read-char port))
  688                (clist '() (cons chr clist)))
  689               ((or (eof-object? chr) (char=? #\newline chr))
  690                (list->string (reverse clist))))))))))
  691 (if (not (defined? getpw))
  692     (define string-index
  693       (if (defined? string-index)
  694       string-index
  695       (lambda (str chr)
  696         (define len (string-length str))
  697         (do ((pos 0 (+ 1 pos)))
  698         ((or (>= pos len) (char=? chr (string-ref str pos)))
  699          (and (< pos len) pos)))))))
  700 
  701 (define (login->home-directory login)
  702   (cond ((defined? getpw)
  703      (let ((pwvect (getpw login)))
  704        (and pwvect (vector-ref pwvect 5))))
  705     ((not (file-exists? "/etc/passwd")) #f)
  706     (else
  707      (call-with-input-file "/etc/passwd"
  708        (lambda (iprt)
  709          (let tryline ()
  710            (define line (read-line iprt))
  711            (define (get-field)
  712          (define idx (string-index line #\:))
  713          (and idx
  714               (let ((fld (substring line 0 idx)))
  715             (set! line (substring line (+ 1 idx)
  716                           (string-length line)))
  717             fld)))
  718            (cond ((eof-object? line) #f)
  719              ((string-index line #\:)
  720               => (lambda (idx)
  721                (define name (substring line 0 idx))
  722                (cond ((equal? login name)
  723                   (do ((ans (get-field) (get-field))
  724                        (cnt 4 (+ -1 cnt)))
  725                       ((or (negative? cnt) (not ans)) ans)))
  726                  (else (tryline))))))))))))
  727 
  728 (define (getlogin) (or (getenv "USER") (getenv "LOGNAME")))
  729 
  730 ;;; If the environment variable SCHEME_LIBRARY_PATH is undefined, use
  731 ;;; (implementation-vicinity) as (library-vicinity).  "require.scm",
  732 ;;; the first file loaded from (library-vicinity), can redirect it.
  733 (define (set-vicinities! init-file)
  734   (set! implementation-vicinity
  735     (let ((vic (substring
  736             init-file
  737             0
  738             (- (string-length init-file)
  739                (string-length "Init.scm")
  740                (string-length (scheme-implementation-version))))))
  741       (lambda () vic)))
  742   (let ((library-path (getenv "SCHEME_LIBRARY_PATH")))
  743     (if library-path
  744     (set! library-vicinity (lambda () library-path))
  745     (let ((filename (in-vicinity (implementation-vicinity) "require.scm")))
  746       (or (try-load filename)
  747           (try-load (in-vicinity (implementation-vicinity) "requires.scm"))
  748           (error "Can't load" filename))
  749       (if (not library-vicinity) (error "Can't find library-vicinity")))))
  750   (set! home-vicinity
  751     (let ((home (getenv "HOME")))
  752       (and (not home) login->home-directory
  753            (let ((login (getlogin)))
  754          (and login (set! home (login->home-directory login)))))
  755       (and home
  756            (case (software-type)
  757          ((unix coherent plan9 ms-dos) ;V7 unix has a / on HOME
  758           (if (not
  759                (eqv? #\/ (string-ref home (+ -1 (string-length home)))))
  760               (set! home (string-append home "/"))))))
  761       (lambda () home))))
  762 ;;; SET-VICINITIES! is also called from BOOT-TAIL
  763 (set-vicinities! *load-pathname*)
  764 
  765 ;;;; Initialize SLIB
  766 (load (in-vicinity (library-vicinity) "require"))
  767 
  768 ;;; This enables line-numbering for SLIB loads.
  769 (define *slib-load-reader* (and (defined? read-numbered) read-numbered))
  770 
  771 ;;; DO NOT MOVE!  SLIB:LOAD-SOURCE and SLIB:LOAD must be defined after
  772 ;;; "require.scm" is loaded.
  773 (define (slib:load-source file)
  774   (fluid-let ((*load-reader* *slib-load-reader*))
  775     (scm:load-source file)))
  776 (define (slib:load file . libs)
  777   (fluid-let ((*load-reader* *slib-load-reader*))
  778     (apply scm:load file libs)))
  779 
  780 ;;; Legacy grease
  781 (if (not (defined? slib:in-catalog?))
  782     (define slib:in-catalog? require:feature->path))
  783 
  784 ;;; Dynamic link-loading
  785 (cond ((or (defined? dyn:link)
  786        (defined? vms:dynamic-link-call))
  787        (load (in-vicinity (implementation-vicinity) "Link"))))
  788 
  789 ;;; Redefine to ease transition from *features* to slib:features.
  790 (define (provide feature)
  791   (cond ((not (memq feature slib:features))
  792      (set! slib:features (cons feature slib:features))
  793      (if (defined? *features*) (set! *features* slib:features)))))
  794 
  795 (cond ((defined? link:link)
  796 (define (slib:load-compiled . args)
  797   (cond ((symbol? (car args))
  798      (require (car args))
  799      (apply slib:load-compiled (cdr args)))
  800     ((apply link:link args)
  801      (if (defined? *features*) (set! slib:features *features*)))
  802     (else (error "Couldn't link files " args))))
  803 (provide 'compiled)))
  804 
  805 ;;; Complete the function set for feature STRING-CASE.
  806 (cond
  807  ((defined? string-upcase!)
  808 (define (string-upcase str) (string-upcase! (string-copy str)))
  809 (define (string-downcase str) (string-downcase! (string-copy str)))
  810 (define (string-capitalize str) (string-capitalize! (string-copy str)))
  811 (define string-ci->symbol
  812   (let ((s2cis (if (equal? "x" (symbol->string 'x))
  813            string-downcase string-upcase)))
  814     (lambda (str) (string->symbol (s2cis str)))))
  815 (define symbol-append
  816   (let ((s2cis (if (equal? "x" (symbol->string 'x))
  817            string-downcase string-upcase)))
  818     (lambda args
  819       (string->symbol
  820        (apply string-append
  821           (map
  822            (lambda (obj)
  823          (cond ((char? obj) (string obj))
  824                ((string? obj) (s2cis obj))
  825                ((number? obj) (s2cis (number->string obj)))
  826                ((symbol? obj) (symbol->string obj))
  827                ((not obj) "")
  828                (else (error 'wrong-type-to 'symbol-append obj))))
  829            args))))))
  830 (define (StudlyCapsExpand nstr . delimitr)
  831   (set! delimitr
  832     (cond ((null? delimitr) "-")
  833           ((char? (car delimitr)) (string (car delimitr)))
  834           (else (car delimitr))))
  835   (do ((idx (+ -1 (string-length nstr)) (+ -1 idx)))
  836       ((> 1 idx) nstr)
  837     (cond ((and (> idx 1)
  838         (char-upper-case? (string-ref nstr (+ -1 idx)))
  839         (char-lower-case? (string-ref nstr idx)))
  840        (set! nstr
  841          (string-append (substring nstr 0 (+ -1 idx))
  842                 delimitr
  843                 (substring nstr (+ -1 idx)
  844                        (string-length nstr)))))
  845       ((and (char-lower-case? (string-ref nstr (+ -1 idx)))
  846         (char-upper-case? (string-ref nstr idx)))
  847        (set! nstr
  848          (string-append (substring nstr 0 idx)
  849                 delimitr
  850                 (substring nstr idx
  851                        (string-length nstr))))))))
  852 (provide 'string-case)))
  853 
  854 ;;;; Bit order and lamination
  855 
  856 ;;(define (logical:ones deg) (lognot (ash -1 deg)))
  857 
  858 ;;; New with SRFI-60
  859 (define (rotate-bit-field n count start end)
  860   (define width (- end start))
  861   (set! count (modulo count width))
  862   (let ((mask (lognot (ash -1 width))))
  863     (define azn (logand mask (arithmetic-shift n (- start))))
  864     (logior (arithmetic-shift
  865          (logior (logand mask (arithmetic-shift azn count))
  866              (arithmetic-shift azn (- count width)))
  867          start)
  868         (logand (lognot (ash mask start)) n))))
  869 ;;; Legacy
  870 ;;(define (logical:rotate k count len) (rotate-bit-field k count 0 len))
  871 
  872 (define (log2-binary-factors n)
  873   (+ -1 (integer-length (logand n (- n)))))
  874 
  875 (define (bit-reverse k n)
  876   (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1))
  877        (k (+ -1 k) (+ -1 k))
  878        (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m))))
  879       ((negative? k) (if (negative? n) (lognot rvs) rvs))))
  880 (define (reverse-bit-field n start end)
  881   (define width (- end start))
  882   (let ((mask (lognot (ash -1 width))))
  883     (define zn (logand mask (arithmetic-shift n (- start))))
  884     (logior (arithmetic-shift (bit-reverse width zn) start)
  885         (logand (lognot (ash mask start)) n))))
  886 
  887 (define (integer->list k . len)
  888   (if (negative? k) (slib:error 'integer->list 'negative? k))
  889   (if (null? len)
  890       (do ((k k (arithmetic-shift k -1))
  891        (lst '() (cons (odd? k) lst)))
  892       ((<= k 0) lst))
  893       (do ((idx (+ -1 (car len)) (+ -1 idx))
  894        (k k (arithmetic-shift k -1))
  895        (lst '() (cons (odd? k) lst)))
  896       ((negative? idx) lst))))
  897 
  898 (define (list->integer bools)
  899   (do ((bs bools (cdr bs))
  900        (acc 0 (+ acc acc (if (car bs) 1 0))))
  901       ((null? bs) acc)))
  902 (define (booleans->integer . bools)
  903   (list->integer bools))
  904 
  905 ;;;; SRFI-60 aliases
  906 (define arithmetic-shift ash)
  907 (define bitwise-ior logior)
  908 (define bitwise-xor logxor)
  909 (define bitwise-and logand)
  910 (define bitwise-not lognot)
  911 ;;(define bit-count logcount)       ;Aliases bit-vector function
  912 ;;BITWISE-BIT-COUNT returns negative count for negative inputs.
  913 (define bit-set?   logbit?)
  914 (define any-bits-set? logtest)
  915 (define first-set-bit log2-binary-factors)
  916 (define bitwise-merge bitwise-if)
  917 
  918 (define @case-aux
  919   (let ((integer-jump-table 1)
  920     (char-jump-table 2))
  921     (lambda (keys actions else-action)
  922       (let ((n (length keys)))
  923     (define (every-key pred)
  924       (let test ((keys keys))
  925         (or (null? keys)
  926         (and (pred (car keys)) (test (cdr keys))))))
  927     (define (jump-table keys)
  928       (let ((minkey (apply min keys))
  929         (maxkey (apply max keys)))
  930         (and (< (- maxkey minkey) (* 4 n))
  931          (let ((actv (make-vector
  932                   (+ 2 (- maxkey minkey)) else-action)))
  933            (for-each
  934             (lambda (key action)
  935               (vector-set! actv (+ 1 (- key minkey)) action))
  936             keys actions)
  937            (list integer-jump-table minkey actv)))))
  938     (cond ((< n 5) #f)
  939           ((every-key integer?)
  940            (jump-table keys))
  941           ((every-key char?)
  942            (let* ((int-keys (map char->integer keys)))
  943          (cond ((jump-table int-keys) =>
  944             (lambda (x)
  945               (cons char-jump-table
  946                 (cons (integer->char (cadr x))
  947                       (cddr x)))))
  948                (else #f)))))))))
  949 
  950 ;;;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer):
  951 (define *defmacros* '())
  952 (define (defmacro? m) (and (assq m *defmacros*) #t))
  953 
  954 (define defmacro:transformer
  955   (lambda (f)
  956     (procedure->memoizing-macro
  957      (lambda (exp env)
  958        (@copy-tree (apply f (remove-line-numbers! (cdr exp))))))))
  959 
  960 (define defmacro:get-destructuring-bind-pairs
  961   (lambda (s e)
  962     (let loop ((s s) (e e) (r '()))
  963       (cond ((pair? s)
  964          (loop (car s) `(car ,e)
  965            (loop (cdr s) `(cdr ,e) r)))
  966         ((null? s) r)
  967         ((symbol? s) (cons `(,s ,e) r))
  968         (else (error 'destructuring-bind "illegal syntax"))))))
  969 
  970 (defsyntax destructuring-bind
  971   (let ((destructuring-bind-transformer
  972      (lambda (s x . ff)
  973        (let ((tmp (gentemp)))
  974          `(let ((,tmp ,x))
  975         (let ,(defmacro:get-destructuring-bind-pairs s tmp)
  976           ,@ff))))))
  977     (set! *defmacros*
  978       (acons 'destructuring-bind
  979          destructuring-bind-transformer *defmacros*))
  980     (defmacro:transformer destructuring-bind-transformer)))
  981 
  982 (defsyntax defmacro:simple-defmacro
  983   (let ((defmacro-transformer
  984       (lambda (name parms . body)
  985         `(defsyntax ,name
  986            (let ((transformer (lambda ,parms ,@body)))
  987          (set! *defmacros* (acons ',name transformer *defmacros*))
  988          (defmacro:transformer transformer))))))
  989     (set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*))
  990     (defmacro:transformer defmacro-transformer)))
  991 
  992 (defmacro:simple-defmacro defmacro (name . body)
  993   (define (expn name pattern body)
  994     (let ((args (gentemp)))
  995       `(defmacro:simple-defmacro ,name ,args
  996      (destructuring-bind ,pattern ,args ,@body))))
  997   (if (pair? name)
  998       (expn (car name) (cdr name) body)
  999       (expn name (car body) (cdr body))))
 1000 
 1001 (define (macroexpand-1 e)
 1002   (if (pair? e) (let ((a (car e)))
 1003           (cond ((symbol? a) (set! a (assq a *defmacros*))
 1004              (if a (apply (cdr a) (cdr e)) e))
 1005             (else e)))
 1006       e))
 1007 
 1008 (define (macroexpand e)
 1009   (if (pair? e) (let ((a (car e)))
 1010           (cond ((symbol? a)
 1011              (set! a (assq a *defmacros*))
 1012              (if a (macroexpand (apply (cdr a) (cdr e))) e))
 1013             (else e)))
 1014       e))
 1015 
 1016 (define gentemp
 1017   (let ((*gensym-counter* -1))
 1018     (lambda ()
 1019       (set! *gensym-counter* (+ *gensym-counter* 1))
 1020       (string->symbol
 1021        (string-append "scm:G" (number->string *gensym-counter*))))))
 1022 
 1023 (define defmacro:eval slib:eval)
 1024 (define defmacro:load load)
 1025 ;; slib:eval-load definition moved to "slib/require.scm"
 1026 
 1027 ;;;; Autoloads for SLIB procedures.
 1028 
 1029 (define (trace-all . args) (require 'debug) (apply trace-all args))
 1030 (define (track-all . args) (require 'debug) (apply track-all args))
 1031 (define (stack-all . args) (require 'debug) (apply stack-all args))
 1032 (define (break-all . args) (require 'debug) (apply break-all args))
 1033 (define (pretty-print . args) (require 'pretty-print) (apply pretty-print args))
 1034 
 1035 ;;; (require 'transcript) would get us SLIB transcript -- not what we want.
 1036 (define (transcript-on arg)
 1037   (load (in-vicinity (implementation-vicinity)
 1038              (string-append "Tscript" (scheme-file-suffix))))
 1039   (transcript-on arg))
 1040 (define (transcript-off)
 1041   (error "No transcript active"))
 1042 
 1043 ;;;; Macros.
 1044 
 1045 ;;; Trace gets re-defmacroed when tracef autoloads.
 1046 (defmacro trace x (cond ((null? x) '()) (else (require 'trace) `(trace ,@x))))
 1047 (defmacro track x (cond ((null? x) '()) (else (require 'track) `(track ,@x))))
 1048 (defmacro stack x (cond ((null? x) '()) (else (require 'stack) `(stack ,@x))))
 1049 (defmacro break x (cond ((null? x) '()) (else (require 'break) `(break ,@x))))
 1050 
 1051 (defmacro defvar (var val)
 1052   `(if (not (defined? ,var)) (define ,var ,val)))
 1053 (defmacro defconst (name value)
 1054   (cond ((list? name) `(defconst ,(car name) (lambda ,(cdr name) ,value)))
 1055     (else (cond ((not (slib:eval `(defined? ,name))))
 1056             ((and (symbol? name) (equal? (slib:eval value)
 1057                          (slib:eval name))))
 1058             (else (error 'trying-to-defconst name
 1059                  'to-different-value value)))
 1060           `(define ,name ,value))))
 1061 (defmacro qase (key . clauses)
 1062   `(case ,key
 1063      ,@(map (lambda (clause)
 1064           (if (list? (car clause))
 1065           (cons (apply
 1066              append
 1067              (map (lambda (elt)
 1068                 (case elt
 1069                   ((unquote) '(unquote))
 1070                   ((unquote-splicing) '(unquote-splicing))
 1071                   (else
 1072                    (eval (list 'quasiquote (list elt))))))
 1073                   (car clause)))
 1074             (cdr clause))
 1075           clause))
 1076         clauses)))
 1077 (defmacro (casev . args) `(qase ,@args))
 1078 
 1079 (defmacro fluid-let (clauses . body)
 1080   (let ((ids (map car clauses))
 1081     (temp (gentemp))
 1082     (swap (gentemp)))
 1083     `(let* ((,temp (list ,@(map cadr clauses)))
 1084         (,swap (lambda () (set! ,temp (set! ,ids ,temp)))))
 1085        (dynamic-wind
 1086        ,swap
 1087        (lambda () ,@body)
 1088        ,swap))))
 1089 
 1090 (define (scm:print-binding sexp frame)
 1091   (cond ((not (null? (cdr sexp)))
 1092      (display "In")
 1093      (for-each (lambda (exp) (display #\space) (display exp)) (cdr sexp))
 1094      (display ": ")))
 1095   (do ((vars (car frame) (cdr vars))
 1096        (vals (cdr frame) (cdr vals)))
 1097       ((not (pair? vars))
 1098        (cond ((not (null? vars)) (write vars)
 1099           (display " := ") (write (car vals))))
 1100        (newline))
 1101     (write (car vars)) (display " = ") (write (car vals)) (display "; ")))
 1102 
 1103 (define print-args
 1104   (procedure->memoizing-macro
 1105    (lambda (sexp env)
 1106      (define (fix-list frm)
 1107        (cond ((pair? frm) (cons (car frm) (fix-list (cdr frm))))
 1108          ((null? frm) '())
 1109          ((symbol? frm) (list frm))
 1110          (else '())))
 1111      (define frm (car env))
 1112      `(scm:print-binding
 1113        ',sexp
 1114        ,(cond ((symbol? frm) `(list ',frm ,frm))
 1115           ((list? frm) `(list ',frm ,@frm))
 1116           ((pair? frm)
 1117            (let ((jlp (fix-list frm)))
 1118          `(list ',(if (symbol? (cdr (last-pair frm))) frm jlp)
 1119             ,@jlp))))))))
 1120 
 1121 (cond
 1122  ((defined? stack-trace)
 1123 
 1124 ;;#+breakpoint-error;; remove line to enable breakpointing on calls to ERROR
 1125 (define error
 1126   (letrec ((oerror error)
 1127            (nerror
 1128             (lambda args
 1129               (dynamic-wind
 1130                   (lambda () (set! error oerror))
 1131                   (lambda ()
 1132                     (define cep (current-error-port))
 1133                     (if (defined? print-call-stack)
 1134                         (print-call-stack cep))
 1135                     (perror "ERROR")
 1136                     (errno 0)
 1137                     (display "ERROR: " cep)
 1138                     (if (not (null? args))
 1139                         (begin (display (car args) cep)
 1140                                (for-each (lambda (x) (display #\space cep) (write x cep))
 1141                                          (cdr args))))
 1142                     (newline cep)
 1143                     (cond ((stack-trace) (newline cep)))
 1144                     (display " * Breakpoint established: (continue <val>) to return." cep)
 1145                     (newline cep) (force-output cep)
 1146                     (require 'debug) (apply breakpoint args))
 1147                   (lambda () (set! error nerror))))))
 1148     nerror))
 1149 
 1150 (define (user-interrupt . args)
 1151   (define cep (current-error-port))
 1152   (newline cep)
 1153   (if (defined? print-call-stack)
 1154       (print-call-stack cep))
 1155   (display "ERROR: user interrupt" cep)
 1156   (newline cep)
 1157   (cond ((stack-trace) (newline cep)))
 1158   (display " * Breakpoint established: (continue <val>) to return." cep)
 1159   (newline cep) (force-output cep)
 1160   (require 'debug) (apply breakpoint args))
 1161   ))
 1162 
 1163 (cond ((and (inexact? (string->number "0.0")) (not (defined? exp)))
 1164        (or (and (defined? usr:lib)
 1165         (usr:lib "m")
 1166         (load (in-vicinity (implementation-vicinity) "Transcen")
 1167               (usr:lib "m")))
 1168        (load (in-vicinity (implementation-vicinity) "Transcen"))))
 1169       (else
 1170        (define (infinite? z) #f)
 1171        (define finite? number?)
 1172        (define inexact->exact identity)
 1173        (define exact->inexact identity)
 1174        (define round->exact identity)
 1175        (define floor->exact identity)
 1176        (define ceiling->exact identity)
 1177        (define truncate->exact identity)
 1178        (define expt integer-expt)))
 1179 
 1180 (define (numerator q)
 1181   (if (not (rational? q)) (error 'numerator q))
 1182   (do ((num q (* 2 num)))
 1183       ((integer? num) num)))
 1184 
 1185 (define (denominator q)
 1186   (if (not (rational? q)) (error 'denominator q))
 1187   (do ((num q (* 2 num))
 1188        (den (- q q -1) (* 2 den)))
 1189       ((integer? num) den)))
 1190 
 1191 ;;;; http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/code/math/isqrt/isqrt.txt
 1192 ;;; Akira Kurihara
 1193 ;;; School of Mathematics
 1194 ;;; Japan Women's University
 1195 ;@
 1196 (define integer-sqrt
 1197   (let ((table '#(0
 1198           1 1 1
 1199           2 2 2 2 2
 1200           3 3 3 3 3 3 3
 1201           4 4 4 4 4 4 4 4 4))
 1202     (square (lambda (x) (* x x))))
 1203     (lambda (n)
 1204       (define (isqrt n)
 1205     (if (> n 24)
 1206         (let* ((len/4 (quotient (- (integer-length n) 1) 4))
 1207            (top (isqrt (ash n (* -2 len/4))))
 1208            (init (ash top len/4))
 1209            (q (quotient n init))
 1210            (iter (quotient (+ init q) 2)))
 1211           (cond ((odd? q) iter)
 1212             ((< (remainder n init) (square (- iter init))) (- iter 1))
 1213             (else iter)))
 1214         (vector-ref table n)))
 1215       (if (and (exact? n) (integer? n) (not (negative? n)))
 1216       (isqrt n)
 1217       (slib:error 'integer-sqrt n)))))
 1218 
 1219 (if (defined? array?)
 1220 (begin
 1221 
 1222 (define (array-null? array)
 1223   (zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd)))
 1224                (array-shape array)))))
 1225 (define (create-array prot . args)
 1226   (if (array-null? prot)
 1227       (dimensions->uniform-array args (array-prototype prot))
 1228       (dimensions->uniform-array args (array-prototype prot)
 1229                  (apply array-ref prot
 1230                     (map car (array-shape prot))))))
 1231 (define make-array create-array)
 1232 (define (list->array rank proto lst)
 1233   (list->uniform-array rank (array-prototype proto) lst))
 1234 (define (vector->array vect prototype . dimensions)
 1235   (define vdx (vector-length vect))
 1236   (if (not (eqv? vdx (apply * dimensions)))
 1237       (slib:error 'vector->array vdx '<> (cons '* dimensions)))
 1238   (let ((ra (apply make-array prototype dimensions)))
 1239     (define (v2ra dims idxs)
 1240       (cond ((null? dims)
 1241          (set! vdx (+ -1 vdx))
 1242          (apply array-set! ra (vector-ref vect vdx) (reverse idxs)))
 1243         (else
 1244          (do ((idx (+ -1 (car dims)) (+ -1 idx)))
 1245          ((negative? idx) vect)
 1246            (v2ra (cdr dims) (cons idx idxs))))))
 1247     (v2ra dimensions '())
 1248     ra))
 1249 (define (array->vector ra)
 1250   (define dims (array-dimensions ra))
 1251   (let* ((vdx (apply * dims))
 1252      (vect (make-vector vdx)))
 1253     (define (ra2v dims idxs)
 1254       (if (null? dims)
 1255       (let ((val (apply array-ref ra (reverse idxs))))
 1256         (set! vdx (+ -1 vdx))
 1257         (vector-set! vect vdx val)
 1258         vect)
 1259       (do ((idx (+ -1 (car dims)) (+ -1 idx)))
 1260           ((negative? idx) vect)
 1261         (ra2v (cdr dims) (cons idx idxs)))))
 1262     (ra2v dims '())))
 1263 (define (make-uniform-wrapper prot)
 1264   (if (string? prot) (set! prot (string->number prot)))
 1265   (if prot
 1266       (lambda opt (if (null? opt)
 1267               (list->uniform-array 1 prot '())
 1268               (list->uniform-array 0 prot (car opt))))
 1269       vector))
 1270 (define Ac64 (make-uniform-wrapper "+64i"))
 1271 (define Ac32 (make-uniform-wrapper "+32i"))
 1272 (define Ar64 (make-uniform-wrapper "64."))
 1273 (define Ar32 (make-uniform-wrapper "32."))
 1274 (define As64 (make-uniform-wrapper -64))
 1275 (define As32 (make-uniform-wrapper -32))
 1276 (define As16 (make-uniform-wrapper -16))
 1277 (define As8  (make-uniform-wrapper -8))
 1278 (define Au64 (make-uniform-wrapper  64))
 1279 (define Au32 (make-uniform-wrapper  32))
 1280 (define Au16 (make-uniform-wrapper  16))
 1281 (define Au8  (make-uniform-wrapper  8))
 1282 (define At1  (make-uniform-wrapper  #t))
 1283 
 1284 ;;; New SRFI-58 names
 1285 ;; flonums
 1286 (define A:floC128b Ac64)
 1287 (define A:floC64b Ac64)
 1288 (define A:floC32b Ac32)
 1289 (define A:floC16b Ac32)
 1290 (define A:floR128b Ar64)
 1291 (define A:floR64b Ar64)
 1292 (define A:floR32b Ar32)
 1293 (define A:floR16b Ar32)
 1294 ;; decimal flonums
 1295 (define A:floQ128d Ar64)
 1296 (define A:floQ64d Ar64)
 1297 (define A:floQ32d Ar32)
 1298 ;; fixnums
 1299 (define A:fixZ64b As64)
 1300 (define A:fixZ32b As32)
 1301 (define A:fixZ16b As16)
 1302 (define A:fixZ8b  As8)
 1303 (define A:fixN64b Au64)
 1304 (define A:fixN32b Au32)
 1305 (define A:fixN16b Au16)
 1306 (define A:fixN8b  Au8)
 1307 (define A:bool    At1)
 1308 
 1309 (define (array-shape a)
 1310   (let ((dims (array-dimensions a)))
 1311     (if (pair? dims)
 1312     (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
 1313          dims)
 1314     dims)))
 1315 (define array=? equal?)
 1316 (provide 'srfi-47)
 1317 (provide 'srfi-58)
 1318 (provide 'srfi-63)
 1319 ))
 1320 
 1321 (if (defined? bigdbl:powers-of-5)
 1322     (do ((i 0 (+ i 1))
 1323      (acc 1 (* acc 5)))
 1324     ((>= i (vector-length bigdbl:powers-of-5)))
 1325       (vector-set! bigdbl:powers-of-5 i acc)))
 1326 
 1327 (define (alarm-interrupt) (alarm 0))
 1328 (if (defined? setitimer)
 1329     (begin
 1330       (define profile-alarm #f)
 1331       (define (profile-alarm-interrupt) (profile-alarm 0))
 1332       (define virtual-alarm #f)
 1333       (define (virtual-alarm-interrupt) (virtual-alarm 0))
 1334       (define milli-alarm #f)
 1335       (let ((make-alarm
 1336          (lambda (sym)
 1337            (and (setitimer sym 0 0) ;DJGPP supports only REAL and PROFILE
 1338             (lambda (value . interval)
 1339               (cadr
 1340                (setitimer sym value
 1341                   (if (pair? interval) (car interval) 0))))))))
 1342     (set! profile-alarm (make-alarm 'profile))
 1343     (set! virtual-alarm (make-alarm 'virtual))
 1344     (set! milli-alarm (make-alarm 'real)))))
 1345 
 1346 ;;;; Initialize statically linked add-ons
 1347 (cond ((defined? scm_init_extensions)
 1348        (scm_init_extensions)
 1349        (if (defined? *features*) (set! slib:features *features*))
 1350        (set! scm_init_extensions #f)))
 1351 
 1352 ;;; Use *argv* instead of (program-arguments), to allow option
 1353 ;;; processing to be done on it.  "ScmInit.scm" must
 1354 ;;; (set! *argv* (program-arguments))
 1355 ;;; if it wants to alter the arguments which BOOT-TAIL processes.
 1356 (define *argv* #f)
 1357 
 1358 (if (not (defined? *syntax-rules*))
 1359     (define *syntax-rules* #f))
 1360 (if (not (defined? *interactive*))
 1361     (define *interactive* #f))
 1362 
 1363 (define (boot-tail dumped?)
 1364   (cond ((not *argv*)
 1365      (set! *argv* (program-arguments))
 1366      (cond (dumped?
 1367         (set-vicinities! dumped?)
 1368         (verbose (if (and (isatty? (current-input-port))
 1369                   (isatty? (current-output-port)))
 1370                  (if (<= (length *argv*) 1) 2 1)
 1371                  0))))
 1372      (cond ((provided? 'getopt)
 1373         (set! *optind* 1)
 1374         (set! *optarg* #f)))))
 1375 
 1376 ;;; This loads the user's initialization file, or files named in
 1377 ;;; program arguments.
 1378   (or *script*
 1379       (eq? (software-type) 'THINKC)
 1380       (member "-no-init-file" (program-arguments))
 1381       (member "--no-init-file" (program-arguments))
 1382       (try-load (in-vicinity (or (home-vicinity) (user-vicinity))
 1383                  (string-append "ScmInit") (scheme-file-suffix))
 1384         *load-reader*)
 1385       (errno 0))
 1386 
 1387   ;; Include line numbers in loaded code.
 1388   (if (defined? read-numbered)
 1389       (set! *load-reader* read-numbered))
 1390 
 1391   (cond
 1392    ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0)))
 1393     (require 'getopt)
 1394 ;;; (else
 1395 ;;;  (define *optind* 1)
 1396 ;;;  (define getopt:opt #f)
 1397 ;;;  (define (getopt optstring) #f))
 1398 
 1399     (let* ((simple-opts "muvqibs")
 1400        (arg-opts '("a kbytes" "-version" "-help"
 1401                "-no-symbol-case-fold"
 1402                "no-init-file" "-no-init-file" "p number"
 1403                "h feature" "r feature" "d filename"
 1404                "f filename" "l filename"
 1405                "c string" "e string" "o filename"))
 1406        (opts (apply string-append ":" simple-opts
 1407             (map (lambda (o)
 1408                    (string-append (string (string-ref o 0)) ":"))
 1409                  arg-opts)))
 1410        (didsomething #f)
 1411        (moreopts #t)
 1412        (exe-name (symbol->string (scheme-implementation-type)))
 1413        (up-name (apply string (map char-upcase (string->list exe-name)))))
 1414 
 1415       (define (do-thunk thunk)
 1416     (if *interactive*
 1417         (thunk)
 1418         (let ((complete #f))
 1419           (dynamic-wind
 1420           (lambda () #f)
 1421           (lambda ()
 1422             (thunk)
 1423             (set! complete #t))
 1424           (lambda ()
 1425             (if (not complete) (close-port (current-input-port))))))))
 1426 
 1427       (define (do-string-arg)
 1428     (require 'string-port)
 1429     (do-thunk
 1430      (lambda ()
 1431        ((if *syntax-rules* macro:eval eval)
 1432         (call-with-input-string
 1433         (string-append "(begin " *optarg* ")")
 1434           read))))
 1435     (set! didsomething #t))
 1436 
 1437       (define (do-load file)
 1438     (do-thunk
 1439      (lambda ()
 1440        (cond (*syntax-rules* (require 'macro) (macro:load file))
 1441          (else (load file)))))
 1442     (set! didsomething #t))
 1443 
 1444       (define (usage preopt opt postopt success?)
 1445     (define cep (if success? (current-output-port) (current-error-port)))
 1446     (define indent (make-string 6 #\space))
 1447     (define i 3)
 1448     (cond ((char? opt) (set! opt (string opt)))
 1449           ;;((symbol? opt) (set! opt (symbol->string opt)))
 1450           )
 1451     (display (string-append preopt opt postopt) cep)
 1452     (newline cep)
 1453     (display (string-append "Usage: "
 1454                 exe-name
 1455                 " [-a kbytes] [-" simple-opts "]") cep)
 1456     (for-each
 1457      (lambda (o)
 1458        (display (string-append " [-" o "]") cep)
 1459        (set! i (+ 1 i))
 1460        (cond ((zero? (modulo i 5)) (newline cep) (display indent cep))))
 1461      (cdr arg-opts))
 1462     (display " [-- | -s | -] [file] [args...]" cep) (newline cep)
 1463     (if success? (display success? cep) (quit #f)))
 1464 
 1465       ;; -a int => ignore (handled by scm_init_from_argv)
 1466       ;; -c str => (eval str)
 1467       ;; -e str => (eval str)
 1468       ;; -d str => (require 'databases) (open-database str)
 1469       ;; -f str => (load str)
 1470       ;; -l str => (load str)
 1471       ;; -r sym => (require sym)
 1472       ;; -h sym => (provide sym)
 1473       ;; -o str => (dump str)
 1474       ;; -p int => (verbose int)
 1475       ;; -m     => (set! *syntax-rules* #t)
 1476       ;; -u     => (set! *syntax-rules* #f)
 1477       ;; -v     => (verbose 3)
 1478       ;; -q     => (verbose 0)
 1479       ;; -i     => (set! *interactive* #t)
 1480       ;; -b     => (set! *interactive* #f)
 1481       ;; -s     => set argv, don't execute first one
 1482       ;; --no-symbol-case-fold => symbols preserve character case
 1483       ;; -no-init-file => don't load init file
 1484       ;; --no-init-file => don't load init file
 1485       ;; --help => print and exit
 1486       ;; --version => print and exit
 1487       ;; --     => last option
 1488 
 1489       (let loop ((option (getopt-- opts)))
 1490     (case option
 1491       ((#\a)
 1492        (cond ((> *optind* 3)
 1493           (usage "scm: option `-" getopt:opt "' must be first" #f))
 1494          ((or (not (exact? (string->number *optarg*)))
 1495               (not (<= 1 (string->number *optarg*) 10000)))
 1496           ;;    This size limit should match scm.c ^^
 1497           (usage "scm: option `-" getopt:opt
 1498              (string-append *optarg* "' unreasonable") #f))))
 1499       ((#\e #\c) (do-string-arg))   ;sh-like
 1500       ((#\f #\l) (do-load *optarg*)) ;(set-car! *argv* *optarg*)
 1501       ((#\d) (require 'databases)
 1502        (open-database *optarg*))
 1503       ((#\o) (require 'dump)
 1504        (if (< *optind* (length *argv*))
 1505            (dump *optarg* #t)
 1506            (dump *optarg*)))
 1507       ((#\r) (do-thunk (lambda ()
 1508                  (if (and (= 1 (string-length *optarg*))
 1509                       (char-numeric? (string-ref *optarg* 0)))
 1510                  (case (string-ref *optarg* 0)
 1511                    ((#\2) (require 'r2rs))
 1512                    ((#\3) (require 'r3rs))
 1513                    ((#\4) (require 'r4rs))
 1514                    ((#\5) (require 'r5rs)
 1515                     (set! *syntax-rules* #t))
 1516                    (else (require (string->symbol *optarg*))))
 1517                  (require (string->symbol *optarg*))))))
 1518       ((#\h) (do-thunk (lambda () (provide (string->symbol *optarg*)))))
 1519       ((#\p) (verbose (string->number *optarg*)))
 1520       ((#\q) (verbose 0))
 1521       ((#\v) (verbose 3))
 1522       ((#\i) (set! *interactive* #t) ;sh-like
 1523        (verbose (max 2 (verbose))))
 1524       ((#\b) (set! didsomething #t)
 1525        (set! *interactive* #f))
 1526       ((#\s) (set! moreopts #f) ;sh-like
 1527        (set! didsomething #t)
 1528        (set! *interactive* #t))
 1529       ((#\m) (set! *syntax-rules* #t))
 1530       ((#\u) (set! *syntax-rules* #f))
 1531       ((#\n) (if (not (string=? "o-init-file" *optarg*))
 1532              (usage "scm: unrecognized option `-n" *optarg* "'" #f)))
 1533       ((#\:) (usage "scm: option `-" getopt:opt "' requires an argument" #f))
 1534       ((#\?) (usage "scm: unrecognized option `-" getopt:opt "'" #f))
 1535       ((#f) (set! moreopts #f)  ;sh-like
 1536        (cond ((and (< *optind* (length *argv*))
 1537                (string=? "-" (list-ref *argv* *optind*)))
 1538           (set! *optind* (+ 1 *optind*)))))
 1539       (else
 1540        (or (cond ((not (string? option)) #f)
 1541              ((string-ci=? "no-init-file" option))
 1542              ((string-ci=? "no-symbol-case-fold" option))
 1543              ((string-ci=? "version" option)
 1544               (display
 1545                (string-append exe-name " "
 1546                       (scheme-implementation-version)
 1547                       "
 1548 Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
 1549 "
 1550                       up-name
 1551                       " may be distributed under the terms of"
 1552                       " the GNU General Public Licence;
 1553 certain other uses are permitted as well."
 1554                       " For details, see the file `COPYING',
 1555 which is included in the "
 1556                       up-name " distribution.
 1557 There is no warranty, to the extent permitted by law.
 1558 "
 1559                       ))
 1560               (cond ((execpath) =>
 1561                  (lambda (path)
 1562                    (display " This executable was loaded from ")
 1563                    (write path)
 1564                    (newline))))
 1565               (quit #t))
 1566              ((string-ci=? "help" option)
 1567               (usage "This is "
 1568                  up-name
 1569                  ", a Scheme interpreter."
 1570                  (let ((sihp (scheme-implementation-home-page)))
 1571                    (if sihp
 1572                    (string-append "Latest info: " sihp "
 1573 ")
 1574                    "")))
 1575               (quit #t))
 1576              (else #f))
 1577            (usage "scm: unknown option `--" option "'" #f))))
 1578 
 1579     (cond ((and moreopts (< *optind* (length *argv*)))
 1580            (loop (getopt-- opts)))
 1581           ((< *optind* (length *argv*)) ;No more opts
 1582            (set! *argv* (list-tail *argv* *optind*))
 1583            (set! *optind* 1)
 1584            (cond ((and (not didsomething) *script*)
 1585               (do-load *script*)
 1586               (set! *optind* (+ 1 *optind*))))
 1587            (cond ((and (> (verbose) 2)
 1588                (not (= (+ -1 *optind*) (length *argv*))))
 1589               (display "scm: extra command arguments unused:"
 1590                    (current-error-port))
 1591               (for-each (lambda (x) (display (string-append " " x)
 1592                              (current-error-port)))
 1593                 (list-tail *argv* (+ -1 *optind*)))
 1594               (newline (current-error-port)))))
 1595           ((and (not didsomething) (= *optind* (length *argv*)))
 1596            (set! *interactive* #t)))))
 1597 
 1598     (cond ((not *interactive*) (quit))
 1599       ((and *syntax-rules* (not (provided? 'macro)))
 1600        (require 'repl)
 1601        (require 'macro)
 1602        (let* ((oquit quit))
 1603          (set! quit (lambda () (repl:quit)))
 1604          (set! exit quit)
 1605          (repl:top-level macro:eval)
 1606          (oquit))))
 1607     ;;otherwise, fall into natural SCM repl.
 1608     )
 1609    (else (errno 0)
 1610      (set! *interactive* #t)
 1611      (for-each load (cdr (program-arguments))))))