summaryrefslogtreecommitdiffstats
path: root/mitscheme.init
diff options
context:
space:
mode:
Diffstat (limited to 'mitscheme.init')
-rw-r--r--mitscheme.init305
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"))