diff options
Diffstat (limited to 'Init5d2.scm')
| -rw-r--r-- | Init5d2.scm | 1092 |
1 files changed, 1092 insertions, 0 deletions
diff --git a/Init5d2.scm b/Init5d2.scm new file mode 100644 index 0000000..19c2ff2 --- /dev/null +++ b/Init5d2.scm @@ -0,0 +1,1092 @@ +;; Copyright (C) 1991-1999 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 GUILE. +;; +;; The exception is that, if you link the GUILE 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 GUILE 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 GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, 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 GUILE, 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) "5d2") +(define (scheme-implementation-home-page) + "http://swissnet.ai.mit.edu/~jaffer/SCM.html") + +(define vicinity:suffix? + (let ((suffi + (case (software-type) + ((AMIGA) '(#\: #\/)) + ((MACOS THINKC) '(#\:)) + ((MS-DOS WINDOWS ATARIST OS/2) '(#\\ #\/)) + ((NOSVE) '(#\: #\.)) + ((UNIX COHERENT) '(#\/)) + ((VMS) '(#\: #\]))))) + (lambda (chr) (memv chr suffi)))) + +(define (pathname->vicinity pathname) + ;;Go up one level if PATHNAME ends in a vicinity suffix. + (let loop ((i (- (string-length pathname) 2))) + (cond ((negative? i) "") + ((vicinity:suffix? (string-ref pathname i)) + (substring pathname 0 (+ i 1))) + (else (loop (- i 1)))))) + +;;; This definition of PROGRAM-VICINITY is equivalent to the one defined +;;; SLIB/require.scm. It is used here to bootstrap +;;; IMPLEMENTATION-VICINITY and possibly LIBRARY-VICINITY. + +(define (program-vicinity) + (if *load-pathname* + (pathname->vicinity *load-pathname*) + (error "not loading but called" 'program-vicinity))) + +(define in-vicinity string-append) + +;;; 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. + +;;; 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 library-vicinity #f) +(define home-vicinity #f) +(define (set-vicinities! init-file) + (set! implementation-vicinity + (let ((vic (pathname->vicinity init-file))) + (lambda () vic))) + (set! library-vicinity + (let ((library-path (getenv "SCHEME_LIBRARY_PATH"))) + (if library-path + (lambda () library-path) + (lambda () + (let ((olv library-vicinity) + (oload load)) + (dynamic-wind + (lambda () (set! load identity)) + (lambda () + (try-load (in-vicinity (implementation-vicinity) + "require.scm"))) + (lambda () (set! load oload))) + (if (eq? olv library-vicinity) + (error "Can't find library-vicinity")) + (library-vicinity)))))) + (set! home-vicinity + (let ((home (getenv "HOME"))) + (and home + (case (software-type) + ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME + (if (not + (char=? #\/ + (string-ref home (+ -1 (string-length home))))) + (set! home (string-append home "/")))))) + (lambda () home)))) +(set-vicinities! *load-pathname*) + +;;; Here for backward compatability +(define scheme-file-suffix + (case (software-type) + ((NOSVE) (lambda () "_scm")) + (else (lambda () ".scm")))) + +(set! *features* + (append '(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) + *features*)) + +(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) + (call-with-input-file file + (lambda (inport) + (do ((c (read-char inport) (read-char inport))) + ((eof-object? c)) + (write-char c))))) +(define (terms) + (display-file "/usr/doc/copyright/GPL")) + +;; Array syntax: +;; n is a decimal number, which may be elided for a default value of 1. +;; #nA\( ... ) character array +;; #nAt( ... ) boolean array +;; #nAe[sfdl]( ... ) exact number array +;; #nAu[sfdl]( ... ) positive exact number array +;; #nAi[sfdl]( ... ) inexact real number array +;; #nAic[sfdl]( ... ) inexact complex number array + +(define (read:array rank port) + (let ((prot + (case (char-downcase (peek-char port)) + ((#\\) (read-char port) #\a) + ((#\t) (read-char port) #t) + ((#\e) + (read-char port) + (case (char-downcase (peek-char port)) + ((#\s) (read-char port) 'exact-short) + ((#\f #\d #\l) (read-char port) -2) + (else -2))) + ((#\u) + (read-char port) + (case (char-downcase (peek-char port)) + ((#\s #\f #\d #\l) (read-char port) 2) + (else 2))) + ((#\i) + (read-char port) + (case (char-downcase (peek-char port)) + ((#\c) + (read-char port) + (case (char-downcase (peek-char port)) + ((#\s #\f #\d #\l) (read-char port))) + 0+1.0i) + ((#\s #\f) (read-char port) 1.0) + ((#\d #\l) (read-char port) 1/3) + (else 1/3))) + (else #f)))) + (list->uniform-array rank prot (read port)))) + +(define (read:sharp c port) + (define (barf c) + (error "unknown # object" c)) + (define chr0 (char->integer #\0)) + (define (feature? exp) + (cond ((symbol? exp) + (or (memq exp *features*) (eq? exp (software-type)))) + ((and (pair? exp) (list? exp)) + (case (car exp) + ((not) (not (feature? (cadr exp)))) + ((or) (if (null? (cdr exp)) #f + (or (feature? (cadr exp)) + (feature? (cons 'or (cddr exp)))))) + ((and) (if (null? (cdr exp)) #t + (and (feature? (cadr exp)) + (feature? (cons 'and (cddr exp)))))) + (else (error "read:sharp+ invalid expression " exp)))))) + (case c + ((#\') (read port)) + ((#\.) (eval (read port))) + ((#\+) (if (feature? (read port)) + (read port) + (begin (read port) (if #f #f)))) + ((#\-) (if (not (feature? (read port))) + (read port) + (begin (read port) (if #f #f)))) + ((#\a #\A) (read:array 1 port)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let loop ((arg (- (char->integer c) chr0))) + (let ((c (peek-char port))) + (cond ((char-numeric? c) + (loop (+ (* 10 arg) + (- (char->integer (read-char port)) chr0)))) + ((memv c '(#\a #\A)) + (read-char port) + (read:array arg port)) + (else + (warn "obsolete array read syntax") + (read:array arg port)))))) + ((#\!) (if (= 1 (line-number)) + (let skip ((metarg? #f)) + (case (read-char port) + ((#\newline) (if metarg? (skip #t))) + ((#\\) (skip #t)) + ((#\!) (if (not (and (eqv? #\# (peek-char port)) + (read-char port))) + (skip metarg?))) + (else (skip metarg?)))) + (barf c))) + (else (barf c)))) + +;; We can assume TOK has at least 2 characters. +(define read:sharp-char + (letrec ((control (lambda (c) + (and (char? c) + (if (eqv? c #\?) + (integer->char 127) + (integer->char + (logand 31 (char->integer c))))))) + (meta (lambda (c) + (and (char? c) + (integer->char + (logior 128 (char->integer c))))))) + (lambda (tok) + (case (string-ref tok 0) + ((#\C #\c) + (and (char=? #\- (string-ref tok 1)) + (if (= 3 (string-length tok)) + (control (string-ref tok 2)) + (let ((c (read:sharp-char + (substring tok 2 (string-length tok))))) + (and c (control c)))))) + ((#\^) + (and (= 2 (string-length tok)) + (control (string-ref tok 1)))) + ((#\M #\m) + (and (char=? #\- (string-ref tok 1)) + (if (= 3 (string-length tok)) + (meta (string-ref tok 2)) + (let ((c (read:sharp-char + (substring tok 2 (string-length tok))))) + (and c (meta c)))))))))) + +;;;; 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*))))))) + +;; Make #; convert the rest of the line to a (comment ...) form. +;; "build.scm" uses this. +(define read:sharp + (let ((rdsharp read:sharp)) + (lambda (c port) + (if (eqv? c #\;) + (let skip-semi () + (cond ((eqv? #\; (peek-char port)) + (read-char port) + (skip-semi)) + (else `(comment ,(read-line port))))) + (rdsharp c port))))) + + +(define type 'type) ;for /bin/sh hack. +(define : ':) +(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 + (if (defined? cr) cr (lambda (x) x))) + +(if (not (defined? the-macro)) + (define the-macro identity)) +(define 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 ATARIST) "wb") + (else "w"))) +(define OPEN_BOTH (case (software-type) + ((MS-DOS WINDOWS ATARIST) "r+b") + (else "r+"))) +(define (_IONBF mode) (string-append mode "0")) +(define (_TRACKED mode) (string-append mode "?")) + +(define could-not-open #f) + +(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 (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-io-file str) (open-file str OPEN_BOTH)) + +(define close-input-port close-port) +(define close-output-port close-port) +(define close-io-port close-port) + +(define (call-with-input-file str proc) + (let* ((file (open-input-file str)) + (ans (proc file))) + (close-input-port file) + ans)) + +(define (call-with-output-file str proc) + (let* ((file (open-output-file str)) + (ans (proc file))) + (close-output-port file) + ans)) + +(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 (warn . args) + (define cep (current-error-port)) + (perror "WARN") + (errno 0) + (display "WARN: " cep) + (if (not (null? args)) + (begin (display (car args) cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) + (cdr args)))) + (newline cep) + (force-output cep)) + +(define (error . args) + (define cep (current-error-port)) + (perror "ERROR") + (errno 0) + (display "ERROR: " cep) + (if (not (null? args)) + (begin (display (car args) cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) + (cdr 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 #\ )) args) + (newline) + result) +(define (pp . args) + (for-each pretty-print args) + (if #f #f)) + +(define (file-exists? str) + (let ((port (open-file str OPEN_READ))) + (and port (close-port port) #t))) +(define (file-readable? str) + (let ((port (open-file str OPEN_READ))) + (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 (memq 'ed *features*)) + (begin + (define (ed . args) + (system (apply string-append + (or (getenv "EDITOR") "editor") + (map (lambda (s) (string-append " " s)) args)))) + (set! *features* (cons 'ed *features*)))) + +(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) + +;;; Load. +(define load:indent 0) +(define (load:pre file) + (define cep (current-error-port)) + (cond ((> (verbose) 1) + (display + (string-append ";" (make-string load:indent #\ ) "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 #\ ) + "done loading " filesuf) + cep) + (newline cep) + (force-output cep)))) + +(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 (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)) + ;;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)) + (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) + ;;HERE is where the suffix gets specified + (and (not (has-suffix? file sfs)) + (begin (set! filesuf (string-append file sfs)) + (try-load filesuf))))) + (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) + +(load (in-vicinity (library-vicinity) "require")) + +;;; DO NOT MOVE! This must be done after "require.scm" is loaded. +(define slib:load-source scm:load-source) +(define slib:load scm:load) + +(cond ((or (defined? dyn:link) + (defined? vms:dynamic-link-call) + (file-exists? (in-vicinity (implementation-vicinity) "hobbit.tms"))) + (load (in-vicinity (implementation-vicinity) "Link")))) + +(cond ((defined? link:link) + (define (slib:load-compiled . args) + (or (apply link:link args) + (error "Couldn't link files " args))) + (provide 'compiled))) + +(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 + (if (equal? "a" (symbol->string 'a)) + (lambda (str) (string->symbol (string-downcase str))) + (lambda (str) (string->symbol (string-upcase str))))) + +(define logical:logand logand) +(define logical:logior logior) +(define logical:logxor logxor) +(define logical:lognot lognot) +(define logical:ash ash) +(define logical:logcount logcount) +(define logical:integer-length integer-length) +(define logical:integer-expt integer-expt) + +(define logical:bit-field bit-field) +(define bit-extract bit-field) +(define logical:bitwise-if bitwise-if) +(define logical:copy-bit copy-bit) +(define logical:copy-bit-field copy-bit-field) + +(define (logical:ipow-by-squaring x k acc proc) + (cond ((zero? k) acc) + ((= 1 k) (proc acc x)) + (else (logical:ipow-by-squaring (proc x x) + (quotient k 2) + (if (even? k) acc (proc acc x)) + proc)))) + +;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 (cdr exp))))))) + +(define defmacro + (let ((defmacro-transformer + (lambda (name parms . body) + `(define ,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))) + +(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) + +(define (slib:eval-load <filename> evl) + (if (not (file-exists? <filename>)) + (set! <filename> (string-append <filename> (scheme-file-suffix)))) + (call-with-input-file <filename> + (lambda (port) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* <filename>) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o)) + (set! *load-pathname* old-load-pathname))))) + +;;; Autoloads for SLIB procedures. + +(define (tracef . args) (require 'trace) (apply tracef args)) +(define (trace:tracef . args) (require 'trace) (apply trace:tracef args)) +(define (trace-all . args) (require 'debug) (apply trace-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 redefmacroed when tracef autoloads. +(defmacro trace x + (if (null? x) '() + `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) x)))) +(defmacro break x + (if (null? x) '() + `(begin ,@(map (lambda (x) `(set! ,x (break:breakf ,x ',x))) 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 (slib:error 'trying-to-defconst name + 'to-different-value value))) + `(define ,name ,value)))) +(defmacro casev (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 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 print-args + (procedure->syntax + (lambda (sexp env) + (set! env (environment->tree env)) + (let ((frame (and (not (null? env)) (car env)))) + (cond ((not (null? (cdr sexp))) + (display "In") + (for-each (lambda (exp) (display #\ ) (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 vals))) + (newline)) + (write (car vars)) + (display " = ") + (write (car vals)) + (display "; ")))))) + +(cond + ((defined? stack-trace) + + #+breakpoint-error;; remove line to enable breakpointing on calls to ERROR + (define (error . args) + (define cep (current-error-port)) + (perror "ERROR") + (errno 0) + (display "ERROR: " cep) + (if (not (null? args)) + (begin (display (car args) cep) + (for-each (lambda (x) (display #\ 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)) + + (define (user-interrupt . args) + (define cep (current-error-port)) + (newline 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)) + )) + +;;; ABS and MAGNITUDE can be the same. +(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"))) + (set! abs magnitude))) + +(if (defined? array?) + (begin + (define uniform-vector? array?) + (define make-uniform-vector dimensions->uniform-array) +; (define uniform-vector-ref array-ref) + (define (uniform-vector-set! u i o) + (uniform-vector-set1! u o i)) +; (define uniform-vector-fill! array-fill!) +; (define uniform-vector-read! uniform-array-read!) +; (define uniform-vector-write uniform-array-write) + + (define (make-array fill . args) + (dimensions->uniform-array args () fill)) + (define (make-uniform-array prot . args) + (dimensions->uniform-array args prot)) + (define (list->array ndim lst) + (list->uniform-array ndim '() lst)) + (define (list->uniform-vector prot lst) + (list->uniform-array 1 prot lst)) + (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 (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) + (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? *R4RS-macro*)) + (define *R4RS-macro* #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 (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))) + (errno 0)) + + (cond + ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0))) + (require 'getopt) +;;; (else +;;; (define *optind* 1) +;;; (define getopt:opt #f) +;;; (define (getopt argc argv optstring) #f)) + + (let* ((simple-opts "muqvbis") + (arg-opts '("a kbytes" "no-init-file" "-no-init-file" + "-version" "-help" "p number" + "r feature" "f filename" "l filename" + "d 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))) + (argc (length *argv*)) + (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 *R4RS-macro* macro:eval eval) + (call-with-input-string + (string-append "(begin " *optarg* ")") + read)))) + (set! didsomething #t)) + + (define (do-load file) + (do-thunk + (lambda () + (cond (*R4RS-macro* (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 #\ )) + (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 4)) (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 'database-utilities) (open-database str) + ;; -f str => (load str) + ;; -l str => (load str) + ;; -r str => (require str) + ;; -o str => (dump str) + ;; -p int => (verbose int) + ;; -m => (set! *R4RS-macro* #t) + ;; -u => (set! *R4RS-macro* #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-- argc *argv* 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 'database-utilities) + (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 'rev3-procedures) + (require 'rev2-procedures)) + ((#\3) (require 'rev3-procedures)) + ((#\4) (require 'rev4-optional-procedures)) + ((#\5) (require 'values) + (require 'macro) + (require 'eval) + (set! *R4RS-macro* #t)) + (else (require (string->symbol *optarg*)))) + (require (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! *R4RS-macro* #t)) + ((#\u) (set! *R4RS-macro* #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-- argc *argv* 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 *R4RS-macro* (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 + (begin (errno 0) + (set! *interactive* #t) + (for-each load (cdr (program-arguments))))))) |