path: root/chez.init

;"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 <port>)
(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 <pathname> evl)
  (if (not (file-exists? <pathname>))
      (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  (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)))))

;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