diff options
Diffstat (limited to 'Template.scm')
| -rw-r--r-- | Template.scm | 146 |
1 files changed, 87 insertions, 59 deletions
diff --git a/Template.scm b/Template.scm index 6421d92..63c10c9 100644 --- a/Template.scm +++ b/Template.scm @@ -3,40 +3,34 @@ ;;; ;;; This code is in the public domain. -;;; (software-type) should be set to the generic operating system type. +;;@ (software-type) should be set to the generic operating system type. ;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - (define (software-type) 'UNIX) -;;; (scheme-implementation-type) should return the name of the scheme +;;@ (scheme-implementation-type) should return the name of the scheme ;;; implementation loading this file. - (define (scheme-implementation-type) 'Template) -;;; (scheme-implementation-home-page) should return a (string) URI +;;@ (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) #f) -;;; (scheme-implementation-version) should return a string describing +;;@ (scheme-implementation-version) should return a string describing ;;; the version the scheme implementation loading this file. - (define (scheme-implementation-version) "?") -;;; (implementation-vicinity) should be defined to be the pathname of +;;@ (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) ((UNIX) "/usr/local/src/scheme/") ((VMS) "scheme$src:") ((MS-DOS) "C:\\scheme\\"))) -;;; (library-vicinity) should be defined to be the pathname of the +;;@ (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 @@ -51,17 +45,21 @@ (else ""))))) (lambda () library-path))) -;;; (home-vicinity) should return the vicinity of the user's HOME +;;@ (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))) - -;;; *FEATURES* should be set to a list of symbols describing features +(define (home-vicinity) + (let ((home (getenv "HOME"))) + (and home + (case (software-type) + ((UNIX COHERENT MS-DOS) ;V7 unix has a / on HOME + (if (eqv? #\/ (string-ref home (+ -1 (string-length home)))) + home + (string-append home "/"))) + (else home))))) + +;;@ *FEATURES* should be set to a list of symbols describing features ;;; of this implementation. Suggestions for features are: - (define *features* '( source ;can load scheme source files @@ -71,7 +69,7 @@ ;; Scheme report features - rev5-report ;conforms to + r5rs ;conforms to eval ;R5RS two-argument eval values ;R5RS multiple values dynamic-wind ;R5RS dynamic-wind @@ -85,11 +83,11 @@ ;STRING-FILL!, LIST->VECTOR, ;VECTOR->LIST, and VECTOR-FILL! - rev4-report ;conforms to + r4rs ;conforms to ieee-p1178 ;conforms to -; rev3-report ;conforms to +; r3rs ;conforms to ; rev2-procedures ;SUBSTRING-MOVE-LEFT!, ;SUBSTRING-MOVE-RIGHT!, @@ -100,7 +98,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 @@ -133,66 +131,66 @@ )) -;;; (OUTPUT-PORT-WIDTH <port>) +;;@ (OUTPUT-PORT-WIDTH <port>) (define (output-port-width . arg) 79) -;;; (OUTPUT-PORT-HEIGHT <port>) +;;@ (OUTPUT-PORT-HEIGHT <port>) (define (output-port-height . arg) 24) -;;; (CURRENT-ERROR-PORT) +;;@ (CURRENT-ERROR-PORT) (define current-error-port (let ((port (current-output-port))) (lambda () port))) -;;; (TMPNAM) makes a temporary file name. +;;@ (TMPNAM) makes a temporary file name. (define tmpnam (let ((cntr 100)) (lambda () (set! cntr (+ 1 cntr)) (string-append "slib_" (number->string cntr))))) -;;; (FILE-EXISTS? <string>) +;;@ (FILE-EXISTS? <string>) (define (file-exists? f) #f) -;;; (DELETE-FILE <string>) +;;@ (DELETE-FILE <string>) (define (delete-file f) #f) -;;; FORCE-OUTPUT flushes any pending output on optional arg output port +;;@ FORCE-OUTPUT flushes any pending output on optional arg output port ;;; use this definition if your system doesn't have such a procedure. (define (force-output . arg) #t) ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string ;;; port versions of CALL-WITH-*PUT-FILE. -;;; "rationalize" adjunct procedures. +;;@ "rationalize" adjunct procedures. ;;(define (find-ratio x e) ;; (let ((rat (rationalize x e))) ;; (list (numerator rat) (denominator rat)))) ;;(define (find-ratio-between x y) ;; (find-ratio (/ (+ x y) 2) (/ (- x y) 2))) -;;; CHAR-CODE-LIMIT is one greater than the largest integer which can +;;@ CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define char-code-limit 256) -;;; MOST-POSITIVE-FIXNUM is used in modular.scm +;;@ MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum #x0FFFFFFF) -;;; Return argument +;;@ Return argument (define (identity x) x) -;;; SLIB:EVAL is single argument eval using the top-level (user) environment. +;;@ SLIB:EVAL is single argument eval using the top-level (user) environment. (define slib:eval eval) -;;; If your implementation provides R4RS macros: +;; If your implementation provides R4RS macros: ;(define macro:eval slib:eval) ;(define macro:load load) - (define *defmacros* (list (cons 'defmacro (lambda (name parms . body) `(set! *defmacros* (cons (cons ',name (lambda ,parms ,@body)) *defmacros*)))))) +;@ (define (defmacro? m) (and (assq m *defmacros*) #t)) - +;@ (define (macroexpand-1 e) (if (pair? e) (let ((a (car e))) @@ -200,7 +198,7 @@ (if a (apply (cdr a) (cdr e)) e)) (else e))) e)) - +;@ (define (macroexpand e) (if (pair? e) (let ((a (car e))) @@ -209,7 +207,7 @@ (if a (macroexpand (apply (cdr a) (cdr e))) e)) (else e))) e)) - +;@ (define gentemp (let ((*gensym-counter* -1)) (lambda () @@ -218,13 +216,15 @@ (string-append "slib:G" (number->string *gensym-counter*)))))) (define base:eval slib:eval) +;@ (define (defmacro:eval x) (base:eval (defmacro:expand* x))) + (define (defmacro:expand* x) (require 'defmacroexpand) (apply defmacro:expand* x '())) - +;@ (define (defmacro:load <pathname>) (slib:eval-load <pathname> defmacro:eval)) - +;@ (define (slib:eval-load <pathname> evl) (if (not (file-exists? <pathname>)) (set! <pathname> (string-append <pathname> (scheme-file-suffix)))) @@ -236,61 +236,89 @@ ((eof-object? o)) (evl o)) (set! *load-pathname* old-load-pathname))))) - +;@ (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)))) + (for-each (lambda (x) (display #\ cep) (write x cep)) args)))) -;;; define an error procedure for the library +;;@ define an error procedure for the library (define (slib:error . args) (if (provided? 'trace) (print-call-stack (current-error-port))) (apply error args)) - -;;; define these as appropriate for your system. +;@ +(define (make-exchanger obj) + (lambda (rep) (let ((old obj)) (set! obj rep) old))) +(define (open-file filename modes) + (case modes + ((r rb) (open-input-file filename)) + ((w wb) (open-output-file filename)) + (else (slib:error 'open-file 'mode? modes)))) +(define (port? obj) (or (input-port? port) (output-port? 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 (close-port port) + (cond ((input-port? port) + (close-input-port port) + (if (output-port? port) (close-output-port port))) + ((output-port? port) (close-output-port port)) + (else (slib:error 'close-port 'port? port)))) +;@ +(define (browse-url 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 '" "'"))) + +;;@ define these as appropriate for your system. (define slib:tab (integer->char 9)) (define slib:form-feed (integer->char 12)) -;;; Support for older versions of Scheme. Not enough code for its own file. +;;@ Support for older versions of Scheme. Not enough code for its own file. (define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) (define t #t) (define nil #f) -;;; Define these if your implementation's syntax can support it and if +;;@ Define these if your implementation's syntax can support it and if ;;; they are not already defined. - ;(define (1+ n) (+ n 1)) ;(define (-1+ n) (+ n -1)) ;(define 1- -1+) +;@ (define in-vicinity string-append) -;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;@ Define SLIB:EXIT to be the implementation procedure to exit or ;;; return if exitting not supported. (define slib:exit (lambda args #f)) -;;; Here for backward compatability +;;@ Here for backward compatability (define scheme-file-suffix (let ((suffix (case (software-type) ((NOSVE) "_scm") (else ".scm")))) (lambda () suffix))) -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever +;;@ (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 f) (load (string-append f ".scm"))) -;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced +;;@ (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. - +;;@ 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")) |