home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / unix / scheme_1 / !Scm_scm_Init < prev    next >
Encoding:
Text File  |  1994-06-27  |  21.3 KB  |  708 lines
  1. ;;;; "Init.scm", Scheme initialization code for SCM.
  2. ;;; Copyright (C) 1991, 1992, 1993, 1994 Aubrey Jaffer.
  3. ;;; See the file `COPYING' for terms applying to this program.
  4.  
  5. (define (scheme-implementation-type) 'SCM)
  6. (define (scheme-implementation-version) "4e1")
  7.  
  8. ;;; (library-vicinity) should be defined to be the pathname of the
  9. ;;; directory where files of Scheme library functions reside.
  10.  
  11. (define library-vicinity
  12.   (let ((library-path
  13.      (or (getenv "SCHEME_LIBRARY_PATH")
  14.          (case (software-type)
  15.            ((UNIX COHERENT) "/usr/local/lib/slib/")
  16.            ((VMS) "lib$scheme:")
  17.            ((MSDOS ATARIST) "C:\\SCM\\SLIB\\")
  18.            ((OS/2) "\\languages\\scm\\slib\\")
  19.            ((MACOS THINKC) "camus Napoleon:Think C4.0:scm3.0:")
  20.            ((AMIGA) "Scheme:libs/")
  21.            (else "")))))
  22.  
  23.     (lambda () library-path)))
  24.  
  25. ;;; program-vicinity is here in case the Scheme Library cannot be found.
  26. (define program-vicinity
  27.   (let ((*vicinity-suffix*
  28.      (case (software-type)
  29.        ((UNIX COHERENT) '(#\/))
  30.        ((AMIGA) '(#\: #\/))
  31.        ((VMS) '(#\: #\]))
  32.        ((MSDOS ATARIST OS/2) '(#\\))
  33.        ((MACOS THINKC) '(#\:)))))
  34.     (lambda ()
  35.       (let loop ((i (- (string-length *load-pathname*) 1)))
  36.     (cond ((negative? i) "")
  37.           ((memv (string-ref *load-pathname* i)
  38.              *vicinity-suffix*)
  39.            (substring *load-pathname* 0 (+ i 1)))
  40.           (else (loop (- i 1))))))))
  41.  
  42. ;;; Here for backward compatability
  43. (define scheme-file-suffix
  44.   (case (software-type)
  45.     ((NOSVE) (lambda () "_scm"))
  46.     ((archimedes) (lambda () ""))
  47.     (else (lambda () ".scm"))))
  48.  
  49. (set! *features*
  50.       (append '(getenv tmpnam system abort transcript with-file
  51.         ieee-p1178 rev4-report rev4-optional-procedures
  52.         hash object-hash delay eval dynamic-wind
  53.         multiarg-apply multiarg/and- logical defmacro
  54.         string-port source)
  55.           *features*))
  56.  
  57. (define in-vicinity string-append)
  58.  
  59. (define slib:exit quit)
  60.  
  61. ;;; This is the vicinity where this file resides.
  62. (define implementation-vicinity
  63. ;  (let ((vic (program-vicinity)))
  64. ;    (lambda () vic)))
  65. ;;; --- ams. 
  66.  (let ((vic "<scm$dir>."))
  67.     (lambda () vic)))
  68.     
  69.     
  70. (define (terms)
  71.   (list-file (in-vicinity (implementation-vicinity) "COPYING")))
  72.  
  73. (define (list-file file)
  74.   (call-with-input-file file
  75.     (lambda (inport)
  76.       (do ((c (read-char inport) (read-char inport)))
  77.       ((eof-object? c))
  78.     (write-char c)))))
  79.  
  80. (define (read:eval-feature exp)
  81.   (cond ((symbol? exp)
  82.      (or (memq exp *features*) (eq? exp (software-type))))
  83.     ((and (pair? exp) (list? exp))
  84.      (case (car exp)
  85.        ((not) (not (read:eval-feature (cadr exp))))
  86.        ((or) (if (null? (cdr exp)) #f
  87.              (or (read:eval-feature (cadr exp))
  88.              (read:eval-feature (cons 'or (cddr exp))))))
  89.        ((and) (if (null? (cdr exp)) #t
  90.               (and (read:eval-feature (cadr exp))
  91.                (read:eval-feature (cons 'and (cddr exp))))))
  92.        (else (error "read:sharp+ invalid expression " exp))))))
  93.  
  94. (define (read:array digit port)
  95.   (define chr0 (char->integer #\0))
  96.   (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
  97.         (if (char-numeric? (peek-char port))
  98.             (readnum (+ (* 10 val)
  99.                 (- (char->integer (read-char port)) chr0)))
  100.             val)))
  101.     (prot (if (eq? #\( (peek-char port))
  102.           '()
  103.           (let ((c (read-char port)))
  104.             (case c ((#\b) #t)
  105.               ((#\a) #\a)
  106.               ((#\u) 1)
  107.               ((#\e) -1)
  108.               ((#\s) 1.0)
  109.               ((#\i) 1/3)
  110.               ((#\c) 0+i)
  111.               (else (error "read:array unknown option " c)))))))
  112.     (if (eq? (peek-char port) #\()
  113.     (list->uniform-array rank prot (read port))
  114.     (error "read:array list not found"))))
  115.  
  116. (define (read:uniform-vector proto port)
  117.   (if (eq? #\( (peek-char port))
  118.       (list->uniform-array 1 proto (read port))
  119.       (error "read:uniform-vector list not found")))
  120.  
  121. (define (read:sharp c port)
  122.   (define (barf)
  123.     (error "unknown # object" c))
  124.   (case c ((#\') (read port))
  125.     ((#\+) (if (read:eval-feature (read port))
  126.            (read port)
  127.            (begin (read port) (if #f #f))))
  128.     ((#\-) (if (not (read:eval-feature (read port)))
  129.            (read port)
  130.            (begin (read port) (if #f #f))))
  131.     ((#\b) (read:uniform-vector #t port))
  132.     ((#\a) (read:uniform-vector #\a port))
  133.     ((#\u) (read:uniform-vector 1 port))
  134.     ((#\e) (read:uniform-vector -1 port))
  135.     ((#\s) (read:uniform-vector 1.0 port))
  136.     ((#\i) (read:uniform-vector 1/3 port))
  137.     ((#\c) (read:uniform-vector 0+i port))
  138.     ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  139.      (read:array c port))
  140.     ((#\!) (if (= 1 (line-number))
  141.            (let skip () (if (eq? #\newline (peek-char port))
  142.                     (if #f #f)
  143.                     (begin (read-char port) (skip))))
  144.            (barf)))
  145.     (else (barf))))
  146.  
  147. ;;;; Here are some Revised^2 Scheme functions:
  148. (define 1+
  149.   (let ((+ +))
  150.     (lambda (n) (+ n 1))))
  151. (define -1+
  152.   (let ((+ +))
  153.     (lambda (n) (+ n -1))))
  154. (define 1- -1+)
  155. (define <? <)
  156. (define <=? <=)
  157. (define =? =)
  158. (define >? >)
  159. (define >=? >=)
  160. (define t #t)
  161. (define nil #f)
  162. (define sequence begin)
  163.  
  164. (set! apply (lambda (fun . args) (@apply fun (apply:nconc-to-last args))))
  165. (define (call-with-current-continuation proc)
  166.   (@call-with-current-continuation proc))
  167.  
  168. ;;; VMS does something strange when output is sent to both
  169. ;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT.
  170. (case (software-type) ((VMS) (set-current-error-port (current-output-port))))
  171.  
  172. ;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
  173. ;;; mode to open files in.  MSDOS does carraige return - newline
  174. ;;; translation if not opened in `b' mode.
  175.  
  176. (define OPEN_READ (case (software-type)
  177.             ((MSDOS ATARIST) "rb")
  178.             (else "r")))
  179. (define OPEN_WRITE (case (software-type)
  180.              ((MSDOS ATARIST) "wb")
  181.              (else "w")))
  182. (define OPEN_BOTH (case (software-type)
  183.             ((MSDOS ATARIST) "r+b")
  184.             (else "r+")))
  185.  
  186. (define could-not-open #f)
  187.  
  188. (define (open-input-file str)
  189.   (or (open-file str OPEN_READ)
  190.       (and (procedure? could-not-open) (could-not-open) #f)
  191.       (error "OPEN-INPUT-FILE couldn't find file " str)))
  192. (define (open-output-file str)
  193.   (or (open-file str OPEN_WRITE)
  194.       (and (procedure? could-not-open) (could-not-open) #f)
  195.       (error "OPEN-OUTPUT-FILE couldn't find file " str)))
  196. (define (open-io-file str) (open-file str OPEN_BOTH))
  197.  
  198. (define close-input-port close-port)
  199. (define close-output-port close-port)
  200. (define close-io-port close-port)
  201.  
  202. (define (call-with-input-file str proc)
  203.   (let* ((file (open-input-file str))
  204.      (ans (proc file)))
  205.     (close-input-port file)
  206.     ans))
  207.  
  208. (define (call-with-output-file str proc)
  209.   (let* ((file (open-output-file str))
  210.      (ans (proc file)))
  211.     (close-output-port file)
  212.     ans))
  213.  
  214. (define (with-input-from-port port thunk)
  215.   (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
  216.     (dynamic-wind swaports thunk swaports)))
  217.  
  218. (define (with-output-to-port port thunk)
  219.   (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
  220.     (dynamic-wind swaports thunk swaports)))
  221.  
  222. (define (with-error-to-port port thunk)
  223.   (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
  224.     (dynamic-wind swaports thunk swaports)))
  225.  
  226. (define (with-input-from-file file thunk)
  227.   (let* ((nport (open-input-file file))
  228.      (ans (with-input-from-port nport thunk)))
  229.     (close-port nport)
  230.     ans))
  231.  
  232. (define (with-output-to-file file thunk)
  233.   (let* ((nport (open-output-file file))
  234.      (ans (with-output-to-port nport thunk)))
  235.     (close-port nport)
  236.     ans))
  237.  
  238. (define (with-error-to-file file thunk)
  239.   (let* ((nport (open-output-file file))
  240.      (ans (with-error-to-port nport thunk)))
  241.     (close-port nport)
  242.     ans))
  243.  
  244. (define (error . args)
  245.   (define cep (current-error-port))
  246.   (perror "ERROR")
  247.   (errno 0)
  248.   (display "ERROR: " cep)
  249.   (if (not (null? args))
  250.       (begin (display (car args) cep)
  251.          (for-each (lambda (x) (display #\  cep) (write x cep))
  252.                (cdr args))))
  253.   (newline cep)
  254.   (force-output cep)
  255.   (abort))
  256.  
  257. (define set-errno errno)
  258. (define exit quit)
  259.  
  260. (define (file-exists? str)
  261.   (let ((port (open-file str OPEN_READ)))
  262.     (if port (begin (close-port port) #t)
  263.     #f)))
  264.  
  265. (if (memq 'line-i/o *features*)
  266.     (define (write-line str . arg)
  267.       (apply display str arg)
  268.       (apply newline arg)))
  269.  
  270. (if (memq 'pipe *features*)
  271.     (define (open-input-pipe str) (open-pipe str "r")))
  272. (if (memq 'pipe *features*)
  273.     (define (open-output-pipe str) (open-pipe str "w")))
  274.  
  275. (if (not (memq 'ed *features*))
  276.     (begin
  277.       (define (ed . args)
  278.     (system (apply string-append
  279.                (or (getenv "EDITOR") "ed")
  280.                (map (lambda (s) (string-append " " s)) args))))
  281.       (set! *features* (cons 'ed *features*))))
  282.  
  283. (if (not (defined? output-port-width))
  284.     (define (output-port-width . arg) 80))
  285.  
  286. (if (not (defined? output-port-height))
  287.     (define (output-port-height . arg) 24))
  288.  
  289. (define (has-suffix? str suffix)
  290.   (let ((sufl (string-length suffix))
  291.     (sl (string-length str)))
  292.     (and (> sl sufl)
  293.      (string=? (substring str (- sl sufl) sl) suffix))))
  294.  
  295. (define slib:error error)
  296. (define slib:tab #\tab)
  297. (define slib:form-feed #\page)
  298. (define slib:eval eval)
  299.  
  300. ;;; Load.
  301. (define (scm:load file . libs)
  302.   (define sfs (scheme-file-suffix))
  303.   (define cep (current-error-port))
  304.   (define filesuf file)
  305.   (define hss (has-suffix? file sfs))
  306.   (cond ((> (verbose) 1)
  307.      (display ";loading " cep) (write file cep) (newline cep)))
  308.   (force-output cep)
  309.   (or (and (defined? link:link) (not hss)
  310.        (or (apply link:link file libs)
  311.            (and link:able-suffix
  312.             (let ((fs (string-append file link:able-suffix)))
  313.               (cond ((not (file-exists? fs)) #f)
  314.                 ((apply link:link fs libs) (set! filesuf fs) #t)
  315.                 (else #f))))))
  316.       (and (null? libs)
  317.        (or (try-load file)
  318.            ;;HERE is where the suffix gets specified
  319.            (and (not hss)
  320.             (begin (set! filesuf (string-append file sfs))
  321.                (try-load filesuf)))))
  322.       (and (procedure? could-not-open) (could-not-open) #f)
  323.       (error "LOAD couldn't find file " file))
  324.   (errno 0)
  325.   (cond ((> (verbose) 1)
  326.      (display ";done loading " cep) (write filesuf cep) (newline cep)
  327.      (force-output cep))))
  328. (define load scm:load)
  329. (define slib:load load)
  330.  
  331. (define (scm:load-source file)
  332.   (define sfs (scheme-file-suffix))
  333.   (define cep (current-error-port))
  334.   (define filesuf file)
  335.   (cond ((> (verbose) 1)
  336.      (display ";loading " cep) (write file cep) (newline cep)))
  337.   (force-output cep)
  338.   (or (and (or (try-load file)
  339.            ;;HERE is where the suffix gets specified
  340.            (and (not (has-suffix? file sfs))
  341.             (begin (set! filesuf (string-append file sfs))
  342.                (try-load filesuf)))))
  343.       (and (procedure? could-not-open) (could-not-open) #f)
  344.       (error "LOAD couldn't find file " file))
  345.   (errno 0)
  346.   (cond ((> (verbose) 1)
  347.      (display ";done loading " cep) (write filesuf cep) (newline cep)
  348.      (force-output cep))))
  349. (define slib:load-source scm:load-source)
  350.  
  351. (cond ((try-load
  352.     (in-vicinity (library-vicinity) "require" (scheme-file-suffix))))
  353.       (else
  354.        (perror "WARNING")
  355.        (display "WARNING: Couldn't find require.scm in (library-vicinity)"
  356.         (current-error-port))
  357.        (write (library-vicinity) (current-error-port))
  358.        (newline (current-error-port))
  359.        (errno 0)))
  360.  
  361. ;;; DO NOT MOVE!  This has to be done after "require.scm" is loaded.
  362. (define slib:load-source scm:load-source)
  363. (define slib:load scm:load)
  364.  
  365. (if (or (defined? dld:link)
  366.     (defined? shl:load)
  367.     (defined? vms:dynamic-link-call)
  368.     (file-exists? (in-vicinity (implementation-vicinity) "hobbit.tms")))
  369.     (try-load (in-vicinity (implementation-vicinity)
  370.                "Link" (scheme-file-suffix))))
  371.  
  372. (cond ((defined? link:link)
  373.        (define slib:load-compiled link:link)
  374.        (provide 'compiled)))
  375.  
  376. (define logical:logand logand)
  377. (define logical:logior logior)
  378. (define logical:logxor logxor)
  379. (define logical:lognot lognot)
  380. (define logical:ash ash)
  381. (define logical:logcount logcount)
  382. (define logical:integer-length integer-length)
  383. (define logical:bit-extract bit-extract)
  384. (define logical:integer-expt integer-expt)
  385.  
  386. (define (logical:ipow-by-squaring x k acc proc)
  387.   (cond ((zero? k) acc)
  388.     ((= 1 k) (proc acc x))
  389.     (else (logical:ipow-by-squaring (proc x x)
  390.                     (quotient k 2)
  391.                     (if (even? k) acc (proc acc x))
  392.                     proc))))
  393.  
  394. ;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer):
  395. (define *defmacros* '())
  396. (define (macro? m) (and (assq m *defmacros*) #t))
  397.  
  398. (define defmacro:transformer
  399.   (lambda (f)
  400.     (procedure->memoizing-macro
  401.       (lambda (exp env)
  402.     (copy-tree (apply f (cdr exp)))))))
  403.  
  404. (define defmacro
  405.   (let ((defmacro-transformer
  406.       (lambda (name parms . body)
  407.         `(define ,name
  408.            (let ((transformer (lambda ,parms ,@body)))
  409.          (set! *defmacros* (acons ',name transformer *defmacros*))
  410.          (defmacro:transformer transformer))))))
  411.     (set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*))
  412.     (defmacro:transformer defmacro-transformer)))
  413.  
  414. (define (macroexpand-1 e)
  415.   (if (pair? e) (let ((a (car e)))
  416.           (cond ((symbol? a) (set! a (assq a *defmacros*))
  417.                      (if a (apply (cdr a) (cdr e)) e))
  418.             (else e)))
  419.       e))
  420.  
  421. (define (macroexpand e)
  422.   (if (pair? e) (let ((a (car e)))
  423.           (cond ((symbol? a)
  424.              (set! a (assq a *defmacros*))
  425.              (if a (macroexpand (apply (cdr a) (cdr e))) e))
  426.             (else e)))
  427.       e))
  428.  
  429. (define gentemp
  430.   (let ((*gensym-counter* -1))
  431.     (lambda ()
  432.       (set! *gensym-counter* (+ *gensym-counter* 1))
  433.       (string->symbol
  434.        (string-append "scm:G" (number->string *gensym-counter*))))))
  435.  
  436. (define defmacro:eval slib:eval)
  437. (define defmacro:load load)
  438.  
  439. (define (slib:eval-load <filename> evl)
  440.   (if (not (file-exists? <filename>))
  441.       (set! <filename> (string-append <filename> (scheme-file-suffix))))
  442.   (call-with-input-file <filename>
  443.     (lambda (port)
  444.       (let ((old-load-pathname *load-pathname*))
  445.     (set! *load-pathname* <filename>)
  446.     (do ((o (read port) (read port)))
  447.         ((eof-object? o))
  448.       (evl o))
  449.     (set! *load-pathname* old-load-pathname)))))
  450.  
  451. ;;; Autoloads for SLIB procedures.
  452.  
  453. (define (tracef . args) (require 'debug) (apply tracef args))
  454. (define *traced-procedures* '())
  455. (define (trace:tracef fun sym)
  456.   (cond ((memq sym *traced-procedures*)
  457.      (display "WARNING: already traced " (current-error-port))
  458.      (display sym (current-error-port))
  459.      (newline (current-error-port))
  460.      fun)
  461.     (else
  462.      (set! *traced-procedures* (cons sym *traced-procedures*))
  463.      (tracef fun sym))))
  464. (define (trace:untracef fun sym)
  465.   (require 'common-list-functions)
  466.   (cond ((memq sym *traced-procedures*)
  467.      (set! *traced-procedures* (remove sym *traced-procedures*))
  468.      (untracef fun))
  469.     (else
  470.      (display "WARNING: not traced " (current-error-port))
  471.      (display sym (current-error-port))
  472.      (newline (current-error-port))
  473.      fun)))
  474.  
  475. ;;; Macros.
  476.  
  477. (defmacro trace x
  478.   (if (null? x) '*traced-procedures*
  479.       `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) x))))
  480. (defmacro untrace x
  481.   (if (null? x)
  482.       (slib:eval
  483.        `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x)))
  484.               *traced-procedures*)
  485.            '',*traced-procedures*))
  486.       `(begin ,@(map (lambda (x) `(set! ,x (trace:untracef ,x ',x))) x))))
  487.  
  488. (defmacro defvar (var val)
  489.   `(if (not (defined? ,var)) (define ,var ,val)))
  490.  
  491. ;;; ABS and MAGNITUDE can be the same.
  492. (if (inexact? (string->number "0.0"))
  493.     (begin (load (in-vicinity (implementation-vicinity)
  494.                   "Transcen" (scheme-file-suffix)))
  495.        (set! abs magnitude)))
  496.  
  497. (if (defined? array?)
  498.     (begin
  499.       (define uniform-vector? array?)
  500.       (define make-uniform-vector dimensions->uniform-array)
  501. ;      (define uniform-vector-ref array-ref)
  502.       (define (uniform-vector-set! u i o)
  503.     (uniform-vector-set1! u o i))
  504.       (define uniform-vector-fill! array-fill!)
  505.  
  506.       (define (make-array fill . args)
  507.     (dimensions->uniform-array args () fill))
  508.       (define (make-uniform-array prot . args)
  509.     (dimensions->uniform-array args prot))
  510.       (define (list->array ndim lst)
  511.     (list->uniform-array ndim '() lst))
  512.       (define (list->uniform-vector prot lst)
  513.     (list->uniform-array 1 prot lst))
  514.       (define (array-shape a)
  515.     (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
  516.          (array-dimensions a)))))
  517.  
  518. ;;; Use *argv* instead of (program-arguments), to allow option
  519. ;;; processing to be done on it.
  520. (define *argv* (program-arguments))
  521.  
  522. ;;; This loads the user's initialization file, or files named in
  523. ;;; program arguments.
  524.  
  525. (or
  526.  (eq? (software-type) 'THINKC)
  527.  (member "-no-init-file" (program-arguments))
  528.  (try-load
  529.   (in-vicinity
  530.    (let ((home (getenv "HOME")))
  531.      (if home
  532.      (case (software-type)
  533.        ((UNIX COHERENT)
  534.         (if (char=? #\/ (string-ref home (+ -1 (string-length home))))
  535.         home            ;V7 unix has a / on HOME
  536.         (string-append home "/")))
  537.        (else home))
  538.      (user-vicinity)))
  539.    "ScmInit")) ;;; removed .scm - ams
  540.  (errno 0))
  541.  
  542. (if (not (defined? *R4RS-macro*))
  543.     (define *R4RS-macro* #f))
  544. (if (not (defined? *interactive*))
  545.     (define *interactive* #f))
  546.  
  547. (cond
  548.  ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0)))
  549.   (require 'getopt)
  550. ;;; (else
  551. ;;;  (define *optind* 1)
  552. ;;;  (define getopt:opt #f)
  553. ;;;  (define (getopt argc argv optstring) #f))
  554.  
  555.   (let* ((simple-opts "muqvbis")
  556.      (arg-opts '("a kbytes" "no-init-file" "p number"
  557.                 "r feature" "f filename" "l filename"
  558.                 "c string" "e string"))
  559.      (opts (apply string-append ":" simple-opts
  560.               (map (lambda (o)
  561.                  (string-append (string (string-ref o 0)) ":"))
  562.                arg-opts)))
  563.      (argc (length *argv*))
  564.      (didsomething #f)
  565.      (moreopts #t))
  566.  
  567.     (define (do-thunk thunk)
  568.       (if *interactive*
  569.       (thunk)
  570.       (let ((complete #f))
  571.         (dynamic-wind
  572.          (lambda () #f)
  573.          (lambda ()
  574.            (thunk)
  575.            (set! complete #t))
  576.          (lambda () (if (not complete) (quit)))))))
  577.  
  578.     (define (do-string-arg)
  579.       (require 'string-port)
  580.       (do-thunk
  581.        (lambda ()
  582.      (eval
  583.       (call-with-input-string
  584.        (string-append "(begin " *optarg* ")")
  585.        read))))
  586.       (set! didsomething #t))
  587.  
  588.     (define (do-load file)
  589.       (do-thunk
  590.        (lambda ()
  591.      (cond (*R4RS-macro* (require 'macro) (macro:load file))
  592.            (else (load file)))))
  593.       (set! didsomething #t))
  594.  
  595.     (define (usage preopt opt postopt)
  596.       (define cep (current-error-port))
  597.       (define indent (make-string 6 #\ ))
  598.       (define i 2)
  599.       (if (char? opt) (set! opt (string opt)))
  600.       (display (string-append preopt opt postopt) cep)
  601.       (newline cep)
  602.       (display (string-append "Usage: " (car (program-arguments))
  603.                   " [-" simple-opts "]") cep)
  604.       (for-each
  605.        (lambda (o)
  606.      (display (string-append " [-" o "]") cep)
  607.      (set! i (+ 1 i))
  608.      (cond ((zero? (modulo i 4)) (newline cep) (display indent cep))))
  609.        arg-opts)
  610.       (display " [-- | -s | -] [file] [args...]" cep) (newline cep)
  611.       (exit 1))
  612.  
  613.     ;; -c str => (eval str)
  614.     ;; -e str => (eval str)
  615.     ;; -f str => (load str)
  616.     ;; -l str => (load str)
  617.     ;; -r str => (require str)
  618.     ;; -p int => (verbose int)
  619.     ;; -m     => (set! *R4RS-macro* #t)
  620.     ;; -u     => (set! *R4RS-macro* #f)
  621.     ;; -v     => (verbose 3)
  622.     ;; -q     => (verbose 0)
  623.     ;; -i     => (set! *interactive* #t)
  624.     ;; -b     => (set! *interactive* #f)
  625.     ;; -s     => set argv, don't execute first one
  626.     ;; -no-init-file => don't load init file
  627.     ;; --     => last option
  628.  
  629.     (let loop ()
  630.       (case (getopt argc *argv* opts)
  631.     ((#\e #\c) (do-string-arg))    ;sh-like
  632.     ((#\f #\l);;(set-car! *argv* *optarg*)
  633.      (do-load *optarg*))
  634.     ((#\r) (do-thunk (lambda ()
  635.                (if (and (= 1 (string-length *optarg*))
  636.                     (char-numeric? (string-ref *optarg* 0)))
  637.                    (case (string-ref *optarg* 0)
  638.                  ((#\2) (require 'rev3-procedures)
  639.                     (require 'rev2-procedures))
  640.                  ((#\3) (require 'rev3-procedures))
  641.                  ((#\4) (require 'rev4-optional-procedures))
  642.                  ((#\5) (require 'dynamic-wind)
  643.                     (require 'values)
  644.                     (require 'macro)
  645.                     (set! *R4RS-macro* #t))
  646.                  (else (require (string->symbol *optarg*))))
  647.                    (require (string->symbol *optarg*))))))
  648.     ((#\p) (verbose (string->number *optarg*)))
  649.     ((#\q) (verbose 0))
  650.     ((#\v) (verbose 3))
  651.     ((#\i) (set! *interactive* #t)    ;sh-like
  652.            (verbose (max 2 (verbose))))
  653.     ((#\b) (set! *interactive* #f))
  654.     ((#\s) (set! moreopts #f)    ;sh-like
  655.            (set! didsomething #t)
  656.            (set! *interactive* #t))
  657.     ((#\m) (set! *R4RS-macro* #t))
  658.     ((#\u) (set! *R4RS-macro* #f))
  659.     ((#\n) (if (not (string=? "o-init-file" *optarg*))
  660.            (usage "scm: unrecognized option `-n" *optarg* "'")))
  661.     ((#\:) (usage "scm: option `-" getopt:opt "' requires an argument"))
  662.     ((#\?) (usage "scm: unrecognized option `-" getopt:opt "'"))
  663.     ((#f) (set! moreopts #f)    ;sh-like
  664.           (cond ((and (< *optind* (length *argv*))
  665.               (string=? "-" (list-ref *argv* *optind*)))
  666.              (set! *optind* (+ 1 *optind*)))))
  667.     (else (usage "scm: unknown option `-" getopt:opt "'")))
  668.  
  669.       (cond ((and moreopts (< *optind* (length *argv*)))
  670.          (loop))
  671.         ((< *optind* (length *argv*)) ;No more opts
  672.          (set! *argv* (list-tail *argv* *optind*))
  673.          (set! *optind* 1)
  674.          (cond ((not didsomething) (do-load (car *argv*))
  675.                        (set! *optind* (+ 1 *optind*))))
  676.          (cond ((and (> (verbose) 2)
  677.              (not (= (+ -1 *optind*) (length *argv*))))
  678.             (display "scm: extra command arguments unused:"
  679.                  (current-error-port))
  680.             (for-each (lambda (x) (display (string-append " " x)
  681.                            (current-error-port)))
  682.                   (list-tail *argv* (+ -1 *optind*)))
  683.             (newline (current-error-port)))))
  684.         ((and (not didsomething) (= *optind* (length *argv*)))
  685.          (set! *interactive* #t)))))
  686.  
  687.   (cond ((not *interactive*) (quit))
  688.     (*R4RS-macro*
  689.      (require 'repl)
  690.      (require 'macro)
  691.      (let* ((oquit quit))
  692.        (set! quit (lambda () (repl:quit)))
  693.        (set! exit quit)
  694.        (repl:top-level macro:eval)
  695.        (oquit))))
  696.   ;;otherwise, fall into non-macro SCM repl.
  697.   )
  698.  (else
  699.   (begin (errno 0)
  700.      (for-each load (cdr (program-arguments))))))
  701.  
  702. ; --- hereonwards by ams
  703. ;
  704. ; Fire up the archi extension routines
  705. ;
  706. (case (software-type)
  707. ((archimedes) (load "<scm$dir>.arc_ext"))
  708. (else ""))