From 8ffbc2df0fde83082610149d24e594c1cd879f4a Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 2a6 --- chez.init | 266 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 266 insertions(+) create mode 100644 chez.init (limited to 'chez.init') diff --git a/chez.init b/chez.init new file mode 100644 index 0000000..a91cce3 --- /dev/null +++ b/chez.init @@ -0,0 +1,266 @@ +;"chez.init" Initialization file for SLIB for Chez Scheme -*-scheme-*- +; Copyright (C) 1993 dorai@cs.rice.edu (Dorai Sitaram) +; Copyright (C) 1991, 1992, 1993 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. + +;;; (software-type) should be set to the generic operating system type. +;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. + +(define (software-type) 'UNIX) + +(define (scheme-implementation-type) 'Chez) + +;;; (scheme-implementation-version) should return a string describing +;;; the version the scheme implementation loading this file. + +(define (scheme-implementation-version) "?") + +(define implementation-vicinity + (lambda () "/usr/local/lib/scheme/")) + +;; library-vicinity is moved below the defination of getenv + +(define *features* + '( + source ;can load scheme source files + ;(slib:load-source "filename") + compiled ;can load compiled files + ;(slib:load-compiled "filename") + char-ready? + delay + dynamic-wind + fluid-let + format + full-continuation + getenv + ieee-p1178 + macro + multiarg/and- + multiarg-apply + pretty-print + random + random-inexact + rationalize + rev3-procedures + rev3-report + rev4-optional-procedures + rev4-report + sort + system + transcript + with-file + string-port + )) + +;R4RS define-syntax in terms of Chez's extend-syntax. +;Caveat: no let-syntax + +(extend-syntax (define-syntax syntax-rules) + ((define-syntax name (syntax-rules kwds . clauses)) + (extend-syntax (name . kwds) . clauses))) + +;DEFINED? +(define-syntax defined? + (syntax-rules () + ((defined? x) (or (bound? 'x) (get 'x '*expander*))))) + +;Chez's sort routines have the opposite parameter order to Slib's +(define chez:sort sort) +(define chez:sort! sort!) +(define chez:merge merge) +(define chez:merge! merge!) + +(define sort + (lambda (s p) + (chez:sort p s))) +(define sort! + (lambda (s p) + (chez:sort! p s))) +(define merge + (lambda (s1 s2 p) + (chez:merge p s1 s2))) +(define merge! + (lambda (s1 s2 p) + (chez:merge! p s1 s2))) + +;RENAME-FILE +(define rename-file + (lambda (src dst) + (system (string-append "mv " src " " dst)))) + +;OUTPUT-PORT-WIDTH +(define output-port-width (lambda arg 79)) + +;;; (OUTPUT-PORT-HEIGHT ) +(define (output-port-height . arg) 24) + +;;; (CURRENT-ERROR-PORT) +(define current-error-port + (let ((port (current-output-port))) + (lambda () 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))))) + +;GETENV +(provide-foreign-entries '("getenv")) +(define getenv + (foreign-procedure "getenv" + (string) string)) + +(define library-vicinity + (let ((library-path (or (getenv "SCHEME_LIBRARY_PATH") + "/usr/local/lib/slib/"))) + (lambda () library-path))) + +;FORCE-OUTPUT +(define force-output flush-output) + +;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string +;;; port versions of CALL-WITH-*PUT-FILE. +(define (call-with-output-string f) + (let ((outsp (open-output-string))) + (f outsp) + (let ((s (get-output-string outsp))) + (close-output-port outsp) + s))) + +(define (call-with-input-string s f) + (let* ((insp (open-input-string s)) + (res (f insp))) + (close-input-port insp) + res)) + +;CHAR-CODE-LIMIT +(define char-code-limit 256) + +;Chez's MOST-POSITIVE-FIXNUM is a thunk rather than a number +(if (procedure? most-positive-fixnum) + (set! most-positive-fixnum (most-positive-fixnum))) + +;;; Return argument +(define (identity x) x) + +(define slib:eval eval) + +(define-macro! defmacro z `(define-macro! ,@z)) + +(define (defmacro? m) (get m '*expander*)) + +(define macroexpand-1 eps-expand-once) + +(define (macroexpand e) + (if (pair? e) (let ((a (car e))) + (if (and (symbol? a) (getprop a '*expander*)) + (macroexpand (expand-once 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*)))))) + +(define defmacro:eval slib:eval) +(define macro:eval slib: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))))) + +;Chez's (FORMAT f . a) corresponds to Slib's (FORMAT #f f . a) + +(define chez:format format) +(define format + (lambda (where how . args) + (let ((str (apply chez:format how args))) + (cond ((not where) str) + ((eq? where #t) (display str)) + (else (display str where)))))) + +(define slib:error + (lambda args + (let ((port (current-error-port))) + (display "Error: " port) + (for-each (lambda (x) (display x port)) args) + (error #f "")))) + +(define slib:tab #\tab) +(define slib:form-feed #\page) + +;Chez's nil variable is bound to '() rather than #f + +(define nil #f) + +(define in-vicinity string-append) + +;;; Define SLIB:EXIT to be the implementation procedure to exit or +;;; return if exitting not supported. +(define slib:chez:quit + (let ([arg (call-with-current-continuation (lambda (x) x))]) + (cond [(procedure? arg) arg] + [arg (exit)] + [else (exit 1)]))) + +(define slib:exit + (lambda args + (cond ((null? args) (slib:chez:quit #t)) + ((eqv? #t (car args)) (slib:chez:quit #t)) + ((eqv? #f (car args)) (slib:chez:quit #f)) + ((zero? (car args)) (slib:chez:quit #t)) + (else (slib:chez:quit #f))))) + +;;; Here for backward compatability +;Note however that ".ss" is a common Chez file suffix +(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 f) (load (string-append f (scheme-file-suffix)))) + +;;; defmacro:load and macro:load also need the default suffix +(define defmacro:load slib:load-source) +(define macro:load slib:load-source) + +;;; (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")) +;end chez.init -- cgit v1.2.3