home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / scm / Init < prev    next >
Text File  |  1995-01-02  |  22KB  |  695 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) "4e2")
  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 () "")) ; --- ams
  47.     (else (lambda () ".scm"))))
  48.  
  49. (set! *features*
  50.       (append '(getenv tmpnam 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 current-time)
  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. ; --- ams fiddled again
  63. ;(define implementation-vicinity
  64. ;  (let ((vic (program-vicinity)))
  65. ;    (lambda () vic)))
  66. (define implementation-vicinity
  67.   (lambda () "<Scm$Dir>."))
  68.  
  69. (define (terms)
  70.   (list-file (in-vicinity (implementation-vicinity) "COPYING")))
  71.  
  72. (define (list-file file)
  73.   (call-with-input-file file
  74.     (lambda (inport)
  75.       (do ((c (read-char inport) (read-char inport)))
  76.       ((eof-object? c))
  77.     (write-char c)))))
  78.  
  79. (define (read:eval-feature exp)
  80.   (cond ((symbol? exp)
  81.      (or (memq exp *features*) (eq? exp (software-type))))
  82.     ((and (pair? exp) (list? exp))
  83.      (case (car exp)
  84.        ((not) (not (read:eval-feature (cadr exp))))
  85.        ((or) (if (null? (cdr exp)) #f
  86.              (or (read:eval-feature (cadr exp))
  87.              (read:eval-feature (cons 'or (cddr exp))))))
  88.        ((and) (if (null? (cdr exp)) #t
  89.               (and (read:eval-feature (cadr exp))
  90.                (read:eval-feature (cons 'and (cddr exp))))))
  91.        (else (error "read:sharp+ invalid expression " exp))))))
  92.  
  93. (define (read:array digit port)
  94.   (define chr0 (char->integer #\0))
  95.   (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
  96.         (if (char-numeric? (peek-char port))
  97.             (readnum (+ (* 10 val)
  98.                 (- (char->integer (read-char port)) chr0)))
  99.             val)))
  100.     (prot (if (eq? #\( (peek-char port))
  101.           '()
  102.           (let ((c (read-char port)))
  103.             (case c ((#\b) #t)
  104.               ((#\a) #\a)
  105.               ((#\u) 1)
  106.               ((#\e) -1)
  107.               ((#\s) 1.0)
  108.               ((#\i) 1/3)
  109.               ((#\c) 0+i)
  110.               (else (error "read:array unknown option " c)))))))
  111.     (if (eq? (peek-char port) #\()
  112.     (list->uniform-array rank prot (read port))
  113.     (error "read:array list not found"))))
  114.  
  115. (define (read:uniform-vector proto port)
  116.   (if (eq? #\( (peek-char port))
  117.       (list->uniform-array 1 proto (read port))
  118.       (error "read:uniform-vector list not found")))
  119.  
  120. (define (read:sharp c port)
  121.   (define (barf)
  122.     (error "unknown # object" c))
  123.   (case c ((#\') (read port))
  124.     ((#\+) (if (read:eval-feature (read port))
  125.            (read port)
  126.            (begin (read port) (if #f #f))))
  127.     ((#\-) (if (not (read:eval-feature (read port)))
  128.            (read port)
  129.            (begin (read port) (if #f #f))))
  130.     ((#\b) (read:uniform-vector #t port))
  131.     ((#\a) (read:uniform-vector #\a port))
  132.     ((#\u) (read:uniform-vector 1 port))
  133.     ((#\e) (read:uniform-vector -1 port))
  134.     ((#\s) (read:uniform-vector 1.0 port))
  135.     ((#\i) (read:uniform-vector 1/3 port))
  136.     ((#\c) (read:uniform-vector 0+i port))
  137.     ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  138.      (read:array c port))
  139.     ((#\!) (if (= 1 (line-number))
  140.            (let skip () (if (eq? #\newline (peek-char port))
  141.                     (if #f #f)
  142.                     (begin (read-char port) (skip))))
  143.            (barf)))
  144.     (else (barf))))
  145.  
  146. ;;;; Here are some Revised^2 Scheme functions:
  147. (define 1+
  148.   (let ((+ +))
  149.     (lambda (n) (+ n 1))))
  150. (define -1+
  151.   (let ((+ +))
  152.     (lambda (n) (+ n -1))))
  153. (define 1- -1+)
  154. (define <? <)
  155. (define <=? <=)
  156. (define =? =)
  157. (define >? >)
  158. (define >=? >=)
  159. (define t #t)
  160. (define nil #f)
  161. (define sequence begin)
  162.  
  163. (set! apply (lambda (fun . args) (@apply fun (apply:nconc-to-last args))))
  164. (define (call-with-current-continuation proc)
  165.   (@call-with-current-continuation proc))
  166.  
  167. ;;; VMS does something strange when output is sent to both
  168. ;;; CURRENT-OUTPUT-PORT and CURRENT-ERROR-PORT.
  169. (case (software-type) ((VMS) (set-current-error-port (current-output-port))))
  170.  
  171. ;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
  172. ;;; mode to open files in.  MSDOS does carraige return - newline
  173. ;;; translation if not opened in `b' mode.
  174.  
  175. (define OPEN_READ (case (software-type)
  176.             ((MSDOS ATARIST) "rb")
  177.             (else "r")))
  178. (define OPEN_WRITE (case (software-type)
  179.              ((MSDOS ATARIST) "wb")
  180.              (else "w")))
  181. (define OPEN_BOTH (case (software-type)
  182.             ((MSDOS ATARIST) "r+b")
  183.             (else "r+")))
  184. (define (_IONBF mode) (string-append mode "0"))
  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. (if (not (defined? force-output))
  245.     (define (force-output . a) #f))
  246.  
  247. (define (error . args)
  248.   (define cep (current-error-port))
  249.   (perror "ERROR")
  250.   (errno 0)
  251.   (display "ERROR: " cep)
  252.   (if (not (null? args))
  253.       (begin (display (car args) cep)
  254.          (for-each (lambda (x) (display #\  cep) (write x cep))
  255.                (cdr args))))
  256.   (newline cep)
  257.   (force-output cep)
  258.   (abort))
  259.  
  260. (define set-errno errno)
  261. (define exit quit)
  262.  
  263. (define (file-exists? str)
  264.   (let ((port (open-file str OPEN_READ)))
  265.     (if port (begin (close-port port) #t)
  266.     #f)))
  267.  
  268. (define difftime -)
  269. (define offset-time +)
  270.  
  271. (if (not (memq 'ed *features*))
  272.     (begin
  273.       (define (ed . args)
  274.     (system (apply string-append
  275.                (or (getenv "EDITOR") "ed")
  276.                (map (lambda (s) (string-append " " s)) args))))
  277.       (set! *features* (cons 'ed *features*))))
  278.  
  279. (if (not (defined? output-port-width))
  280.     (define (output-port-width . arg) 80))
  281.  
  282. (if (not (defined? output-port-height))
  283.     (define (output-port-height . arg) 24))
  284.  
  285. (if (not (defined? last-pair))
  286.     (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)))
  287.  
  288. (define (has-suffix? str suffix)
  289.   (let ((sufl (string-length suffix))
  290.     (sl (string-length str)))
  291.     (and (> sl sufl)
  292.      (string=? (substring str (- sl sufl) sl) suffix))))
  293.  
  294. (define (identity x) x)
  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) (try-load file))
  317.       ;;HERE is where the suffix gets specified
  318.       (and (not hss)
  319.        (begin (set! filesuf (string-append file sfs))
  320.           (try-load filesuf)))
  321.       (and (procedure? could-not-open) (could-not-open) #f)
  322.       (error "LOAD couldn't find file " file))
  323.   (errno 0)
  324.   (cond ((> (verbose) 1)
  325.      (display ";done loading " cep) (write filesuf cep) (newline cep)
  326.      (force-output cep))))
  327. (define load scm:load)
  328. (define slib:load load)
  329.  
  330. (define (scm:load-source file)
  331.   (define sfs (scheme-file-suffix))
  332.   (define cep (current-error-port))
  333.   (define filesuf file)
  334.   (cond ((> (verbose) 1)
  335.      (display ";loading " cep) (write file cep) (newline cep)))
  336.   (force-output cep)
  337.   (or (and (or (try-load file)
  338.            ;;HERE is where the suffix gets specified
  339.            (and (not (has-suffix? file sfs))
  340.             (begin (set! filesuf (string-append file sfs))
  341.                (try-load filesuf)))))
  342.       (and (procedure? could-not-open) (could-not-open) #f)
  343.       (error "LOAD couldn't find file " file))
  344.   (errno 0)
  345.   (cond ((> (verbose) 1)
  346.      (display ";done loading " cep) (write filesuf cep) (newline cep)
  347.      (force-output cep))))
  348. (define slib:load-source scm:load-source)
  349.  
  350. (cond ((try-load
  351.     (in-vicinity (library-vicinity) "require" (scheme-file-suffix))))
  352.       (else
  353.        (perror "WARNING")
  354.        (display "WARNING: Couldn't find require.scm in (library-vicinity)"
  355.         (current-error-port))
  356.        (write (library-vicinity) (current-error-port))
  357.        (newline (current-error-port))
  358.        (errno 0)))
  359.  
  360. ;;; DO NOT MOVE!  This has to be done after "require.scm" is loaded.
  361. (define slib:load-source scm:load-source)
  362. (define slib:load scm:load)
  363.  
  364. (if (or (defined? dld:link)
  365.     (defined? shl:load)
  366.     (defined? vms:dynamic-link-call)
  367.     (file-exists? (in-vicinity (implementation-vicinity) "hobbit.tms")))
  368.     (try-load (in-vicinity (implementation-vicinity)
  369.                "Link" (scheme-file-suffix))))
  370.  
  371. (cond ((defined? link:link)
  372.        (define (slib:load-compiled . args)
  373.      (or (apply link:link args)
  374.          (error "Couldn't link files " args)))
  375.        (provide 'compiled)))
  376.  
  377. (define logical:logand logand)
  378. (define logical:logior logior)
  379. (define logical:logxor logxor)
  380. (define logical:lognot lognot)
  381. (define logical:ash ash)
  382. (define logical:logcount logcount)
  383. (define logical:integer-length integer-length)
  384. (define logical:bit-extract bit-extract)
  385. (define logical:integer-expt integer-expt)
  386.  
  387. (define (logical:ipow-by-squaring x k acc proc)
  388.   (cond ((zero? k) acc)
  389.     ((= 1 k) (proc acc x))
  390.     (else (logical:ipow-by-squaring (proc x x)
  391.                     (quotient k 2)
  392.                     (if (even? k) acc (proc acc x))
  393.                     proc))))
  394.  
  395. ;defmacro from dorai@cs.rice.edu (heavily hacked by jaffer):
  396. (define *defmacros* '())
  397. (define (defmacro? m) (and (assq m *defmacros*) #t))
  398.  
  399. (define defmacro:transformer
  400.   (lambda (f)
  401.     (procedure->memoizing-macro
  402.       (lambda (exp env)
  403.     (copy-tree (apply f (cdr exp)))))))
  404.  
  405. (define defmacro
  406.   (let ((defmacro-transformer
  407.       (lambda (name parms . body)
  408.         `(define ,name
  409.            (let ((transformer (lambda ,parms ,@body)))
  410.          (set! *defmacros* (acons ',name transformer *defmacros*))
  411.          (defmacro:transformer transformer))))))
  412.     (set! *defmacros* (acons 'defmacro defmacro-transformer *defmacros*))
  413.     (defmacro:transformer defmacro-transformer)))
  414.  
  415. (define (macroexpand-1 e)
  416.   (if (pair? e) (let ((a (car e)))
  417.           (cond ((symbol? a) (set! a (assq a *defmacros*))
  418.                      (if a (apply (cdr a) (cdr e)) e))
  419.             (else e)))
  420.       e))
  421.  
  422. (define (macroexpand e)
  423.   (if (pair? e) (let ((a (car e)))
  424.           (cond ((symbol? a)
  425.              (set! a (assq a *defmacros*))
  426.              (if a (macroexpand (apply (cdr a) (cdr e))) e))
  427.             (else e)))
  428.       e))
  429.  
  430. (define gentemp
  431.   (let ((*gensym-counter* -1))
  432.     (lambda ()
  433.       (set! *gensym-counter* (+ *gensym-counter* 1))
  434.       (string->symbol
  435.        (string-append "scm:G" (number->string *gensym-counter*))))))
  436.  
  437. (define defmacro:eval slib:eval)
  438. (define defmacro:load load)
  439.  
  440. (define (slib:eval-load <filename> evl)
  441.   (if (not (file-exists? <filename>))
  442.       (set! <filename> (string-append <filename> (scheme-file-suffix))))
  443.   (call-with-input-file <filename>
  444.     (lambda (port)
  445.       (let ((old-load-pathname *load-pathname*))
  446.     (set! *load-pathname* <filename>)
  447.     (do ((o (read port) (read port)))
  448.         ((eof-object? o))
  449.       (evl o))
  450.     (set! *load-pathname* old-load-pathname)))))
  451.  
  452. ;;; Autoloads for SLIB procedures.
  453.  
  454. (define (tracef . args) (require 'trace) (apply tracef args))
  455. (define (trace:tracef . args) (require 'trace) (apply trace:tracef args))
  456. (define (pretty-print . args) (require 'pretty-print)
  457.   (apply pretty-print args))
  458. (define (print . args) (require 'debug) (apply print args))
  459.  
  460. ;;; Macros.
  461.  
  462. ;;; Trace gets redefmacroed when tracef autoloads.
  463. (defmacro trace x
  464.   (if (null? x) '()
  465.       `(begin ,@(map (lambda (x) `(set! ,x (trace:tracef ,x ',x))) x))))
  466.  
  467. (defmacro defvar (var val)
  468.   `(if (not (defined? ,var)) (define ,var ,val)))
  469.  
  470. ;;; ABS and MAGNITUDE can be the same.
  471. (cond ((and (inexact? (string->number "0.0")) (not (defined? exp)))
  472.        (if (defined? usr:lib)
  473.        (load (in-vicinity (implementation-vicinity) "Transcen")
  474.          (usr:lib "m"))
  475.        (load (in-vicinity (implementation-vicinity) "Transcen"
  476.                   (scheme-file-suffix))))
  477.        (set! abs magnitude)))
  478.  
  479. (if (defined? array?)
  480.     (begin
  481.       (define uniform-vector? array?)
  482.       (define make-uniform-vector dimensions->uniform-array)
  483. ;      (define uniform-vector-ref array-ref)
  484.       (define (uniform-vector-set! u i o)
  485.     (uniform-vector-set1! u o i))
  486. ;      (define uniform-vector-fill! array-fill!)
  487.       (define uniform-vector-read! uniform-array-read!)
  488.       (define uniform-vector-write uniform-array-write)
  489.  
  490.       (define (make-array fill . args)
  491.     (dimensions->uniform-array args () fill))
  492.       (define (make-uniform-array prot . args)
  493.     (dimensions->uniform-array args prot))
  494.       (define (list->array ndim lst)
  495.     (list->uniform-array ndim '() lst))
  496.       (define (list->uniform-vector prot lst)
  497.     (list->uniform-array 1 prot lst))
  498.       (define (array-shape a)
  499.     (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
  500.          (array-dimensions a)))))
  501.  
  502. ;;; Use *argv* instead of (program-arguments), to allow option
  503. ;;; processing to be done on it.
  504. (define *argv* (program-arguments))
  505.  
  506. ;;; This loads the user's initialization file, or files named in
  507. ;;; program arguments.
  508.  
  509. (or
  510.  (eq? (software-type) 'THINKC)
  511.  (member "-no-init-file" (program-arguments))
  512.  (try-load
  513.   (in-vicinity
  514.    (let ((home (getenv "HOME")))
  515.      (if home
  516.      (case (software-type)
  517.        ((UNIX COHERENT)
  518.         (if (char=? #\/ (string-ref home (+ -1 (string-length home))))
  519.         home            ;V7 unix has a / on HOME
  520.         (string-append home "/")))
  521.        (else home))
  522.      (user-vicinity)))
  523. ;   "ScmInit.scm")) --- ams - removed .scm
  524.     "ScmInit"))
  525.  (errno 0))
  526.  
  527. (if (not (defined? *R4RS-macro*))
  528.     (define *R4RS-macro* #f))
  529. (if (not (defined? *interactive*))
  530.     (define *interactive* #f))
  531.  
  532. (cond
  533.  ((and (> (length *argv*) 1) (char=? #\- (string-ref (cadr *argv*) 0)))
  534.   (require 'getopt)
  535. ;;; (else
  536. ;;;  (define *optind* 1)
  537. ;;;  (define getopt:opt #f)
  538. ;;;  (define (getopt argc argv optstring) #f))
  539.  
  540.   (let* ((simple-opts "muqvbis")
  541.      (arg-opts '("a kbytes" "no-init-file" "p number"
  542.                 "r feature" "f filename" "l filename"
  543.                 "c string" "e string"))
  544.      (opts (apply string-append ":" simple-opts
  545.               (map (lambda (o)
  546.                  (string-append (string (string-ref o 0)) ":"))
  547.                arg-opts)))
  548.      (argc (length *argv*))
  549.      (didsomething #f)
  550.      (moreopts #t))
  551.  
  552.     (define (do-thunk thunk)
  553.       (if *interactive*
  554.       (thunk)
  555.       (let ((complete #f))
  556.         (dynamic-wind
  557.          (lambda () #f)
  558.          (lambda ()
  559.            (thunk)
  560.            (set! complete #t))
  561.          (lambda () (if (not complete) (quit #f)))))))
  562.  
  563.     (define (do-string-arg)
  564.       (require 'string-port)
  565.       (do-thunk
  566.        (lambda ()
  567.      (eval
  568.       (call-with-input-string
  569.        (string-append "(begin " *optarg* ")")
  570.        read))))
  571.       (set! didsomething #t))
  572.  
  573.     (define (do-load file)
  574.       (do-thunk
  575.        (lambda ()
  576.      (cond (*R4RS-macro* (require 'macro) (macro:load file))
  577.            (else (load file)))))
  578.       (set! didsomething #t))
  579.  
  580.     (define (usage preopt opt postopt)
  581.       (define cep (current-error-port))
  582.       (define indent (make-string 6 #\ ))
  583.       (define i 3)
  584.       (if (char? opt) (set! opt (string opt)))
  585.       (display (string-append preopt opt postopt) cep)
  586.       (newline cep)
  587.       (display (string-append "Usage: " (car (program-arguments))
  588.                   " [-a kbytes] [-" simple-opts "]") cep)
  589.       (for-each
  590.        (lambda (o)
  591.      (display (string-append " [-" o "]") cep)
  592.      (set! i (+ 1 i))
  593.      (cond ((zero? (modulo i 4)) (newline cep) (display indent cep))))
  594.        (cdr arg-opts))
  595.       (display " [-- | -s | -] [file] [args...]" cep) (newline cep)
  596.       (exit #f))
  597.  
  598.     ;; -a int => ignore (handled by run_scm)
  599.     ;; -c str => (eval str)
  600.     ;; -e str => (eval str)
  601.     ;; -f str => (load str)
  602.     ;; -l str => (load str)
  603.     ;; -r str => (require str)
  604.     ;; -p int => (verbose int)
  605.     ;; -m     => (set! *R4RS-macro* #t)
  606.     ;; -u     => (set! *R4RS-macro* #f)
  607.     ;; -v     => (verbose 3)
  608.     ;; -q     => (verbose 0)
  609.     ;; -i     => (set! *interactive* #t)
  610.     ;; -b     => (set! *interactive* #f)
  611.     ;; -s     => set argv, don't execute first one
  612.     ;; -no-init-file => don't load init file
  613.     ;; --     => last option
  614.  
  615.     (let loop ()
  616.       (case (getopt argc *argv* opts)
  617.     ((#\a)
  618.      (cond ((> *optind* 3)
  619.         (usage "scm: option `-" getopt:opt "' must be first"))
  620.            ((or (not (exact? (string->number *optarg*)))
  621.             (not (<= 1 (string->number *optarg*) 10000)))
  622.         ;;    This size limit should match scm.c ^^
  623.         (usage "scm: option `-" getopt:opt
  624.                (string-append *optarg* "' unreasonable")))))
  625.     ((#\e #\c) (do-string-arg))    ;sh-like
  626.     ((#\f #\l);;(set-car! *argv* *optarg*)
  627.      (do-load *optarg*))
  628.     ((#\r) (do-thunk (lambda ()
  629.                (if (and (= 1 (string-length *optarg*))
  630.                     (char-numeric? (string-ref *optarg* 0)))
  631.                    (case (string-ref *optarg* 0)
  632.                  ((#\2) (require 'rev3-procedures)
  633.                     (require 'rev2-procedures))
  634.                  ((#\3) (require 'rev3-procedures))
  635.                  ((#\4) (require 'rev4-optional-procedures))
  636.                  ((#\5) (require 'dynamic-wind)
  637.                     (require 'values)
  638.                     (require 'macro)
  639.                     (set! *R4RS-macro* #t))
  640.                  (else (require (string->symbol *optarg*))))
  641.                    (require (string->symbol *optarg*))))))
  642.     ((#\p) (verbose (string->number *optarg*)))
  643.     ((#\q) (verbose 0))
  644.     ((#\v) (verbose 3))
  645.     ((#\i) (set! *interactive* #t)    ;sh-like
  646.            (verbose (max 2 (verbose))))
  647.     ((#\b) (set! *interactive* #f))
  648.     ((#\s) (set! moreopts #f)    ;sh-like
  649.            (set! didsomething #t)
  650.            (set! *interactive* #t))
  651.     ((#\m) (set! *R4RS-macro* #t))
  652.     ((#\u) (set! *R4RS-macro* #f))
  653.     ((#\n) (if (not (string=? "o-init-file" *optarg*))
  654.            (usage "scm: unrecognized option `-n" *optarg* "'")))
  655.     ((#\:) (usage "scm: option `-" getopt:opt "' requires an argument"))
  656.     ((#\?) (usage "scm: unrecognized option `-" getopt:opt "'"))
  657.     ((#f) (set! moreopts #f)    ;sh-like
  658.           (cond ((and (< *optind* (length *argv*))
  659.               (string=? "-" (list-ref *argv* *optind*)))
  660.              (set! *optind* (+ 1 *optind*)))))
  661.     (else (usage "scm: unknown option `-" getopt:opt "'")))
  662.  
  663.       (cond ((and moreopts (< *optind* (length *argv*)))
  664.          (loop))
  665.         ((< *optind* (length *argv*)) ;No more opts
  666.          (set! *argv* (list-tail *argv* *optind*))
  667.          (set! *optind* 1)
  668.          (cond ((not didsomething) (do-load (car *argv*))
  669.                        (set! *optind* (+ 1 *optind*))))
  670.          (cond ((and (> (verbose) 2)
  671.              (not (= (+ -1 *optind*) (length *argv*))))
  672.             (display "scm: extra command arguments unused:"
  673.                  (current-error-port))
  674.             (for-each (lambda (x) (display (string-append " " x)
  675.                            (current-error-port)))
  676.                   (list-tail *argv* (+ -1 *optind*)))
  677.             (newline (current-error-port)))))
  678.         ((and (not didsomething) (= *optind* (length *argv*)))
  679.          (set! *interactive* #t)))))
  680.  
  681.   (cond ((not *interactive*) (quit))
  682.     (*R4RS-macro*
  683.      (require 'repl)
  684.      (require 'macro)
  685.      (let* ((oquit quit))
  686.        (set! quit (lambda () (repl:quit)))
  687.        (set! exit quit)
  688.        (repl:top-level macro:eval)
  689.        (oquit))))
  690.   ;;otherwise, fall into non-macro SCM repl.
  691.   )
  692.  (else
  693.   (begin (errno 0)
  694.      (for-each load (cdr (program-arguments))))))
  695.