path: root/guile.init

;"guile.init" Configuration file for SLIB for GUILE	-*-scheme-*-
;;; Author: Aubrey Jaffer
;;;
;;; This code is in the public domain.

(if (string<? (version) "1.6")
    (define-module (ice-9 slib)))	; :no-backtrace
(define slib-module (current-module))
(define (defined? symbol) (module-defined? slib-module symbol))

(define base:define define)
(define define
  (procedure->memoizing-macro
   (lambda (exp env)
     (cons (if (= 1 (length env)) 'define-public 'base:define) (cdr exp)))))

;;; Hack to make syncase macros work in the slib module
(if (nested-ref the-root-module '(app modules ice-9 syncase))
    (set-object-property! (module-local-variable (current-module) 'define)
			  '*sc-expander*
			  '(define)))

;;; (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) 'guile)

;;; (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.gnu.org/software/guile/guile.html")

;;; (scheme-implementation-version) should return a string describing
;;; the version the scheme implementation loading this file.
(define scheme-implementation-version version)

(define in-vicinity string-append)

;;; (implementation-vicinity) should be defined to be the pathname of
;;; the directory where any auxillary files to your Scheme
;;; implementation reside.
(define implementation-vicinity
  (let* ((path (or (%search-load-path "slib/require.scm")
		   (error "Could not find slib/require.scm in " %load-path)))
	 (vic (substring path 0 (- (string-length path) 16))))
    (lambda () vic)))

;;; (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
	  ;; Use this getenv if your implementation supports it.
	  (and (defined? 'getenv) (getenv "SCHEME_LIBRARY_PATH"))
	  ;; Use this path if your scheme does not support GETENV
	  ;; or if SCHEME_LIBRARY_PATH is not set.
	  (in-vicinity (implementation-vicinity) "slib/"))))
    (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)
  (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*
  (append
      '(
	source				;can load scheme source files
					;(slib:load-source "filename")
;	compiled			;can load compiled files
					;(slib:load-compiled "filename")

		       ;; Scheme report features

;	r5rs				;conforms to
	eval				;R5RS two-argument eval
;	values				;R5RS multiple values
	dynamic-wind			;R5RS dynamic-wind
;	macro				;R5RS high level macros
	delay				;has DELAY and FORCE
	multiarg-apply			;APPLY can take more than 2 args.
;	rationalize
	rev4-optional-procedures	;LIST-TAIL, STRING->LIST,
					;LIST->STRING, STRING-COPY,
					;STRING-FILL!, LIST->VECTOR,
					;VECTOR->LIST, and VECTOR-FILL!

;	r4rs				;conforms to

;	ieee-p1178			;conforms to

;	r3rs				;conforms to

	rev2-procedures			;SUBSTRING-MOVE-LEFT!,
					;SUBSTRING-MOVE-RIGHT!,
					;SUBSTRING-FILL!,
					;STRING-NULL?, APPEND!, 1+,
					;-1+, <?, <=?, =?, >?, >=?
;	object-hash			;has OBJECT-HASH

	multiarg/and-			;/ and - can take more than 2 args.
	with-file			;has WITH-INPUT-FROM-FILE and
					;WITH-OUTPUT-TO-FILE
;	transcript			;TRANSCRIPT-ON and TRANSCRIPT-OFF
;	ieee-floating-point		;conforms to IEEE Standard 754-1985
					;IEEE Standard for Binary
					;Floating-Point Arithmetic.
	full-continuation		;can return multiple times

			;; Other common features

;	srfi				;srfi-0, COND-EXPAND finds all srfi-*
;	sicp				;runs code from Structure and
					;Interpretation of Computer
					;Programs by Abelson and Sussman.
	defmacro			;has Common Lisp DEFMACRO
;	record				;has user defined data structures
	string-port			;has CALL-WITH-INPUT-STRING and
					;CALL-WITH-OUTPUT-STRING
;	sort
;	pretty-print
;	object->string
;	format				;Common-lisp output formatting
;	trace				;has macros: TRACE and UNTRACE
;	compiler			;has (COMPILER)
;	ed				;(ED) is editor
	random
	)

	(if (defined? 'getenv)
	    '(getenv)
	    '())

	(if (defined? 'current-time)
	    '(current-time)
	    '())

	(if (defined? 'system)
	    '(system)
	    '())

	(if (defined? 'array?)
	    '(array)
	    '())

	(if (defined? 'char-ready?)
	    '(char-ready?)
	    '())

	(if (defined? 'array-for-each)
	    '(array-for-each)
	    '())

	*features*))

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

;;; (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 . arg) #t)

;;; 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 (port? obj) (or (input-port? obj) (output-port? obj)))
(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))

;;; "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 #x0FFFFFFF)

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

;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
(define slib:eval
  (if (string<? (scheme-implementation-version) "1.5")
      eval
      (let ((ie (interaction-environment)))
	(lambda (expression)
	  (eval expression ie)))))

;;; Define SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit quit)

;;; Here for backward compatability
;;(define scheme-file-suffix
;;  (let ((suffix (case (software-type)
;;		  ((NOSVE) "_scm")
;;		  (else ".scm"))))
;;    (lambda () suffix)))

(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 (guile:wrap-case-insensitive proc)
  (lambda args
    (save-module-excursion
     (lambda ()
       (set-current-module slib-module)
       (let ((old (read-options)))
	 (dynamic-wind
	     (lambda () (read-enable 'case-insensitive))
	     (lambda () (apply proc args))
	     (lambda () (read-options old))))))))

(define read (guile:wrap-case-insensitive read))

;;; (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
  (let ((load-file (guile:wrap-case-insensitive load)))
    (lambda (<pathname>)
      (load-file (string-append <pathname> (scheme-file-suffix))))))

(define slib:load-source slib: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 slib:load)

(define defmacro:eval slib:eval)
(define defmacro:load slib:load)

(define (defmacro:expand* x)
  (require 'defmacroexpand) (apply defmacro:expand* x '()))

;;; If your implementation provides R4RS macros:
(define macro:eval slib:eval)
(define macro:load slib:load)

(define slib:warn warn)
(define slib:error error)

;;; define these as appropriate for your system.
(define slib:tab #\tab)
(define slib:form-feed #\page)

;;; {Time}
(define difftime -)
(define offset-time +)

;;; Early version of 'logical is built-in
(define logical:logand			logand)
(define logical:logior			logior)
;;(define logical:logxor			logxor)
;;(define logical:lognot			lognot)
;;(define logical:logtest			logtest)
;;(define logical:logbit?			logbit?)
(define (copy-bit index to bool)
  (if bool
      (logical:logior to (logical:ash 1 index))
      (logical:logand to (logical:lognot (logical:ash 1 index)))))
;;(define copy-bit			logical:copy-bit)
;;(define logical:ash			ash)
;;(define logical:logcount		logcount)
;;(define logical:integer-length		integer-length)
(define (logical:bit-field n start end)
  (logical:logand (- (logical:integer-expt 2 (- end start)) 1)
		  (logical:ash n (- start))))
;;(define bit-field			logical:bit-field)
(define (bitwise-if mask n0 n1)
  (logical:logior (logical:logand mask n0)
		  (logical:logand (logical:lognot mask) n1)))
(define logical:bitwise-if			bitwise-if)
;;(define logical:bit-extract		bit-extract)
(define (copy-bit-field to start end from)
  (logical:bitwise-if
   (logical:ash (- (logical:integer-expt 2 (- end start)) 1) start)
   (logical:ash from start)
   to))
;;(define copy-bit-field			logical:copy-bit-field)
(define logical:integer-expt		integer-expt)
;;(define logical:ipow-by-squaring	ipow-by-squaring)

;;guile> (expt 2 -1)
;;ERROR: In procedure integer-expt:
;;ERROR: Argument out of range: -1
;;ABORT: (out-of-range)
(define expt
  (let ((integer-expt integer-expt))
    (lambda (z1 z2)
      (cond ((zero? z1) (if (zero? z2) 1 0))
	    ((and (exact? z2) (not (negative? z2)))
	     (integer-expt z1 z2))
	    ((and (real? z2) (real? z1) (>= z1 0))
	     ($expt z1 z2))
	    (else
	     (exp (* z2 (log z1))))))))

;;; array-for-each
(define (array-indexes ra)
  (let ((ra0 (apply create-array '#() (array-shape ra))))
    (array-index-map! ra0 list)
    ra0))
(define (array-copy! source dest)
  (array-map! dest identity source))
(define (array-null? array)
  (zero? (apply * (map (lambda (bnd) (- 1 (apply - bnd)))
		       (array-shape array)))))
(define (create-array prot . args)
  (if (array-null? prot)
      (dimensions->uniform-array args (array-prototype prot))
      (dimensions->uniform-array args (array-prototype prot)
				 (apply array-ref prot
					(map car (array-shape prot))))))
(define (make-uniform-wrapper prot)
  (if (string? prot) (set! prot (string->number prot)))
  (if prot
      (lambda opt (if (null? opt)
		      (list->uniform-array 1 prot '())
		      (list->uniform-array 1 prot opt)))
      vector))
(define ac64 (make-uniform-wrapper "+i"))
(define ac32 ac64)
(define ar64 (make-uniform-wrapper "1/3"))
(define ar32 (make-uniform-wrapper "1."))
(define as64 vector)
(define as32 (make-uniform-wrapper -32))
(define as16 as32)
(define as8  as32)
(define au64 vector)
(define au32 (make-uniform-wrapper  32))
(define au16 au32)
(define au8  au32)
(define at1  (make-uniform-wrapper  #t))

;;; {Random numbers}
(define (make-random-state . args)
  (let ((seed (if (null? args) *random-state* (car args))))
    (cond ((string? seed))
	  ((number? seed) (set! seed (number->string seed)))
	  (else (let ()
		  (require 'object->string)
		  (set! seed (object->limited-string seed 50)))))
    (seed->random-state seed)))

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

;;; Guile has nil and t as self-sets
;;(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+)

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