HAKERIS 11/HAKERIS 11.ISO/linux/system/LinuxConsole 0.4/linuxconsole0.4install-en.iso/guile0.4.lcm/share/guile/slib/pscheme.init

Text File | 2004-01-06 | 5.9 KB | 205 lines

;;; "pscheme.init" -*-scheme-*-
;;; SLIB init file for Pocket Scheme
;;; SLIB orig Author: Aubrey Jaffer ([e-mail])
;;; Author: Ben Goetter <[e-mail]>
;;; Initial work for 0.2.3 by Robert Goldman ([e-mail])
;;;
;;; This code is in the public domain.

; best fit for Windows CE?
(define (software-type) 'MS-DOS)

(define (scheme-implementation-type) 'PocketScheme)
(define (scheme-implementation-version) "0.3.6")

(define in-vicinity string-append)

(define (implementation-vicinity)
  "\\Program Files\\Pocket Scheme\\")

(define (library-vicinity)
  (in-vicinity (implementation-vicinity) "slib\\"))

(define (home-vicinity)
  "\\My Documents\\")

(define *features*
  '(source
    rev4-report
    ieee-p1178
    rev4-optional-procedures
    multiarg/and-
    multiarg-apply
    with-file
    char-ready?
    defmacro
    delay
    eval
    dynamic-wind
    full-continuation
    ;;trace                ; Comment out for SLIB TRACE macros
    system
    string-port
    ))

;;; (OUTPUT-PORT-WIDTH <port>)
(define (output-port-width . arg) 79)

;;; (OUTPUT-PORT-HEIGHT <port>)
(define (output-port-height . arg) 12)

;;; (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)
  (let ((file #f))
    (with-handlers (((lambda (x) #t) (lambda (x) #f)))
           (set! file (open-input-file f))
           (close-input-port file)
           #t)))

;; pscheme: current-error-port, delete-file, force-output already defined

;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
;;; be returned by CHAR->INTEGER.
;(define char-code-limit
; (with-handlers (
;  ((lambda (x) #t) (lambda (x) 256))
;                )
;  (integer->char 65535)
;  65536))
;;; Currently there are only three clients of this symbol.
;;; Following observations relate to PScheme 0.3.5, JACAL 1a9, SLIB 2c5.
;;; JACAL: crashes when set to 65536.
;;; make-crc: extremely inefficient when set to 65536, spending forever in init
;;; precedence-parse: ignores any setting in excess of 256
;;; So we patch it to 256.
(define char-code-limit 256)

;;; MOST-POSITIVE-FIXNUM is used in modular.scm
;;; This is the most positive immediate-value fixnum in PScheme.
;;; The secondary representation extends fixnum values to 0xffffffff.
(define most-positive-fixnum #x07FFFFFF)

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

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

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

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

(define (defmacro:load <pathname>)
  (slib:eval-load <pathname> defmacro:eval))

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

;;; Define an error procedure for the library
(define (slib:error . k)
  (if (provided? 'trace) (print-call-stack (current-error-port)))
  (error
   (cond
    ((= (length k) 0) '())
    ((= (length k) 1) (car k))
    ((provided? 'string-port)
     (call-with-output-string
      (lambda (out)
    (let ((add-space #f))
      (map
       (lambda (arg)
         (if add-space (write-char #\space out) (set! add-space #t))
         (display arg out))
       k)))))
    (else (car k)))))

;;; For the benefit of slib:error above, as announced by feature string-port
(define (call-with-output-string t)
  (let* ((p (open-output-string))
     (r (t p))
     (s (get-output-string p)))
    (close-output-port p)
    s))

(define (call-with-input-string s t)
  (let* ((p (open-input-string s))
     (r (t p)))
    (close-input-port p)
    r))

;;; 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 SLIB:EXIT to be the implementation procedure to exit or
;;; return if exitting not supported.
(define slib:exit exit)

;;; Here for backward compatability
(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)
  (if (not (file-exists? f))
      (set! f (string-append f (scheme-file-suffix))))
  (load f))

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

;;; Hold onto pscheme native version
(define pscheme:require require)
(slib:load (in-vicinity (library-vicinity) "require"))