;;;"scheme48.init" Initialisation for SLIB for Scheme48 -*-scheme-*- ;;; Copyright (C) 1992, 1993, 1994, 1995, 1997 Aubrey Jaffer. ; ;Permission to copy this software, to redistribute it, and to use it ;for any purpose is granted, subject to the following restrictions and ;understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. ; ;2. I have made no warrantee or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; ;3. In conjunction with products arising from the use of this ;material, there shall be no use of my name in any advertising, ;promotional, or sales literature without prior written consent in ;each case. ;;; If you know the magic incantation to make a "," command available ;;; as a scheme procedure, you can make a nifty slib function to do ;;; this (like `slib:dump' in "vscm.init"). But for now, type: ;;; make slib48 ;;; (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 ;;; implementation loading this file. (define (scheme-implementation-type) 'Scheme48) ;;; (scheme-implementation-version) should return a string describing ;;; the version of the scheme implementation loading this file. (define scheme-implementation-version (cond ((= -86400 (modulo -2177452800 -86400)) (display "scheme48-0.36 has been superseded by") (newline) (display "ftp@ftp-swiss.ai.mit.edu:pub/s48/scheme48-0.46.tgz") (newline) (display "ftp://ftp-swiss.ai.mit.edu/pub/s48/scheme48-0.46.tgz") (newline) (lambda () "0.36")) (else (lambda () "0.46")))) ;;; (implementation-vicinity) should be defined to be the pathname of ;;; the directory where any auxiliary files to your Scheme ;;; implementation reside. ;;; [ defined from the Makefile ] ;;; (library-vicinity) should be defined to be the pathname of the ;;; directory where files of Scheme library functions reside. ;;; [ defined from the Makefile ] (define getenv s48-getenv) (define system s48-system) ;;; (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 ;;; of this implementation. See Template.scm for the list of feature ;;; names. (define *features* '( source ;can load scheme source files ;(slib:load-source "filename") ; compiled ;can load compiled files ;(slib:load-compiled "filename") rev4-report ;conforms to ieee-p1178 ;conforms to rev4-optional-procedures multiarg/and- multiarg-apply rationalize delay ;has delay and force with-file char-ready? ;has values ;proposed multiple values eval ;slib:eval is single argument eval. dynamic-wind ;proposed dynamic-wind full-continuation ;can return multiple times macro ;R4RS appendix's DEFINE-SYNTAX system ;posix (system ) getenv ;posix (getenv ) )) ;;; (OUTPUT-PORT-WIDTH ) (define (output-port-width . arg) 79) ;;; (OUTPUT-PORT-HEIGHT ) (define (output-port-height . arg) 24) ;;; (CURRENT-ERROR-PORT) (define current-error-port s48-current-error-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))))) ;;; (FILE-EXISTS? ) (define (file-exists? f) (call-with-current-continuation (lambda (k) (s48-with-handler (lambda (condition decline) (k #f)) (lambda () (close-input-port (open-input-file f)) #t))))) ;;; (DELETE-FILE ) (define (delete-file file-name) (s48-system (string-append "rm " file-name))) ;;; 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) (s48-force-output (if (null? arg) (current-output-port) (car arg)))) ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can ;;; be returned by CHAR->INTEGER. (define integer->char s48-ascii->char) (define char->integer (let ((char->integer char->integer) (code0 (char->integer (integer->char 0)))) (lambda (char) (- (char->integer char) code0)))) (define char-code-limit 256) ;;; Workaround MODULO bug (define modulo (let ((modulo modulo)) (lambda (n1 n2) (let ((ans (modulo n1 n2))) (if (= ans n2) (- ans ans) ans))))) ;;; MOST-POSITIVE-FIXNUM is used in modular.scm (define most-positive-fixnum #x1FFFFFFF) ;;; Return argument (define (identity x) x) ;;; If your implementation provides eval, SLIB:EVAL is single argument ;;; eval using the top-level (user) environment. (define slib:eval (let ((eval eval) (interaction-environment interaction-environment)) (lambda (form) (eval form (interaction-environment))))) ;;; If your implementation provides R4RS macros: (define macro:eval slib:eval) (define (macro:load ) (if (not (file-exists? )) (set! (string-append (scheme-file-suffix)))) (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))) (cond ((symbol? a) (set! a (assq a *defmacros*)) (if a (apply (cdr a) (cdr e)) e)) (else e))) e)) (define (macroexpand e) (if (pair? e) (let ((a (car e))) (cond ((symbol? a) (set! a (assq a *defmacros*)) (if a (macroexpand (apply (cdr a) (cdr e))) e)) (else 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*)))))) (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 ) (slib:eval-load defmacro:eval)) (define (slib:eval-load evl) (if (not (file-exists? )) (set! (string-append (scheme-file-suffix)))) (call-with-input-file (lambda (port) (let ((old-load-pathname *load-pathname*)) (set! *load-pathname* ) (do ((o (read port) (read port))) ((eof-object? o)) (evl o)) (set! *load-pathname* old-load-pathname))))) (define slib:warn (lambda args (let ((port (current-error-port))) (display "Warn: " port) (for-each (lambda (x) (display x port)) args)))) ;;; define an error procedure for the library (define slib:error s48-error) ;;; define these as appropriate for your system. (define slib:tab (s48-ascii->char 9)) (define slib:form-feed (s48-ascii->char 12)) ;;; 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 them 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 ;;; return if exitting not supported. (define slib:exit (lambda args #f)) ;;; Here for backward compatability (define scheme-file-suffix (case (software-type) ((NOSVE) (lambda () "_scm")) (else (lambda () ".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 f) (load (string-append f (scheme-file-suffix)))) ;;; (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) ;;; Scheme48 complains that these are not defined (even though they ;;; won't be called until they are). (define synclo:load #f) (define syncase:load #f) (define macwork:load #f) (define transcript-on #f) (define transcript-off #f) (slib:load (in-vicinity (library-vicinity) "require"))