diff options
Diffstat (limited to 'mitscheme.init')
| -rw-r--r-- | mitscheme.init | 305 |
1 files changed, 187 insertions, 118 deletions
diff --git a/mitscheme.init b/mitscheme.init index afec48e..934de62 100644 --- a/mitscheme.init +++ b/mitscheme.init @@ -8,45 +8,49 @@ (define getenv get-environment-variable) ;;; (software-type) should be set to the generic operating system type. -(define (software-type) (if (getenv "HOMEDRIVE") 'MS-DOS 'UNIX)) +(define (software-type) + (if (eq? 'unix microcode-id/operating-system) 'UNIX 'MS-DOS)) ;;; (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. - (define (scheme-implementation-type) 'MITScheme) ;;; (scheme-implementation-home-page) should return a (string) URI ;;; (Uniform Resource Identifier) for this scheme implementation's home ;;; page; or false if there isn't one. - (define (scheme-implementation-home-page) - "http://swissnet.ai.mit.edu/scheme-home.html") + "http://www.swiss.ai.mit.edu/projects/scheme/") ;;; (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) - (let* ((str (with-output-to-string identify-world)) - (beg (+ (string-search-forward "Release " str) 8)) - (rst (substring str beg (string-length str))) - (end (string-find-next-char-in-set - rst - (predicate->char-set char-whitespace?)))) - (substring rst 0 end))) + (get-subsystem-version-string "Release")) + +(define (mit-scheme-release>= major minor) + (let ((version (scheme-implementation-version))) + (let ((components (burst-string version #\. #f)) + (lose + (lambda () + (error "Malformed release version string:" version)))) + (let ((major* + (or (and (pair? components) + (string->number (car components))) + (lose)))) + (or (> major* major) + (and (= major* major) + (>= (or (and (pair? (cdr components)) + (string->number (cadr components))) + (lose)) + minor))))))) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxillary files to your Scheme ;;; implementation reside. - (define (implementation-vicinity) - (case (software-type) - ((MS-DOS) "c:\\scheme\\") - ((UNIX) "/usr/local/lib/mit-scheme/") - ((VMS) "scheme$src:"))) + (->namestring (system-library-directory-pathname #f))) ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. - (define library-vicinity (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH") @@ -54,22 +58,18 @@ (case (software-type) ((MS-DOS) "c:\\slib\\") ((UNIX) "/usr/local/lib/slib/") - ((VMS) "lib$scheme:") (else ""))))) (lambda () library-path))) ;;; (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 - (let ((home-path (getenv "HOME"))) - (lambda () home-path))) +(define (home-vicinity) + (->namestring (user-homedir-pathname))) ;;; *features* should be set to a list of symbols describing features ;;; of this implementation. See Template.scm for the list of feature ;;; names. - (define *features* '( source ;can load scheme source files @@ -79,11 +79,14 @@ ;; Scheme report features - rev5-report ;conforms to - eval ;R5RS two-argument eval +; **** no, for several reasons +; r5rs ;conforms to +; **** no -- special arguments not supported +; eval ;R5RS two-argument eval +; **** sort of -- not integrated with continuations values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind - macro ;R5RS high level macros + fluid-let delay ;has DELAY and FORCE multiarg-apply ;APPLY can take more than 2 args. char-ready? @@ -93,11 +96,12 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to - ieee-p1178 ;conforms to +; **** no -- #F and '() are identical +; ieee-p1178 ;conforms to -; rev3-report ;conforms to +; r3rs ;conforms to rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -108,7 +112,7 @@ multiarg/and- ;/ and - can take more than 2 args. with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE + ;WITH-OUTPUT-TO-FILE transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF ieee-floating-point ;conforms to IEEE Standard 754-1985 ;IEEE Standard for Binary @@ -118,16 +122,14 @@ ;; Other common features ; srfi ;srfi-0, COND-EXPAND finds all srfi-* - sicp ;runs code from Structure and - ;Interpretation of Computer - ;Programs by Abelson and Sussman. defmacro ;has Common Lisp DEFMACRO record ;has user defined data structures string-port ;has CALL-WITH-INPUT-STRING and ;CALL-WITH-OUTPUT-STRING -; sort + sort pretty-print object->string +; **** limited subset with (load-option 'format) ; format ;Common-lisp output formatting trace ;has macros: TRACE and UNTRACE compiler ;has (COMPILER) @@ -143,6 +145,19 @@ Xwindows )) +; **** MIT Scheme has SORT, but SORT! accepts only vectors. +(define sort! sort) + +(define mit-scheme-has-r4rs-macros? + (mit-scheme-release>= 7 7)) +(if mit-scheme-has-r4rs-macros? + (set! *features* (cons 'macro *features*))) + +(if (get-subsystem-version-string "6.001") + ;; Runs code from "Structure and Interpretation of Computer + ;; Programs" by Abelson and Sussman. + (set! *features* (cons 'sicp *features*))) + (define current-time current-file-time) (define difftime -) (define offset-time +) @@ -151,19 +166,16 @@ (define output-port-width output-port/x-size) ;;; (OUTPUT-PORT-HEIGHT <port>) -(define (output-port-height . arg) 24) +(define (output-port-height port) + (or (output-port/y-size port) + 24)) ;;; (CURRENT-ERROR-PORT) -(define current-error-port - (let ((port console-output-port)) - (lambda () port))) +(define current-error-port nearest-cmdl/port) ;;; (TMPNAM) makes a temporary file name. -(define tmpnam - (let ((cntr 100)) - (lambda () (set! cntr (+ 1 cntr)) - (let ((tmp (string-append "slib_" (number->string cntr)))) - (if (file-exists? tmp) (tmpnam) tmp))))) +(define (tmpnam) + (->namestring (temporary-file-pathname))) ;;; FORCE-OUTPUT flushes any pending output on optional arg output port. (define force-output flush-output) @@ -172,21 +184,31 @@ ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string ;;; port versions of CALL-WITH-*PUT-FILE. -(define (call-with-output-string proc) - (let ((co (current-output-port))) - (with-output-to-string - (lambda () - (let ((port (current-output-port))) - (with-output-to-port co - (lambda () (proc port)))))))) +(define call-with-output-string with-string-output-port) (define (call-with-input-string string proc) - (let ((ci (current-input-port))) - (with-input-from-string string - (lambda () - (let ((port (current-input-port))) - (with-input-from-port ci - (lambda () (proc port)))))))) + (proc (string->input-port string))) + +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +(define (open-file filename modes) + (case modes + ((r) (open-input-file filename)) + ((r+) (open-i/o-file filename)) + ((w) (open-output-file filename)) + ((rb) (open-binary-input-file filename)) + ((r+b rb+) (open-binary-i/o-file filename)) + ((wb) (open-binary-output-file filename)) + (else (slib:error 'open-file 'mode? modes)))) +(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 object->string write-to-string) (define object->limited-string write-to-string) @@ -199,61 +221,113 @@ (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can -;;; be returned by CHAR->INTEGER. It is defined incorrectly (65536) -;;; by MITScheme version 8.0. -(define char-code-limit 256) +;;; be returned by CHAR->INTEGER. +;;; +;;; [Note that this definition conflicts with MIT Scheme's definition +;;; of the same name.] +;;; +;;; Can't use correct value because "jacal/types.scm" assumes that +;;; every possible character can be stored into a string. In MIT +;;; Scheme, only 8-bit characters fit in strings, while the character +;;; object supports 16 bits of character code with 5 bucky bits. So +;;; instead provide the limit that is appropriate for string +;;; characters. +(define char-code-limit + ;;char-integer-limit + 256) ;;; MOST-POSITIVE-FIXNUM is used in modular.scm -(define most-positive-fixnum #x03FFFFFF) +(define most-positive-fixnum + (let loop ((n 1)) + (if (fix:fixnum? n) + (loop (* n 2)) + (- n 1)))) ;;; Return argument -(define (identity x) x) +(define identity identity-procedure) ;;; SLIB:EVAL is single argument eval using the top-level (user) environment. -;(define (slib:eval form) (eval form (repl/environment (nearest-repl)))) +;(define (slib:eval form) (eval form (nearest-repl/environment))) (define (slib:eval form) (eval form user-initial-environment)) (define *macros* '(defmacro)) (define (defmacro? m) (and (memq m *macros*) #t)) -(syntax-table-define system-global-syntax-table 'defmacro - (macro defmacargs - (let ((macname (car defmacargs)) (macargs (cadr defmacargs)) - (macbdy (cddr defmacargs))) - `(begin - (set! *macros* (cons ',macname *macros*)) - (syntax-table-define system-global-syntax-table ',macname - (macro ,macargs ,@macbdy)))))) - -(define (macroexpand-1 e) - (if (pair? e) (let ((a (car e))) - (if (and (symbol? a) (defmacro? a)) - (apply (syntax-table-ref system-global-syntax-table a) - (cdr e)) - e)) - e)) - -(define (macroexpand e) - (if (pair? e) (let ((a (car e))) - (if (and (symbol? a) (defmacro? a)) - (macroexpand - (apply (syntax-table-ref system-global-syntax-table a) - (cdr e))) - e)) - e)) - -(define gentemp - (let ((*gensym-counter* -1)) - (lambda () - (set! *gensym-counter* (+ *gensym-counter* 1)) - (string->symbol - (string-append "slib:G" (number->string *gensym-counter*)))))) +(if mit-scheme-has-r4rs-macros? + (environment-define-macro user-initial-environment 'defmacro + (non-hygienic-macro-transformer->expander + (lambda arguments + (let ((name (car arguments))) + `(begin + (set! *macros* (cons ',name *macros*)) + (environment-define-macro user-initial-environment ',name + (non-hygienic-macro-transformer->expander + (lambda ,@(cdr arguments)) + user-initial-environment))))) + user-initial-environment)) + (syntax-table-define system-global-syntax-table 'defmacro + (macro defmacargs + (let ((macname (car defmacargs)) (macargs (cadr defmacargs)) + (macbdy (cddr defmacargs))) + `(begin + (set! *macros* (cons ',macname *macros*)) + (syntax-table-define system-global-syntax-table ',macname + (macro ,macargs ,@macbdy))))))) + +(define macroexpand-1) +(define macroexpand) +(let ((finish + (lambda (get-transformer apply-transformer) + (set! macroexpand-1 + (lambda (form) + (let ((transformer (get-transformer form))) + (if transformer + (apply-transformer transformer form) + form)))) + (set! macroexpand + (lambda (form) + (let ((transformer (get-transformer form))) + (if transformer + (macroexpand (apply-transformer transformer form)) + form))))))) + (if mit-scheme-has-r4rs-macros? + (let ((e (->environment '(runtime syntactic-closures)))) + (let ((transformer-item/expander (access transformer-item/expander e)) + (expander-item/expander (access expander-item/expander e)) + (expander-item/environment (access expander-item/environment e))) + (finish + (lambda (form) + (and (pair? form) + (let ((a (car form))) + (and (symbol? a) + (defmacro? a) + (environment-lookup-macro user-initial-environment + a))))) + (lambda (item form) + (let ((item (transformer-item/expander item))) + ((expander-item/expander item) + form + user-initial-environment + (expander-item/environment item))))))) + (finish + (lambda (form) + (and (pair? form) + (let ((a (car form))) + (and (symbol? a) + (defmacro? a) + (syntax-table-ref system-global-syntax-table a))))) + (apply-transformer + (lambda (transformer form) + (apply transformer (cdr form))))))) + +(define gentemp generate-uninterned-symbol) (define defmacro:eval slib:eval) (define defmacro:load load) -;;; If your implementation provides R4RS macros: -;(define macro:eval slib:eval) -;(define macro:load load) +(if mit-scheme-has-r4rs-macros? + (begin + (environment-define (the-environment) 'macro:eval slib:eval) + (environment-define (the-environment) 'macro:load load))) (define (slib:eval-load <pathname> evl) (if (not (file-exists? <pathname>)) @@ -261,31 +335,30 @@ (call-with-input-file <pathname> (lambda (port) (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* <pathname>) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) + (fluid-let ((*load-pathname* <pathname>)) + (do ((o (read port) (read port))) + ((eof-object? o)) + (evl o))))))) -(define record-modifier record-updater) ;some versions need this? +;; Older implementations need this definition. +(if (lexical-unreferenceable? (the-environment) 'record-modifier) + (local-assignment (the-environment) 'record-modifier record-updater)) -(define slib:warn - (lambda args - (let ((cep (current-error-port))) - (if (provided? 'trace) (print-call-stack cep)) - (display "Warn: " cep) - (for-each (lambda (x) (display x cep)) args)))) +(define (slib:warn . args) + (if (provided? 'trace) (print-call-stack (notification-output-port))) + (apply warn args)) ;; define an error procedure for the library (define (slib:error . args) (if (provided? 'trace) (print-call-stack (current-error-port))) - (apply error-procedure (append args (list (the-environment))))) + (apply error args)) ;; define these as appropriate for your system. -(define slib:tab (integer->char 9)) -(define slib:form-feed (integer->char 12)) +(define slib:tab (name->char "tab")) +(define slib:form-feed (name->char "page")) -(define in-vicinity string-append) +(define (in-vicinity vicinity file-name) + (->namestring (merge-pathnames file-name vicinity))) ;;; Define SLIB:EXIT to be the implementation procedure to exit or ;;; return if exitting not supported. @@ -297,22 +370,18 @@ (else (exit 1))))) ;;; Here for backward compatability - (define (scheme-file-suffix) ".scm") ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever ;;; suffix all the module files in SLIB have. See feature 'SOURCE. - (define slib:load-source load) ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced ;;; by compiling "foo.scm" if this implementation can compile files. ;;; See feature 'COMPILED. - (define slib:load-compiled load) ;;; At this point SLIB:LOAD must be able to load SLIB files. - (define slib:load slib:load-source) (slib:load (in-vicinity (library-vicinity) "require.scm")) |