home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / bigloo.init < prev    next >
Encoding:
Text File  |  2004-01-06  |  7.7 KB  |  264 lines
  1. ;; "bigloo.init" Initialization for SLIB for Bigloo    -*-scheme-*-
  2. ;; Copyright 1994 Robert Sanders
  3. ;; Copyright 1991, 1992, 1993 Aubrey Jaffer
  4. ;; Copyright 1991 David Love
  5. ;; 
  6. ;; Permission to copy this software, to redistribute it, and to use it
  7. ;; for any purpose is granted, subject to the following restrictions and
  8. ;; understandings.
  9. ;; 
  10. ;; 1.  Any copy made of this software must include this copyright notice
  11. ;; in full.
  12. ;; 
  13. ;; 2.  I have made no warrantee or representation that the operation of
  14. ;; this software will be error-free, and I am under no obligation to
  15. ;; provide any services, by way of maintenance, update, or otherwise.
  16. ;; 
  17. ;; 3.  In conjunction with products arising from the use of this
  18. ;; material, there shall be no use of my name in any advertising,
  19. ;; promotional, or sales literature without prior written consent in
  20. ;; each case.
  21.  
  22. (define (software-type) 'UNIX)
  23.  
  24. ;;; (scheme-implementation-type) should return the name of the scheme
  25. ;;; implementation loading this file.
  26.  
  27. (define (scheme-implementation-type) 'Bigloo)
  28.  
  29. ;;; (scheme-implementation-version) should return a string describing
  30. ;;; the version the scheme implementation loading this file.
  31.  
  32. ;;; (scheme-implementation-home-page) should return a (string) URL
  33. ;;; (Uniform Resource Locator) for this scheme implementation's home
  34. ;;; page; or false if there isn't one.
  35.  
  36. (define (scheme-implementation-home-page)
  37.   "http://kaolin.unice.fr/~serrano/bigloo/bigloo.html")
  38.  
  39. (define (scheme-implementation-version) "2.0c")
  40.  
  41. ;;; (implementation-vicinity) should be defined to be the pathname of
  42. ;;; the directory where any auxillary files to your Scheme
  43. ;;; implementation reside.
  44.  
  45. (define (implementation-vicinity)
  46.   (case (software-type)
  47.     ((UNIX)    "/usr/unsup/lib/bigloo/")
  48.     ((VMS)    "scheme$src:")
  49.     ((MSDOS)    "C:\\scheme\\")))
  50.  
  51. ;;; (library-vicinity) should be defined to be the pathname of the
  52. ;;; directory where files of Scheme library functions reside.
  53.  
  54. (define library-vicinity
  55.   (let ((library-path
  56.      (or
  57.       ;; Use this getenv if your implementation supports it.
  58.       (getenv "SCHEME_LIBRARY_PATH")
  59.       ;; Use this path if your scheme does not support GETENV
  60.       ;; or if SCHEME_LIBRARY_PATH is not set.
  61.       (case (software-type)
  62.         ((UNIX) "/home/bambam/leavens/unsup-src/scheme/scm/slib/")
  63.         ((VMS) "lib$scheme:")
  64.         ((MSDOS) "C:\\SLIB\\")
  65.         (else "")))))
  66.     (lambda () library-path)))
  67.  
  68. ;;; (home-vicinity) should return the vicinity of the user's HOME
  69. ;;; directory, the directory which typically contains files which
  70. ;;; customize a computer environment for a user.
  71.  
  72. (define home-vicinity
  73.   (let ((home-path (getenv "HOME")))
  74.     (lambda () home-path)))
  75.  
  76. ;;; *FEATURES* should be set to a list of symbols describing features
  77. ;;; of this implementation.  See Template.scm for the list of feature
  78. ;;; names.
  79.  
  80. (define *features*
  81.   '(
  82.     source                ;can load scheme source files
  83.                     ;(slib:load-source "filename")
  84.     rev4-report                ;conforms to
  85.     rev3-report                ;conforms to
  86.     ieee-p1178                ;conforms to
  87.     rev4-optional-procedures
  88.     rev3-procedures
  89.     multiarg/and-
  90.     multiarg-apply
  91.     rationalize
  92.     object-hash
  93.     delay
  94.     promise
  95.     with-file
  96.     transcript
  97.     ieee-floating-point
  98.     eval
  99.     pretty-print
  100.     object->string
  101.     string-case
  102.     string-port
  103.     system
  104.     getenv
  105.     defmacro
  106.     ;;full-continuation            ;not without the -call/cc switch
  107.     ))
  108.  
  109. (define pretty-print pp)
  110.  
  111. (define (object->string x) (obj->string x))
  112.  
  113. ;;; Define these if your implementation's syntax can support it and if
  114. ;;; they are not already defined.
  115.  
  116. (define (1+ n) (+ n 1))
  117. (define (-1+ n) (+ n -1))
  118. (define 1- -1+)
  119.  
  120. ;;; (OUTPUT-PORT-WIDTH <port>)
  121. (define (output-port-width . arg) 79)
  122.  
  123. ;;; (OUTPUT-PORT-HEIGHT <port>)
  124. (define (output-port-height . arg) 24)
  125.  
  126. ;;; (TMPNAM) makes a temporary file name.
  127. (define tmpnam
  128.   (let ((cntr 100))
  129.     (lambda ()
  130.       (set! cntr (+ 1 cntr))
  131.       (let ((tmp (string-append "slib_" (number->string cntr))))
  132.     (if (file-exists? tmp) (tmpnam) tmp)))))
  133.  
  134. ;;; FORCE-OUTPUT flushes any pending output on optional arg output port
  135. ;;; use this definition if your system doesn't have such a procedure.
  136. (define (force-output . args)
  137.   (flush-output-port (if (pair? args) (car args) (current-output-port))))
  138.  
  139. ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
  140. ;;; port versions of CALL-WITH-*PUT-FILE.
  141. (define (call-with-output-string f)
  142.   (let ((outsp (open-output-string)))
  143.     (f outsp)
  144.     (close-output-port outsp)))
  145.  
  146. (define (call-with-input-string s f)
  147.   (let* ((insp (open-input-string s))
  148.      (res (f insp)))
  149.     (close-input-port insp)
  150.     res))
  151.  
  152. ;;; "rationalize" adjunct procedures.
  153. (define (find-ratio x e)
  154.   (let ((rat (rationalize x e)))
  155.     (list (numerator rat) (denominator rat))))
  156. (define (find-ratio-between x y)
  157.   (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
  158.  
  159. ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
  160. ;;; be returned by CHAR->INTEGER.
  161. (define char-code-limit 256)
  162.  
  163. ;; MOST-POSITIVE-FIXNUM is used in modular.scm
  164. (define most-positive-fixnum 536870911)
  165.  
  166. ;;; Return argument
  167. (define (identity x) x)
  168.  
  169. ;; define an error procedure for the library
  170.  
  171. ;;; If your implementation provides eval, SLIB:EVAL is single argument
  172. ;;; eval using the top-level (user) environment.
  173. (define slib:eval eval)
  174.  
  175. (define-macro (defmacro name . forms)
  176.   `(define-macro (,name . ,(car forms)) ,@(cdr forms)))
  177.  
  178. (define (defmacro? m) (get-eval-expander m))
  179. (define (macroexpand-1 body) (expand-once body))
  180. (define (macroexpand body) (expand body))
  181.  
  182. (define (gentemp) (gensym))
  183.  
  184. (define (slib:eval-load <pathname> evl)
  185.   (if (not (file-exists? <pathname>))
  186.       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  187.   (call-with-input-file <pathname>
  188.     (lambda (port)
  189.       (let ((old-load-pathname *load-pathname*))
  190.     (set! *load-pathname* <pathname>)
  191.     (do ((o (read port) (read port)))
  192.         ((eof-object? o))
  193.       (evl o))
  194.     (set! *load-pathname* old-load-pathname)))))
  195.  
  196. (define slib:warn
  197.   (lambda args
  198.     (let ((cep (current-error-port)))
  199.       (if (provided? 'trace) (print-call-stack cep))
  200.       (display "Warn: " cep)
  201.       (for-each (lambda (x) (display x cep)) args))))
  202.  
  203. (define (slib:error . args)
  204.   (if (provided? 'trace) (print-call-stack (current-error-port)))
  205.   (error 'slib:error "" args))
  206.  
  207. ;; define these as appropriate for your system.
  208. (define slib:tab (integer->char 9))
  209. (define slib:form-feed (integer->char 12))
  210.  
  211. ;;; records
  212. (defmacro define-record forms 
  213.   (let* ((name (car forms))
  214.      (maker-name (symbol-append 'make- name)))
  215.     `(begin
  216.        (define-struct ,name ,@(cadr forms))
  217.        (define ,maker-name ,name))
  218.     ))
  219.  
  220.  
  221. (define (promise:force p) (force p))
  222.  
  223. ;;; (implementation-vicinity) should be defined to be the pathname of
  224. ;;; the directory where any auxillary files to your Scheme
  225. ;;; implementation reside.
  226.  
  227. (define in-vicinity string-append)
  228.  
  229. ;;; Define SLIB:EXIT to be the implementation procedure to exit or
  230. ;;; return if exitting not supported.
  231. (define slib:exit (lambda args (exit 0)))
  232.  
  233. ;;; Here for backward compatability
  234. (define scheme-file-suffix
  235.   (let ((suffix (case (software-type)
  236.           ((NOSVE) "_scm")
  237.           (else ".scm"))))
  238.     (lambda () suffix)))
  239.  
  240. ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
  241. ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
  242.  
  243. (define (slib:load-source f) (loadq (string-append f (scheme-file-suffix))))
  244.  
  245. ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
  246. ;;; by compiling "foo.scm" if this implementation can compile files.
  247. ;;; See feature 'COMPILED.
  248.  
  249. (define slib:load-compiled loadq)
  250.  
  251. ;;; At this point SLIB:LOAD must be able to load SLIB files.
  252.  
  253. (define slib:load slib:load-source)
  254.  
  255. (define defmacro:eval slib:eval)
  256. (define defmacro:load slib:load)
  257.  
  258. ;;; If your implementation provides R4RS macros:
  259. ;(define macro:eval slib:eval)
  260. ;(define macro:load load)
  261.  
  262. (slib:load (in-vicinity (library-vicinity) "require"))
  263. ; eof
  264.