From 90889a692076f2c62486607d0354e0fca52364bc Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:40 -0800 Subject: Import Upstream version 5e5 --- Init5e4.scm | 1643 ----------------------------------------------------------- 1 file changed, 1643 deletions(-) delete mode 100644 Init5e4.scm (limited to 'Init5e4.scm') diff --git a/Init5e4.scm b/Init5e4.scm deleted file mode 100644 index bd5874f..0000000 --- a/Init5e4.scm +++ /dev/null @@ -1,1643 +0,0 @@ -;; 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) "5e4") -(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 ) ) -;@ -(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 - math-integer ;math-real and srfi-94 provided in "Transcen.scm" - vicinity srfi-59 srfi-23 - 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 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)))))))))) - -(if (not (defined? file-position)) -(define (file-position . args) #f)) -(if (not (defined? file-set-position)) -(define file-set-position file-position)) - -(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) - (fluid-let ((*load-reader* *slib-load-reader*)) - (scm:load-source file))) -(define (slib:load file . libs) - (fluid-let ((*load-reader* *slib-load-reader*)) - (apply scm:load file libs))) - -;;; 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 -;;BITWISE-BIT-COUNT returns negative count for negative inputs. -(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 ) 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 ) 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) - (slib: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-symbol-case-fold" - "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-symbol-case-fold => symbols preserve character case - ;; -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=? "no-symbol-case-fold" 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)))))) -- cgit v1.2.3