path: root/gambit.init

;;;"gambit.init" Initialization for SLIB for Gambit	-*-scheme-*-
;;; Author: Aubrey Jaffer
;;;
;;; This code is in the public domain.

;;; Ignore case when reading symbols (per R5RS).
(set-case-conversion! #t)

;;; Updated 1992 February 1 for Gambit v1.71 -- by Ken Dickey
;;; Date: Wed, 12 Jan 1994 15:03:12 -0500
;;; From: barnett@armadillo.urich.edu (Lewis Barnett)
;;; Relative pathnames for Slib in MacGambit
;;; Hacked yet again for Gambit v2.4, Jan 1997, by Mike Pope
(define (software-type) 'MACOS)		; for MacGambit.
(define (software-type) 'UNIX)		; for Unix platforms.

(define (scheme-implementation-type) 'gambit)

;;; (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://www.iro.umontreal.ca/~gambit/index.html")

(define (scheme-implementation-version) "3.0")
;;; Jefferson R. Lowrey reports that in Gambit Version 3.0
;;; (argv) returns '("").
(define argv
  (if (equal? '("") (argv))		;Fix only if it is broken.
      (lambda () '("Lowrey HD:Development:MacGambit 3.0:Interpreter"))
      argv))

;;; (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)	(lambda () "/usr/local/share/gambc/"))
    ((VMS)	(lambda () "scheme$src:"))
    ((MS-DOS)	(lambda () "C:\\scheme\\"))
    ((WINDOWS)  (lambda () "c:/scheme/"))
    ((MACOS)
     (let ((arg0 (list-ref (argv) 0)))
       (let loop ((i (- (string-length arg0) 1)))
	 (cond ((negative? i) "")
	       ((char=? #\: (string-ref arg0 i))
		(set! arg0 (substring arg0 0 (+ i 1)))
		(lambda () arg0))
	       (else (loop (- i 1)))))))))

;;; (library-vicinity) should be defined to be the pathname of the
;;; directory where files of Scheme library functions reside.
;;;
;;; This assumes that the slib files are in a folder
;;; called slib in the same directory as the MacGambit Interpreter.
(define library-vicinity
  (let ((library-path
	 (case (software-type)
	   ((UNIX) "/usr/local/lib/slib/")
	   ((MACOS) (string-append (implementation-vicinity) "slib:"))
	   ((AMIGA)	"dh0:scm/Library/")
	   ((VMS) "lib$scheme:")
	   ((WINDOWS MS-DOS) "C:\\SLIB\\")
	   (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
  (case (software-type)
    ((UNIX)	(lambda () "~/"))
    ((VMS)	(lambda () "~:"))
    ((MS-DOS)	(lambda () "~\\"))
    ((WINDOWS)  (lambda () "~/"))
    ((MACOS)    (lambda () "~:"))))

;;; *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
					;(slib:load-source "filename")
	compiled			;can load compiled files
					;(slib:load-compiled "filename")
	r4rs				;conforms to
;	r3rs				;conforms to
	ieee-p1178			;conforms to
;	srfi				;srfi-0, COND-EXPAND finds all srfi-*
	sicp				;runs code from Structure and
					;Interpretation of Computer
					;Programs by Abelson and Sussman.
	rev4-optional-procedures	;LIST-TAIL, STRING->LIST,
					;LIST->STRING, STRING-COPY,
					;STRING-FILL!, LIST->VECTOR,
					;VECTOR->LIST, and VECTOR-FILL!
;	rev2-procedures			;SUBSTRING-MOVE-LEFT!,
					;SUBSTRING-MOVE-RIGHT!,
					;SUBSTRING-FILL!,
					;STRING-NULL?, APPEND!, 1+,
					;-1+, <?, <=?, =?, >?, >=?
	multiarg/and-			;/ and - can take more than 2 args.
	multiarg-apply			;APPLY can take more than 2 args.
	rationalize
	delay				;has DELAY and FORCE
	with-file			;has WITH-INPUT-FROM-FILE and
					;WITH-OUTPUT-TO-FILE
	string-port			;has CALL-WITH-INPUT-STRING and
					;CALL-WITH-OUTPUT-STRING
	transcript			;TRANSCRIPT-ON and TRANSCRIPT-OFF
	char-ready?
;	macro				;has R4RS high level macros
	defmacro			;has Common Lisp DEFMACRO
;	record				;has user defined data structures
;	values				;proposed multiple values
;	dynamic-wind			;proposed dynamic-wind
	ieee-floating-point		;conforms to
	full-continuation		;can return multiple times
;	object-hash			;has OBJECT-HASH

;	sort
	pretty-print
;	object->string
;	format
	trace				;has macros: TRACE and UNTRACE
	break
;	compiler			;has (COMPILER)
;	ed				;(ED) is editor
	system				;posix (system <string>)
;	getenv				;posix (getenv <string>)
	program-arguments		;returns list of strings (argv)
;	current-time			;returns time in seconds since 1/1/1970
    ))

;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . 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))
			 (string-append "slib_" (number->string cntr)))))

;;; Gambit supports SYSTEM as an "Unstable Addition"; Watch for changes.
(define system ##shell-command)

;;; (FILE-EXISTS? <string>)
;(define (file-exists? f) #f)

;;; (DELETE-FILE <string>)
(define (delete-file f) #f)

;;; 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 flush-output)

;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
;;; port versions of CALL-WITH-*PUT-FILE.

(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) (eqv? 0 (system (sprintf #f cmd url))))
  (or (try "netscape-remote -remote 'openURL(%s)'")
      (try "netscape -remote 'openURL(%s)'")
      (try "netscape '%s'&")
      (try "netscape '%s'")))

;;; "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
;;; be returned by CHAR->INTEGER.
(define char-code-limit 256)

;; MOST-POSITIVE-FIXNUM is used in modular.scm
(define most-positive-fixnum #x1FFFFFFF) ; 3-bit tag for 68K

;;; Return argument
(define (identity x) x)

;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define slib:eval eval)

; Define program-arguments as argv
(define program-arguments argv)

;;; 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)))
		  (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 base:eval)

(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))))
  (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)))))

(define print-call-stack identity)	;noop

(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 #\  cep) (write x cep)) args))))

;; 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 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.
(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
;;; 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 (exit)))

;;; 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
;;; 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:eval '(define-macro (defmacro name parms . body)
	      (set! *defmacros* (cons `(cons ',name (lambda ,parms ,@body))
				      *defmacros*))
	      `(define-macro (,name ,@parms) ,@body)))

(slib:load (in-vicinity (library-vicinity) "require"))