diff options
Diffstat (limited to 'Init5e3.scm')
| -rw-r--r-- | Init5e3.scm | 1631 |
1 files changed, 1631 insertions, 0 deletions
diff --git a/Init5e3.scm b/Init5e3.scm new file mode 100644 index 0000000..305cea0 --- /dev/null +++ b/Init5e3.scm @@ -0,0 +1,1631 @@ +;; Copyright (C) 1991-2006 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of SCM. +;; +;; The exception is that, if you link the SCM library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the SCM library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name SCM. If you copy +;; code from other Free Software Foundation releases into a copy of +;; SCM, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for SCM, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;;;; "Init.scm", Scheme initialization code for SCM. +;;; Author: Aubrey Jaffer. + +(define (scheme-implementation-type) 'SCM) +(define (scheme-implementation-version) "5e3") +(define (scheme-implementation-home-page) + "http://swiss.csail.mit.edu/~jaffer/SCM") + +;@ +(define in-vicinity string-append) +;@ +(define (user-vicinity) + (case (software-type) + ((VMS) "[.]") + (else ""))) +;@ +(define vicinity:suffix? + (let ((suffi + (case (software-type) + ((AMIGA) '(#\: #\/)) + ((MACOS THINKC) '(#\:)) + ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT PLAN9) '(#\/)) + ((VMS) '(#\: #\])) + (else + (slib:warn "require.scm" 'unknown 'software-type (software-type)) + "/")))) + (lambda (chr) (and (memv chr suffi) #t)))) +;@ +(define (pathname->vicinity pathname) + (let loop ((i (- (string-length pathname) 1))) + (cond ((negative? i) "") + ((vicinity:suffix? (string-ref pathname i)) + (substring pathname 0 (+ i 1))) + (else (loop (- i 1)))))) +(define (program-vicinity) + (if *load-pathname* + (pathname->vicinity *load-pathname*) + (slib:error 'program-vicinity " called; use slib:load to load"))) +;@ +(define sub-vicinity + (case (software-type) + ((VMS) (lambda + (vic name) + (let ((l (string-length vic))) + (if (or (zero? (string-length vic)) + (not (char=? #\] (string-ref vic (- l 1))))) + (string-append vic "[" name "]") + (string-append (substring vic 0 (- l 1)) + "." name "]"))))) + (else (let ((*vicinity-suffix* + (case (software-type) + ((NOSVE) ".") + ((MACOS THINKC) ":") + ((MS-DOS WINDOWS ATARIST OS/2) "\\") + ((UNIX COHERENT PLAN9 AMIGA) "/")))) + (lambda (vic name) + (string-append vic name *vicinity-suffix*)))))) +;@ +(define (make-vicinity <pathname>) <pathname>) +;@ +(define with-load-pathname + (let ((exchange + (lambda (new) + (let ((old *load-pathname*)) + (set! *load-pathname* new) + old)))) + (lambda (path thunk) + (let ((old #f)) + (dynamic-wind + (lambda () (set! old (exchange path))) + thunk + (lambda () (exchange old))))))) + +(define slib:features + (append '(ed getenv tmpnam abort transcript with-file + ieee-p1178 rev4-report rev4-optional-procedures + hash object-hash delay dynamic-wind fluid-let + multiarg-apply multiarg/and- logical defmacro + string-port source current-time sharp:semi + vicinity srfi-59 srfi-23 srfi-94 + srfi-60) ;logical + (if (defined? *features*) *features* slib:features))) +(if (defined? *features*) (set! *features* slib:features)) + +(define eval + (let ((@eval @eval) + (@copy-tree @copy-tree)) + (lambda (x) (@eval (@copy-tree x))))) + +(define (exec-self) + (require 'i/o-extensions) + (execv (execpath) (if *script* + (cons (car (program-arguments)) + (cons "\\" + (member *script* (program-arguments)))) + (program-arguments)))) + +(define (display-file file . port) + (call-with-input-file file + (lambda (inport) + (do ((c (read-char inport) (read-char inport))) + ((eof-object? c)) + (apply write-char c port))))) +(define (terms) + (display-file (in-vicinity (implementation-vicinity) "COPYING"))) + +;;; Read integer up to first non-digit +(define (read:try-number port . ic) + (define chr0 (char->integer #\0)) + (let loop ((arg (and (not (null? ic)) (- (char->integer (car ic)) chr0)))) + (let ((c (peek-char port))) + (cond ((eof-object? c) #f) + ((char-numeric? c) + (loop (+ (* 10 (or arg 0)) + (- (char->integer (read-char port)) chr0)))) + (else arg))))) + +(define (read-array-type port) + (define (bomb pc wid) + (error 'array 'syntax? (symbol-append "#" rank "A" pc wid))) + (case (char-downcase (peek-char port)) + ((#\:) (read-char port) + (let ((typ (let loop ((arg '())) + (if (= 4 (length arg)) + (string->symbol (list->string (reverse arg))) + (let ((c (read-char port))) + (and (not (eof-object? c)) + (loop (cons (char-downcase c) arg)))))))) + (define wid (and typ (not (eq? 'bool typ)) (read:try-number port))) + (define (check-suffix chrs) + (define chr (read-char port)) + (if (and (char? chr) (not (memv (char-downcase chr) chrs))) + (error 'array-type? (symbol-append ":" typ wid chr)))) + (define prot (assq typ '((floc (128 . +64.0i) + (64 . +64.0i) + (32 . +32.0i) + (16 . +32.0i)) + (flor (128 . 64.0) + (64 . 64.0) + (32 . 32.0) + (16 . 32.0)) + (fixz (64 . -64) + (32 . -32) + (16 . -16) + (8 . -8)) + (fixn (64 . 64) + (32 . 32) + (16 . 16) + (8 . 8)) + (char . #\a) + (bool . #t)))) + (if prot (set! prot (cdr prot))) + (cond ((pair? prot) + (set! prot (assv wid (cdr prot))) + (if (pair? prot) (set! prot (cdr prot))) + (if wid (check-suffix (if (and (inexact? prot) (real? prot)) + '(#\b #\d) + '(#\b))))) + (prot) + (else (check-suffix '()))) + prot)) + ((#\\) (read-char port) #\a) + ((#\t) (read-char port) #t) + ((#\c #\r) (let* ((pc (read-char port)) (wid (read:try-number port))) + (case wid + ((64 32) (case pc + ((#\c) (* +i wid)) + (else (exact->inexact wid)))) + (else (bomb pc wid))))) + ((#\s #\u) (let* ((pc (read-char port)) (wid (read:try-number port))) + (case (or wid (peek-char port)) + ((32 16 8) (case pc + ((#\s) (- wid)) + (else wid))) + (else (bomb pc wid))))) + (else #f))) + +;;; We come into read:array with number or #f for RANK. +(define (read:array rank dims port) + (define (make-it rank dims typ) + (list->uniform-array (cond (rank) + ((null? dims) 1) + (else (length dims))) + typ + (read port))) + (let loop ((dims dims)) + (define dim (read:try-number port)) + (if dim + (loop (cons dim dims)) + (case (peek-char port) + ((#\*) (read-char port) (loop dims)) + ((#\: #\\ #\t #\c #\r #\s #\u #\T #\C #\R #\S #\U) + (make-it rank dims (read-array-type port))) + (else + (make-it rank dims #f)))))) + +;;; read-macros valid for LOAD and READ. +(define (read:sharp c port reader) ; ignore reader + (case c + ;; Used in "implcat" and "slibcat" + ((#\+) (if (slib:provided? (read port)) + (read port) + (begin (read port) (if #f #f)))) + ;; Used in "implcat" and "slibcat" + ((#\-) (if (slib:provided? (read port)) + (begin (read port) (if #f #f)) + (read port))) + ((#\a #\A) (read:array #f '() port)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let* ((num (read:try-number port c)) + (chr (peek-char port))) + (case chr + ((#\a #\A) (read-char port) + (read:array num '() port)) + ((#\*) (read-char port) + (read:array #f (list num) port)) + (else + (read:array 1 (list num) port)) + ;;(else (error 'sharp 'syntax? (symbol-append "#" num chr))) + ))) + (else (error "unknown # object" c)))) + +;;; read-macros valid only in LOAD. +(define (load:sharp c port reader) ;reader used only for #. + (case c + ((#\') (read port)) + ((#\.) (eval (reader port))) + ((#\!) (let skip ((metarg? #f)) + (let ((c (read-char port))) + (case c + ((#\newline) (if metarg? (skip #t))) + ((#\\) (skip #t)) + ((#\!) (cond ((eqv? #\# (peek-char port)) + (read-char port) + (if #f #f)) + (else (skip metarg?)))) + (else (if (char? c) (skip metarg?) c)))))) + ;; Make #; convert the rest of the line to a (comment ...) form. + ;; "build.scm" uses this. + ((#\;) (let skip-semi () + (cond ((eqv? #\; (peek-char port)) + (read-char port) + (skip-semi)) + (else (require 'line-i/o) + `(comment ,(read-line port)))))) + ((#\?) (case (read port) + ((line) (port-line port)) + ((column) (port-column port)) + ((file) (port-filename port)) + (else #f))) + (else (read:sharp c port read)))) + +;;; We can assume TOK has at least 2 characters. +(define char:sharp + (letrec ((numeric-1 + (lambda (tok radix) + (numeric (substring tok 1 (string-length tok)) radix))) + (numeric + (lambda (tok radix) + (cond ((string->number tok radix) => integer->char)))) + (compose + (lambda (modifier tok) + (and (char=? #\- (string-ref tok 1)) + (if (= 3 (string-length tok)) + (modifier (string-ref tok 2)) + (let ((c (char:sharp + (substring tok 2 (string-length tok))))) + (and c (modifier c))))))) + (control + (lambda (c) + (and (char? c) + (if (eqv? c #\?) + (integer->char 127) + (integer->char (logand #o237 (char->integer c))))))) + (meta + (lambda (c) + (and (char? c) + (integer->char (logior 128 (char->integer c))))))) + (lambda (tok) + (case (string-ref tok 0) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) (numeric tok 8)) + ((#\O #\o) (numeric-1 tok 8)) + ((#\D #\d) (numeric-1 tok 10)) + ((#\X #\x) (numeric-1 tok 16)) + ((#\C #\c) (compose control tok)) + ((#\^) (and (= 2 (string-length tok)) (control (string-ref tok 1)))) + ((#\M #\m) (compose meta tok)))))) + +;;;; Function used to accumulate comments before a definition. +(define comment + (let ((*accumulated-comments* '())) + (lambda args + (cond ((null? args) + (let ((ans + (apply string-append + (map (lambda (comment) + (string-append (or comment "") "\n")) + (reverse *accumulated-comments*))))) + (set! *accumulated-comments* '()) + (if (equal? "" ans) + "no-comment" ;#f + (substring ans 0 (+ -1 (string-length ans)))))) + (else (set! *accumulated-comments* + (append (reverse args) *accumulated-comments*))))))) + +(define : ':) ;for /bin/sh hack. +(define !#(if #f #f)) ;for scsh hack. + +;;;; Here are some Revised^2 Scheme functions: +(define 1+ (let ((+ +)) (lambda (n) (+ n 1)))) +(define -1+ (let ((+ +)) (lambda (n) (+ n -1)))) +(define 1- -1+) +(define <? <) +(define <=? <=) +(define =? =) +(define >? >) +(define >=? >=) +(define t #t) +(define nil #f) +(define identity cr) + +(cond ((defined? defsyntax) +(defsyntax define-syntax (the-macro defsyntax))) + (else +(define defsyntax define) +(define the-macro identity))) +(defsyntax sequence (the-macro begin)) +(define copy-tree @copy-tree) + +;;; VMS does something strange when output is sent to both +;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT. +(case (software-type) ((VMS) (set-current-error-port (current-output-port)))) + +;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper +;;; mode to open files in. MS-DOS does carriage return - newline +;;; translation if not opened in `b' mode. + +(define OPEN_READ (case (software-type) + ((MS-DOS WINDOWS ATARIST) 'rb) + (else 'r))) +(define OPEN_WRITE (case (software-type) + ((MS-DOS WINDOWS) 'wbc) + ((ATARIST) 'wb) + (else 'w))) +(define OPEN_BOTH (case (software-type) + ((MS-DOS WINDOWS) 'r+bc) + ((ATARIST) 'r+b) + (else 'r+))) +(define ((make-moder str) mode) + (if (symbol? mode) + (string->symbol (string-append (symbol->string mode) str)) + (string-append mode str))) +(define _IONBF (make-moder "0")) +(define _TRACKED (make-moder "?")) +(define _EXCLUSIVE (make-moder "x")) + +(define could-not-open #f) + +(define (open-output-file str) + (or (open-file str OPEN_WRITE) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-OUTPUT-FILE couldn't open file " str))) +(define (open-input-file str) + (or (open-file str OPEN_READ) + (and (procedure? could-not-open) (could-not-open) #f) + (error "OPEN-INPUT-FILE couldn't open file " str))) + +(define (string-index str chr) + (define len (string-length str)) + (do ((pos 0 (+ 1 pos))) + ((or (>= pos len) (char=? chr (string-ref str pos))) + (and (< pos len) pos)))) + +(if (not (defined? try-create-file)) +(define (try-create-file str modes . perms) + (if (symbol? modes) (set! modes (symbol->string modes))) + (let ((idx (string-index modes #\x))) + (cond ((slib:in-catalog? 'i/o-extensions) + (require 'i/o-extensions) + (apply try-create-file str modes perms)) + ((not idx) + (warn "not exclusive modes?" modes str) + (try-open-file str modes)) + (else (set! modes (string-append (substring modes 0 idx) + (substring modes (+ 1 idx) + (string-length modes)))) + (cond ((not (string-index modes #\w)) + (warn 'try-create-file "not writing?" modes str) + (try-open-file str modes)) + (else + (cond ((and (not (null? perms)) + (not (eqv? #o666 (car perms)))) + (warn "perms?" (car perms) str))) + (cond ((file-exists? str) #f) + (else (try-open-file str modes)))))))))) + +(define close-input-port close-port) +(define close-output-port close-port) + +(define (call-with-open-ports . ports) + (define proc (car ports)) + (cond ((procedure? proc) (set! ports (cdr ports))) + (else (set! ports (reverse ports)) + (set! proc (car ports)) + (set! ports (reverse (cdr ports))))) + (let ((ans (apply proc ports))) + (for-each close-port ports) + ans)) + +(define (call-with-input-file str proc) + (call-with-open-ports (open-input-file str) proc)) + +(define (call-with-output-file str proc) + (call-with-open-ports (open-output-file str) proc)) + +(define (with-input-from-port port thunk) + (dynamic-wind (lambda () (set! port (set-current-input-port port))) + thunk + (lambda () (set! port (set-current-input-port port))))) + +(define (with-output-to-port port thunk) + (dynamic-wind (lambda () (set! port (set-current-output-port port))) + thunk + (lambda () (set! port (set-current-output-port port))))) + +(define (with-error-to-port port thunk) + (dynamic-wind (lambda () (set! port (set-current-error-port port))) + thunk + (lambda () (set! port (set-current-error-port port))))) + +(define (with-input-from-file file thunk) + (let* ((nport (open-input-file file)) + (ans (with-input-from-port nport thunk))) + (close-port nport) + ans)) + +(define (with-output-to-file file thunk) + (let* ((nport (open-output-file file)) + (ans (with-output-to-port nport thunk))) + (close-port nport) + ans)) + +(define (with-error-to-file file thunk) + (let* ((nport (open-output-file file)) + (ans (with-error-to-port nport thunk))) + (close-port nport) + ans)) + +(define (call-with-outputs thunk proc) + (define stdout #f) + (define stderr #f) + (define status #f) + (set! stdout + (call-with-output-string + (lambda (stdout) + (set! stderr + (call-with-output-string + (lambda (stderr) + (call-with-current-continuation + (lambda (escape) + (dynamic-wind + (lambda () + (set! status #f) + (set! stdout (set-current-output-port stdout)) + (set! stderr (set-current-error-port stderr))) + (lambda () (set! status (list (thunk)))) + (lambda () + (set! stdout (set-current-output-port stdout)) + (set! stderr (set-current-error-port stderr)) + (if (not status) (escape #f)))))))))))) + (apply proc stdout stderr (or status '()))) + +(define browse-url + (case (software-type) + ((UNIX COHERENT PLAN9) + (lambda (url) + (define (try cmd end) (zero? (system (string-append cmd url end)))) + (or (try "netscape-remote -remote 'openURL(" ")'") + (try "netscape -remote 'openURL(" ")'") + (try "netscape '" "'&") + (try "netscape '" "'")))) + (else + (lambda (url) + (slib:warn 'define (software-type) 'case 'of 'browse-url 'in + *load-pathname*))))) + +(define (warn . args) + (define cep (current-error-port)) + (if (defined? print-call-stack) (print-call-stack cep)) + (perror "WARN") + (errno 0) + (display "WARN:" cep) + (for-each (lambda (x) (display #\space cep) (write x cep)) args) + (newline cep) + (force-output cep)) + +(define (error . args) + (define cep (current-error-port)) + (if (defined? print-call-stack) (print-call-stack cep)) + (perror "ERROR") + (errno 0) + (display "ERROR:" cep) + (for-each (lambda (x) (display #\space cep) (write x cep)) args) + (newline cep) + (force-output cep) + (abort)) + +(define set-errno errno) +(define slib:exit quit) +(define exit quit) + +(define (print . args) + (define result #f) + (for-each (lambda (x) (set! result x) (write x) (display #\space)) args) + (newline) + result) +(define (pprint . args) + (define result #f) + (for-each (lambda (x) (set! result x) (pretty-print x)) args) + result) +(define (pp . args) + (for-each pretty-print args) + (if #f #f)) + +(if (not (defined? file-exists?)) +(define (file-exists? str) + (let ((port (open-file str OPEN_READ))) + (errno 0) + (and port (close-port port) #t)))) +(define (file-readable? str) + (let ((port (open-file str OPEN_READ))) + (errno 0) + (and port + (char-ready? port) + (do ((c (read-char port) + (and (char-ready? port) (read-char port))) + (i 0 (+ 1 i)) + (l '() (cons c l))) + ((or (not c) (eof-object? c) (<= 2 i)) + (if (null? l) #f (list->string (reverse l)))))))) + +(define difftime -) +(define offset-time +) + +(if (not (defined? ed)) +(define (ed . args) + (system (apply string-append + (or (getenv "EDITOR") "ed") + (map (lambda (s) (string-append " " s)) args))))) + +(if (not (defined? output-port-width)) +(define (output-port-width . arg) 80)) + +(if (not (defined? output-port-height)) +(define (output-port-height . arg) 24)) + +(if (not (defined? last-pair)) +(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l))) + +(define slib:error error) +(define slib:warn warn) +(define slib:tab #\tab) +(define slib:form-feed #\page) +(define slib:eval eval) + +(define (make-exchanger . pair) (lambda (rep) (swap-car! pair rep))) + +;;;; Load. +(define load:indent 0) +(define (load:pre file) + (define cep (current-error-port)) + (cond ((> (verbose) 1) + (display + (string-append ";" (make-string load:indent #\space) "loading " file) + cep) + (set! load:indent (modulo (+ 2 load:indent) 16)) + (newline cep))) + (force-output cep)) + +(define (load:post filesuf) + (define cep (current-error-port)) + (errno 0) + (cond ((> (verbose) 1) + (set! load:indent (modulo (+ -2 load:indent) 16)) + (display (string-append ";" (make-string load:indent #\space) + "done loading " filesuf) + cep) + (newline cep) + (force-output cep)))) + +;;; Here for backward compatibility +(define scheme-file-suffix + (case (software-type) + ((NOSVE) (lambda () "_scm")) + (else (lambda () ".scm")))) + +(define (has-suffix? str suffix) + (let ((sufl (string-length suffix)) + (sl (string-length str))) + (and (> sl sufl) + (string=? (substring str (- sl sufl) sl) suffix)))) + +(define *load-reader* #f) +(define (scm:load file . libs) + (define filesuf file) + (define hss (has-suffix? file (scheme-file-suffix))) + (load:pre file) + (or (and (defined? link:link) (not hss) + (or (let ((s2 (file-readable? file))) + (and s2 (not (equal? "#!" s2)) (apply link:link file libs))) + (and link:able-suffix + (let* ((fs (string-append file link:able-suffix)) + (fs2 (file-readable? fs))) + (and fs2 (apply link:link fs libs) (set! filesuf fs) #t) + )))) + (and (null? libs) (try-load file *load-reader*)) + ;;HERE is where the suffix gets specified + (and (not hss) (errno 0) ; clean up error from TRY-LOAD above + (set! filesuf (string-append file (scheme-file-suffix))) + (try-load filesuf *load-reader*)) + (and (procedure? could-not-open) (could-not-open) #f) + (begin (set! load:indent 0) + (error "LOAD couldn't find file " file))) + (load:post filesuf)) +(define load scm:load) +(define slib:load load) + +(define (scm:load-source file) + (define sfs (scheme-file-suffix)) + (define filesuf file) + (load:pre file) + (or (and (or (try-load file *load-reader*) + ;;HERE is where the suffix gets specified + (and (not (has-suffix? file sfs)) + (begin (set! filesuf (string-append file sfs)) + (try-load filesuf *load-reader*))))) + (and (procedure? could-not-open) (could-not-open) #f) + (error "LOAD couldn't find file " file)) + (load:post filesuf)) +(define slib:load-source scm:load-source) + +;;; This is the vicinity where this file resides. +(define implementation-vicinity #f) + +;;; (library-vicinity) should be defined to be the pathname of the +;;; directory where files of Scheme library functions reside. +(define library-vicinity #f) + +;;; (home-vicinity) should return the vicinity of the user's HOME +;;; directory, the directory which typically contains files which +;;; customize a computer environment for a user. +(define home-vicinity #f) + +(if (not (defined? getpw)) + (define read-line + (if (defined? read-line) + read-line + (lambda port + (let* ((chr (apply read-char port))) + (if (eof-object? chr) + chr + (do ((chr chr (apply read-char port)) + (clist '() (cons chr clist))) + ((or (eof-object? chr) (char=? #\newline chr)) + (list->string (reverse clist)))))))))) +(if (not (defined? getpw)) + (define string-index + (if (defined? string-index) + string-index + (lambda (str chr) + (define len (string-length str)) + (do ((pos 0 (+ 1 pos))) + ((or (>= pos len) (char=? chr (string-ref str pos))) + (and (< pos len) pos))))))) + +(define (login->home-directory login) + (cond ((defined? getpw) + (let ((pwvect (getpw login))) + (and pwvect (vector-ref pwvect 5)))) + ((not (file-exists? "/etc/passwd")) #f) + (else + (call-with-input-file "/etc/passwd" + (lambda (iprt) + (let tryline () + (define line (read-line iprt)) + (define (get-field) + (define idx (string-index line #\:)) + (and idx + (let ((fld (substring line 0 idx))) + (set! line (substring line (+ 1 idx) + (string-length line))) + fld))) + (cond ((eof-object? line) #f) + ((string-index line #\:) + => (lambda (idx) + (define name (substring line 0 idx)) + (cond ((equal? login name) + (do ((ans (get-field) (get-field)) + (cnt 4 (+ -1 cnt))) + ((or (negative? cnt) (not ans)) ans))) + (else (tryline)))))))))))) + +(define (getlogin) (or (getenv "USER") (getenv "LOGNAME"))) + +;;; If the environment variable SCHEME_LIBRARY_PATH is undefined, use +;;; (implementation-vicinity) as (library-vicinity). "require.scm", +;;; the first file loaded from (library-vicinity), can redirect it. +(define (set-vicinities! init-file) + (set! implementation-vicinity + (let ((vic (substring + init-file + 0 + (- (string-length init-file) + (string-length "Init.scm") + (string-length (scheme-implementation-version)))))) + (lambda () vic))) + (let ((library-path (getenv "SCHEME_LIBRARY_PATH"))) + (if library-path + (set! library-vicinity (lambda () library-path)) + (let ((filename (in-vicinity (implementation-vicinity) "require.scm"))) + (or (try-load filename) + (try-load (in-vicinity (implementation-vicinity) "requires.scm")) + (error "Can't load" filename)) + (if (not library-vicinity) (error "Can't find library-vicinity"))))) + (set! home-vicinity + (let ((home (getenv "HOME"))) + (and (not home) login->home-directory + (let ((login (getlogin))) + (and login (set! home (login->home-directory login))))) + (and home + (case (software-type) + ((UNIX COHERENT PLAN9 MS-DOS) ;V7 unix has a / on HOME + (if (not + (eqv? #\/ (string-ref home (+ -1 (string-length home))))) + (set! home (string-append home "/")))))) + (lambda () home)))) +;;; SET-VICINITIES! is also called from BOOT-TAIL +(set-vicinities! *load-pathname*) + +;;;; Initialize SLIB +(load (in-vicinity (library-vicinity) "require")) + +;;; This enables line-numbering for SLIB loads. +(define *slib-load-reader* (and (defined? read-numbered) read-numbered)) + +;;; DO NOT MOVE! SLIB:LOAD-SOURCE and SLIB:LOAD must be defined after +;;; "require.scm" is loaded. +(define (slib:load-source file . libs) + (fluid-let ((*load-reader* *slib-load-reader*)) + (apply scm:load file libs))) +(define slib:load slib:load-source) + +;;; Legacy grease +(if (not (defined? slib:in-catalog?)) + (define slib:in-catalog? require:feature->path)) + +;;; Dynamic link-loading +(cond ((or (defined? dyn:link) + (defined? vms:dynamic-link-call)) + (load (in-vicinity (implementation-vicinity) "Link")))) + +;;; Redefine to ease transition from *features* to slib:features. +(define (provide feature) + (cond ((not (memq feature slib:features)) + (set! slib:features (cons feature slib:features)) + (if (defined? *features*) (set! *features* slib:features))))) + +(cond ((defined? link:link) +(define (slib:load-compiled . args) + (cond ((symbol? (car args)) + (require (car args)) + (apply slib:load-compiled (cdr args))) + ((apply link:link args) + (if (defined? *features*) (set! slib:features *features*))) + (else (error "Couldn't link files " args)))) +(provide 'compiled))) + +;;; Complete the function set for feature STRING-CASE. +(cond + ((defined? string-upcase!) +(define (string-upcase str) (string-upcase! (string-copy str))) +(define (string-downcase str) (string-downcase! (string-copy str))) +(define (string-capitalize str) (string-capitalize! (string-copy str))) +(define string-ci->symbol + (let ((s2cis (if (equal? "x" (symbol->string 'x)) + string-downcase string-upcase))) + (lambda (str) (string->symbol (s2cis str))))) +(define symbol-append + (let ((s2cis (if (equal? "x" (symbol->string 'x)) + string-downcase string-upcase))) + (lambda args + (string->symbol + (apply string-append + (map + (lambda (obj) + (cond ((char? obj) (string obj)) + ((string? obj) (s2cis obj)) + ((number? obj) (s2cis (number->string obj))) + ((symbol? obj) (symbol->string obj)) + ((not obj) "") + (else (error 'wrong-type-to 'symbol-append obj)))) + args)))))) +(define (StudlyCapsExpand nstr . delimitr) + (set! delimitr + (cond ((null? delimitr) "-") + ((char? (car delimitr)) (string (car delimitr))) + (else (car delimitr)))) + (do ((idx (+ -1 (string-length nstr)) (+ -1 idx))) + ((> 1 idx) nstr) + (cond ((and (> idx 1) + (char-upper-case? (string-ref nstr (+ -1 idx))) + (char-lower-case? (string-ref nstr idx))) + (set! nstr + (string-append (substring nstr 0 (+ -1 idx)) + delimitr + (substring nstr (+ -1 idx) + (string-length nstr))))) + ((and (char-lower-case? (string-ref nstr (+ -1 idx))) + (char-upper-case? (string-ref nstr idx))) + (set! nstr + (string-append (substring nstr 0 idx) + delimitr + (substring nstr idx + (string-length nstr)))))))) +(provide 'string-case))) + +;;;; Bit order and lamination + +;;(define (logical:ones deg) (lognot (ash -1 deg))) + +;;; New with SRFI-60 +(define (rotate-bit-field n count start end) + (define width (- end start)) + (set! count (modulo count width)) + (let ((mask (lognot (ash -1 width)))) + (define azn (logand mask (arithmetic-shift n (- start)))) + (logior (arithmetic-shift + (logior (logand mask (arithmetic-shift azn count)) + (arithmetic-shift azn (- count width))) + start) + (logand (lognot (ash mask start)) n)))) +;;; Legacy +;;(define (logical:rotate k count len) (rotate-bit-field k count 0 len)) + +(define (log2-binary-factors n) + (+ -1 (integer-length (logand n (- n))))) + +(define (bit-reverse k n) + (do ((m (if (negative? n) (lognot n) n) (arithmetic-shift m -1)) + (k (+ -1 k) (+ -1 k)) + (rvs 0 (logior (arithmetic-shift rvs 1) (logand 1 m)))) + ((negative? k) (if (negative? n) (lognot rvs) rvs)))) +(define (reverse-bit-field n start end) + (define width (- end start)) + (let ((mask (lognot (ash -1 width)))) + (define zn (logand mask (arithmetic-shift n (- start)))) + (logior (arithmetic-shift (bit-reverse width zn) start) + (logand (lognot (ash mask start)) n)))) + +(define (integer->list k . len) + (if (null? len) + (do ((k k (arithmetic-shift k -1)) + (lst '() (cons (odd? k) lst))) + ((<= k 0) lst)) + (do ((idx (+ -1 (car len)) (+ -1 idx)) + (k k (arithmetic-shift k -1)) + (lst '() (cons (odd? k) lst))) + ((negative? idx) lst)))) + +(define (list->integer bools) + (do ((bs bools (cdr bs)) + (acc 0 (+ acc acc (if (car bs) 1 0)))) + ((null? bs) acc))) +(define (booleans->integer . bools) + (list->integer bools)) + +;;;; SRFI-60 aliases +(define arithmetic-shift ash) +(define bitwise-ior logior) +(define bitwise-xor logxor) +(define bitwise-and logand) +(define bitwise-not lognot) +;;(define bit-count logcount) ;Aliases bit-vector function +(define bit-set? logbit?) +(define any-bits-set? logtest) +(define first-set-bit log2-binary-factors) +(define bitwise-merge bitwise-if) + +(define @case-aux + (let ((integer-jump-table 1) + (char-jump-table 2)) + (lambda (keys actions else-action) + (let ((n (length keys))) + (define (every-key pred) + (let test ((keys keys)) + (or (null? keys) + (and (pred (car keys)) (test (cdr keys)))))) + (define (jump-table keys) + (let ((minkey (apply min keys)) + (maxkey (apply max keys))) + (and (< (- maxkey minkey) (* 4 n)) + (let ((actv (make-vector + (+ 2 (- maxkey minkey)) else-action))) + (for-each + (lambda (key action) + (vector-set! actv (+ 1 (- key minkey)) action)) + keys actions) + (list integer-jump-table minkey actv))))) + (cond ((< n 5) #f) + ((every-key integer?) + (jump-table keys)) + ((every-key char?) + (let* ((int-keys (map char->integer keys))) + (cond ((jump-table int-keys) => + (lambda (x) + (cons char-jump-table + (cons (integer->char (cadr x)) + (cddr x))))) + (else #f))))))))) + +;;;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer): +(define *defmacros* '()) +(define (defmacro? m) (and (assq m *defmacros*) #t)) + +(define defmacro:transformer + (lambda (f) + (procedure->memoizing-macro + (lambda (exp env) + (@copy-tree (apply f (remove-line-numbers! (cdr exp)))))))) + +(define defmacro:get-destructuring-bind-pairs + (lambda (s e) + (let loop ((s s) (e e) (r '())) + (cond ((pair? s) + (loop (car s) `(car ,e) + (loop (cdr s) `(cdr ,e) r))) + ((null? s) r) + ((symbol? s) (cons `(,s ,e) r)) + (else (error 'destructuring-bind "illegal syntax")))))) + +(defsyntax destructuring-bind + (let ((destructuring-bind-transformer + (lambda (s x . ff) + (let ((tmp (gentemp))) + `(let ((,tmp ,x)) + (let ,(defmacro:get-destructuring-bind-pairs s tmp) + ,@ff)))))) + (set! *defmacros* + (acons 'destructuring-bind + destructuring-bind-transformer *defmacros*)) + (defmacro:transformer destructuring-bind-transformer))) + +(defsyntax defmacro:simple-defmacro + (let ((defmacro-transformer + (lambda (name parms . body) + `(defsyntax ,name + (let ((transformer (lambda ,parms ,@body))) + (set! *defmacros* (acons ',name transformer *defmacros*)) + (defmacro:transformer transformer)))))) + (set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*)) + (defmacro:transformer defmacro-transformer))) + +(defmacro:simple-defmacro defmacro (name . body) + (define (expn name pattern body) + (let ((args (gentemp))) + `(defmacro:simple-defmacro ,name ,args + (destructuring-bind ,pattern ,args ,@body)))) + (if (pair? name) + (expn (car name) (cdr name) body) + (expn name (car body) (cdr body)))) + +(define (macroexpand-1 e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) (set! a (assq a *defmacros*)) + (if a (apply (cdr a) (cdr e)) e)) + (else e))) + e)) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (cond ((symbol? a) + (set! a (assq a *defmacros*)) + (if a (macroexpand (apply (cdr a) (cdr e))) e)) + (else e))) + e)) + +(define gentemp + (let ((*gensym-counter* -1)) + (lambda () + (set! *gensym-counter* (+ *gensym-counter* 1)) + (string->symbol + (string-append "scm:G" (number->string *gensym-counter*)))))) + +(define defmacro:eval slib:eval) +(define defmacro:load load) +;; slib:eval-load definition moved to "slib/require.scm" + +;;;; Autoloads for SLIB procedures. + +(define (trace-all . args) (require 'debug) (apply trace-all args)) +(define (track-all . args) (require 'debug) (apply track-all args)) +(define (stack-all . args) (require 'debug) (apply stack-all args)) +(define (break-all . args) (require 'debug) (apply break-all args)) +(define (pretty-print . args) (require 'pretty-print) (apply pretty-print args)) + +;;; (require 'transcript) would get us SLIB transcript -- not what we want. +(define (transcript-on arg) + (load (in-vicinity (implementation-vicinity) + (string-append "Tscript" (scheme-file-suffix)))) + (transcript-on arg)) +(define (transcript-off) + (error "No transcript active")) + +;;;; Macros. + +;;; Trace gets re-defmacroed when tracef autoloads. +(defmacro trace x (cond ((null? x) '()) (else (require 'trace) `(trace ,@x)))) +(defmacro track x (cond ((null? x) '()) (else (require 'track) `(track ,@x)))) +(defmacro stack x (cond ((null? x) '()) (else (require 'stack) `(stack ,@x)))) +(defmacro break x (cond ((null? x) '()) (else (require 'break) `(break ,@x)))) + +(defmacro defvar (var val) + `(if (not (defined? ,var)) (define ,var ,val))) +(defmacro defconst (name value) + (cond ((list? name) `(defconst ,(car name) (lambda ,(cdr name) ,value))) + (else (cond ((not (slib:eval `(defined? ,name)))) + ((and (symbol? name) (equal? (slib:eval value) + (slib:eval name)))) + (else (error 'trying-to-defconst name + 'to-different-value value))) + `(define ,name ,value)))) +(defmacro qase (key . clauses) + `(case ,key + ,@(map (lambda (clause) + (if (list? (car clause)) + (cons (apply + append + (map (lambda (elt) + (case elt + ((unquote) '(unquote)) + ((unquote-splicing) '(unquote-splicing)) + (else + (eval (list 'quasiquote (list elt)))))) + (car clause))) + (cdr clause)) + clause)) + clauses))) +(defmacro (casev . args) `(qase ,@args)) + +(defmacro fluid-let (clauses . body) + (let ((ids (map car clauses)) + (temp (gentemp)) + (swap (gentemp))) + `(let* ((,temp (list ,@(map cadr clauses))) + (,swap (lambda () (set! ,temp (set! ,ids ,temp))))) + (dynamic-wind + ,swap + (lambda () ,@body) + ,swap)))) + +(define (scm:print-binding sexp frame) + (cond ((not (null? (cdr sexp))) + (display "In") + (for-each (lambda (exp) (display #\space) (display exp)) (cdr sexp)) + (display ": "))) + (do ((vars (car frame) (cdr vars)) + (vals (cdr frame) (cdr vals))) + ((not (pair? vars)) + (cond ((not (null? vars)) (write vars) + (display " := ") (write (car vals)))) + (newline)) + (write (car vars)) (display " = ") (write (car vals)) (display "; "))) + +(define print-args + (procedure->memoizing-macro + (lambda (sexp env) + (define (fix-list frm) + (cond ((pair? frm) (cons (car frm) (fix-list (cdr frm)))) + ((null? frm) '()) + ((symbol? frm) (list frm)) + (else '()))) + (define frm (car env)) + `(scm:print-binding + ',sexp + ,(cond ((symbol? frm) `(list ',frm ,frm)) + ((list? frm) `(list ',frm ,@frm)) + ((pair? frm) + (let ((jlp (fix-list frm))) + `(list ',(if (symbol? (cdr (last-pair frm))) frm jlp) + ,@jlp)))))))) + +(cond + ((defined? stack-trace) + +;;#+breakpoint-error;; remove line to enable breakpointing on calls to ERROR +(define error + (letrec ((oerror error) + (nerror + (lambda args + (dynamic-wind + (lambda () (set! error oerror)) + (lambda () + (define cep (current-error-port)) + (if (defined? print-call-stack) + (print-call-stack cep)) + (perror "ERROR") + (errno 0) + (display "ERROR: " cep) + (if (not (null? args)) + (begin (display (car args) cep) + (for-each (lambda (x) (display #\space cep) (write x cep)) + (cdr args)))) + (newline cep) + (cond ((stack-trace) (newline cep))) + (display " * Breakpoint established: (continue <val>) to return." cep) + (newline cep) (force-output cep) + (require 'debug) (apply breakpoint args)) + (lambda () (set! error nerror)))))) + nerror)) + +(define (user-interrupt . args) + (define cep (current-error-port)) + (newline cep) + (if (defined? print-call-stack) + (print-call-stack cep)) + (display "ERROR: user interrupt" cep) + (newline cep) + (cond ((stack-trace) (newline cep))) + (display " * Breakpoint established: (continue <val>) to return." cep) + (newline cep) (force-output cep) + (require 'debug) (apply breakpoint args)) + )) + +(cond ((and (inexact? (string->number "0.0")) (not (defined? exp))) + (or (and (defined? usr:lib) + (usr:lib "m") + (load (in-vicinity (implementation-vicinity) "Transcen") + (usr:lib "m"))) + (load (in-vicinity (implementation-vicinity) "Transcen")))) + (else + (define (infinite? z) #f) + (define finite? number?) + (define inexact->exact identity) + (define exact->inexact identity) + (define round->exact identity) + (define floor->exact identity) + (define ceiling->exact identity) + (define truncate->exact identity) + (define expt integer-expt))) + +(define (numerator q) + (if (not (rational? q)) (error 'numerator q)) + (do ((num q (* 2 num))) + ((integer? num) num))) + +(define (denominator q) + (if (not (rational? q)) (error 'denominator q)) + (do ((num q (* 2 num)) + (den (- q q -1) (* 2 den))) + ((integer? num) den))) +;@ +(define (integer-log base k) + (define (ilog m b k) + (cond ((< k b) k) + (else + (set! n (+ n m)) + (let ((q (ilog (+ m m) (* b b) (quotient k b)))) + (cond ((< q b) q) + (else (set! n (+ m n)) + (quotient q b))))))) + (define n 1) + (define (eigt? k j) (and (exact? k) (integer? k) (> k j))) + (cond ((not (and (eigt? base 1) (eigt? k 0))) + (slib:error 'integer-log base k)) + ((< k base) 0) + (else (ilog 1 base (quotient k base)) n))) + +;;;; http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/code/math/isqrt/isqrt.txt +;;; Akira Kurihara +;;; School of Mathematics +;;; Japan Women's University +;@ +(define integer-sqrt + (let ((table '#(0 + 1 1 1 + 2 2 2 2 2 + 3 3 3 3 3 3 3 + 4 4 4 4 4 4 4 4 4)) + (square (lambda (x) (* x x)))) + (lambda (n) + (define (isqrt n) + (if (> n 24) + (let* ((len/4 (quotient (- (integer-length n) 1) 4)) + (top (isqrt (ash n (* -2 len/4)))) + (init (ash top len/4)) + (q (quotient n init)) + (iter (quotient (+ init q) 2))) + (cond ((odd? q) iter) + ((< (remainder n init) (square (- iter init))) (- iter 1)) + (else iter))) + (vector-ref table n))) + (if (and (exact? n) (integer? n) (not (negative? n))) + (isqrt n) + (type-error 'integer-sqrt n))))) + +(if (defined? array?) +(begin + +(define (array-null? array) + (zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd))) + (array-shape array))))) +(define (create-array prot . args) + (if (array-null? prot) + (dimensions->uniform-array args (array-prototype prot)) + (dimensions->uniform-array args (array-prototype prot) + (apply array-ref prot + (map car (array-shape prot)))))) +(define make-array create-array) +(define (list->array rank proto lst) + (list->uniform-array rank (array-prototype proto) lst)) +(define (vector->array vect prototype . dimensions) + (define vdx (vector-length vect)) + (if (not (eqv? vdx (apply * dimensions))) + (slib:error 'vector->array vdx '<> (cons '* dimensions))) + (let ((ra (apply make-array prototype dimensions))) + (define (v2ra dims idxs) + (cond ((null? dims) + (set! vdx (+ -1 vdx)) + (apply array-set! ra (vector-ref vect vdx) (reverse idxs))) + (else + (do ((idx (+ -1 (car dims)) (+ -1 idx))) + ((negative? idx) vect) + (v2ra (cdr dims) (cons idx idxs)))))) + (v2ra dimensions '()) + ra)) +(define (array->vector ra) + (define dims (array-dimensions ra)) + (let* ((vdx (apply * dims)) + (vect (make-vector vdx))) + (define (ra2v dims idxs) + (if (null? dims) + (let ((val (apply array-ref ra (reverse idxs)))) + (set! vdx (+ -1 vdx)) + (vector-set! vect vdx val) + vect) + (do ((idx (+ -1 (car dims)) (+ -1 idx))) + ((negative? idx) vect) + (ra2v (cdr dims) (cons idx idxs))))) + (ra2v dims '()))) +(define (make-uniform-wrapper prot) + (if (string? prot) (set! prot (string->number prot))) + (if prot + (lambda opt (if (null? opt) + (list->uniform-array 1 prot '()) + (list->uniform-array 0 prot (car opt)))) + vector)) +(define Ac64 (make-uniform-wrapper "+64i")) +(define Ac32 (make-uniform-wrapper "+32i")) +(define Ar64 (make-uniform-wrapper "64.")) +(define Ar32 (make-uniform-wrapper "32.")) +(define As64 (make-uniform-wrapper -64)) +(define As32 (make-uniform-wrapper -32)) +(define As16 (make-uniform-wrapper -16)) +(define As8 (make-uniform-wrapper -8)) +(define Au64 (make-uniform-wrapper 64)) +(define Au32 (make-uniform-wrapper 32)) +(define Au16 (make-uniform-wrapper 16)) +(define Au8 (make-uniform-wrapper 8)) +(define At1 (make-uniform-wrapper #t)) + +;;; New SRFI-58 names +;; flonums +(define A:floC128b Ac64) +(define A:floC64b Ac64) +(define A:floC32b Ac32) +(define A:floC16b Ac32) +(define A:floR128b Ar64) +(define A:floR64b Ar64) +(define A:floR32b Ar32) +(define A:floR16b Ar32) +;; decimal flonums +(define A:floQ128d Ar64) +(define A:floQ64d Ar64) +(define A:floQ32d Ar32) +;; fixnums +(define A:fixZ64b As64) +(define A:fixZ32b As32) +(define A:fixZ16b As16) +(define A:fixZ8b As8) +(define A:fixN64b Au64) +(define A:fixN32b Au32) +(define A:fixN16b Au16) +(define A:fixN8b Au8) +(define A:bool At1) + +(define (array-shape a) + (let ((dims (array-dimensions a))) + (if (pair? dims) + (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) + dims) + dims))) +(define array=? equal?) +(provide 'srfi-47) +(provide 'srfi-58) +(provide 'srfi-63) +)) + +(define (alarm-interrupt) (alarm 0)) +(if (defined? setitimer) + (begin + (define profile-alarm #f) + (define (profile-alarm-interrupt) (profile-alarm 0)) + (define virtual-alarm #f) + (define (virtual-alarm-interrupt) (virtual-alarm 0)) + (define milli-alarm #f) + (let ((make-alarm + (lambda (sym) + (and (setitimer sym 0 0) ;DJGPP supports only REAL and PROFILE + (lambda (value . interval) + (cadr + (setitimer sym value + (if (pair? interval) (car interval) 0)))))))) + (set! profile-alarm (make-alarm 'profile)) + (set! virtual-alarm (make-alarm 'virtual)) + (set! milli-alarm (make-alarm 'real))))) + +;;;; Initialize statically linked add-ons +(cond ((defined? scm_init_extensions) + (scm_init_extensions) + (if (defined? *features*) (set! slib:features *features*)) + (set! scm_init_extensions #f))) + +;;; Use *argv* instead of (program-arguments), to allow option +;;; processing to be done on it. "ScmInit.scm" must +;;; (set! *argv* (program-arguments)) +;;; if it wants to alter the arguments which BOOT-TAIL processes. +(define *argv* #f) + +(if (not (defined? *syntax-rules*)) + (define *syntax-rules* #f)) +(if (not (defined? *interactive*)) + (define *interactive* #f)) + +(define (boot-tail dumped?) + (cond ((not *argv*) + (set! *argv* (program-arguments)) + (cond (dumped? + (set-vicinities! dumped?) + (verbose (if (and (isatty? (current-input-port)) + (isatty? (current-output-port))) + (if (<= (length *argv*) 1) 2 1) + 0)))) + (cond ((provided? 'getopt) + (set! *optind* 1) + (set! *optarg* #f))))) + +;;; This loads the user's initialization file, or files named in +;;; program arguments. + (or *script* + (eq? (software-type) 'THINKC) + (member "-no-init-file" (program-arguments)) + (member "--no-init-file" (program-arguments)) + (try-load (in-vicinity (or (home-vicinity) (user-vicinity)) + (string-append "ScmInit") (scheme-file-suffix)) + *load-reader*) + (errno 0)) + + ;; Include line numbers in loaded code. + (if (defined? read-numbered) + (set! *load-reader* read-numbered)) + + (cond + ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0))) + (require 'getopt) +;;; (else +;;; (define *optind* 1) +;;; (define getopt:opt #f) +;;; (define (getopt optstring) #f)) + + (let* ((simple-opts "muvqibs") + (arg-opts '("a kbytes" "-version" "-help" + "no-init-file" "-no-init-file" "p number" + "h feature" "r feature" "d filename" + "f filename" "l filename" + "c string" "e string" "o filename")) + (opts (apply string-append ":" simple-opts + (map (lambda (o) + (string-append (string (string-ref o 0)) ":")) + arg-opts))) + (didsomething #f) + (moreopts #t) + (exe-name (symbol->string (scheme-implementation-type))) + (up-name (apply string (map char-upcase (string->list exe-name))))) + + (define (do-thunk thunk) + (if *interactive* + (thunk) + (let ((complete #f)) + (dynamic-wind + (lambda () #f) + (lambda () + (thunk) + (set! complete #t)) + (lambda () + (if (not complete) (close-port (current-input-port)))))))) + + (define (do-string-arg) + (require 'string-port) + (do-thunk + (lambda () + ((if *syntax-rules* macro:eval eval) + (call-with-input-string + (string-append "(begin " *optarg* ")") + read)))) + (set! didsomething #t)) + + (define (do-load file) + (do-thunk + (lambda () + (cond (*syntax-rules* (require 'macro) (macro:load file)) + (else (load file))))) + (set! didsomething #t)) + + (define (usage preopt opt postopt success?) + (define cep (if success? (current-output-port) (current-error-port))) + (define indent (make-string 6 #\space)) + (define i 3) + (cond ((char? opt) (set! opt (string opt))) + ;;((symbol? opt) (set! opt (symbol->string opt))) + ) + (display (string-append preopt opt postopt) cep) + (newline cep) + (display (string-append "Usage: " + exe-name + " [-a kbytes] [-" simple-opts "]") cep) + (for-each + (lambda (o) + (display (string-append " [-" o "]") cep) + (set! i (+ 1 i)) + (cond ((zero? (modulo i 5)) (newline cep) (display indent cep)))) + (cdr arg-opts)) + (display " [-- | -s | -] [file] [args...]" cep) (newline cep) + (if success? (display success? cep) (quit #f))) + + ;; -a int => ignore (handled by scm_init_from_argv) + ;; -c str => (eval str) + ;; -e str => (eval str) + ;; -d str => (require 'databases) (open-database str) + ;; -f str => (load str) + ;; -l str => (load str) + ;; -r sym => (require sym) + ;; -h sym => (provide sym) + ;; -o str => (dump str) + ;; -p int => (verbose int) + ;; -m => (set! *syntax-rules* #t) + ;; -u => (set! *syntax-rules* #f) + ;; -v => (verbose 3) + ;; -q => (verbose 0) + ;; -i => (set! *interactive* #t) + ;; -b => (set! *interactive* #f) + ;; -s => set argv, don't execute first one + ;; -no-init-file => don't load init file + ;; --no-init-file => don't load init file + ;; --help => print and exit + ;; --version => print and exit + ;; -- => last option + + (let loop ((option (getopt-- opts))) + (case option + ((#\a) + (cond ((> *optind* 3) + (usage "scm: option `-" getopt:opt "' must be first" #f)) + ((or (not (exact? (string->number *optarg*))) + (not (<= 1 (string->number *optarg*) 10000))) + ;; This size limit should match scm.c ^^ + (usage "scm: option `-" getopt:opt + (string-append *optarg* "' unreasonable") #f)))) + ((#\e #\c) (do-string-arg)) ;sh-like + ((#\f #\l) (do-load *optarg*)) ;(set-car! *argv* *optarg*) + ((#\d) (require 'databases) + (open-database *optarg*)) + ((#\o) (require 'dump) + (if (< *optind* (length *argv*)) + (dump *optarg* #t) + (dump *optarg*))) + ((#\r) (do-thunk (lambda () + (if (and (= 1 (string-length *optarg*)) + (char-numeric? (string-ref *optarg* 0))) + (case (string-ref *optarg* 0) + ((#\2) (require 'r2rs)) + ((#\3) (require 'r3rs)) + ((#\4) (require 'r4rs)) + ((#\5) (require 'r5rs) + (set! *syntax-rules* #t)) + (else (require (string->symbol *optarg*)))) + (require (string->symbol *optarg*)))))) + ((#\h) (do-thunk (lambda () (provide (string->symbol *optarg*))))) + ((#\p) (verbose (string->number *optarg*))) + ((#\q) (verbose 0)) + ((#\v) (verbose 3)) + ((#\i) (set! *interactive* #t) ;sh-like + (verbose (max 2 (verbose)))) + ((#\b) (set! didsomething #t) + (set! *interactive* #f)) + ((#\s) (set! moreopts #f) ;sh-like + (set! didsomething #t) + (set! *interactive* #t)) + ((#\m) (set! *syntax-rules* #t)) + ((#\u) (set! *syntax-rules* #f)) + ((#\n) (if (not (string=? "o-init-file" *optarg*)) + (usage "scm: unrecognized option `-n" *optarg* "'" #f))) + ((#\:) (usage "scm: option `-" getopt:opt "' requires an argument" #f)) + ((#\?) (usage "scm: unrecognized option `-" getopt:opt "'" #f)) + ((#f) (set! moreopts #f) ;sh-like + (cond ((and (< *optind* (length *argv*)) + (string=? "-" (list-ref *argv* *optind*))) + (set! *optind* (+ 1 *optind*))))) + (else + (or (cond ((not (string? option)) #f) + ((string-ci=? "no-init-file" option)) + ((string-ci=? "version" option) + (display + (string-append exe-name " " + (scheme-implementation-version) + " +Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. +" + up-name + " may be distributed under the terms of" + " the GNU General Public Licence; +certain other uses are permitted as well." + " For details, see the file `COPYING', +which is included in the " + up-name " distribution. +There is no warranty, to the extent permitted by law. +" + )) + (cond ((execpath) => + (lambda (path) + (display " This executable was loaded from ") + (write path) + (newline)))) + (quit #t)) + ((string-ci=? "help" option) + (usage "This is " + up-name + ", a Scheme interpreter." + (let ((sihp (scheme-implementation-home-page))) + (if sihp + (string-append "Latest info: " sihp " +") + ""))) + (quit #t)) + (else #f)) + (usage "scm: unknown option `--" option "'" #f)))) + + (cond ((and moreopts (< *optind* (length *argv*))) + (loop (getopt-- opts))) + ((< *optind* (length *argv*)) ;No more opts + (set! *argv* (list-tail *argv* *optind*)) + (set! *optind* 1) + (cond ((and (not didsomething) *script*) + (do-load *script*) + (set! *optind* (+ 1 *optind*)))) + (cond ((and (> (verbose) 2) + (not (= (+ -1 *optind*) (length *argv*)))) + (display "scm: extra command arguments unused:" + (current-error-port)) + (for-each (lambda (x) (display (string-append " " x) + (current-error-port))) + (list-tail *argv* (+ -1 *optind*))) + (newline (current-error-port))))) + ((and (not didsomething) (= *optind* (length *argv*))) + (set! *interactive* #t))))) + + (cond ((not *interactive*) (quit)) + ((and *syntax-rules* (not (provided? 'macro))) + (require 'repl) + (require 'macro) + (let* ((oquit quit)) + (set! quit (lambda () (repl:quit))) + (set! exit quit) + (repl:top-level macro:eval) + (oquit)))) + ;;otherwise, fall into natural SCM repl. + ) + (else (errno 0) + (set! *interactive* #t) + (for-each load (cdr (program-arguments)))))) |