home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / p-utils.scm < prev    next >
Encoding:
Text File  |  1991-06-21  |  3.3 KB  |  130 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; File utils.scm / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Miscellaneous general and not-so-general utilities
  5.  
  6. ; last-pair (was in r^3, flushed for r^4)
  7.  
  8. (define (last-pair x)
  9.   (lisp:last x))
  10.  
  11. ; posq
  12.  
  13. (define (vector-posq thing v)
  14.   (lisp:or (lisp:position thing (lisp:the lisp:simple-vector v))
  15.        #f))
  16.  
  17. (define (string-posq c s)
  18.   (lisp:or (lisp:position c (lisp:the lisp:simple-string s))
  19.        #f))
  20.  
  21. ; Fluids
  22.  
  23. (define (make-fluid top-level-value)
  24.   (let ((f (lisp:gensym "FLUID")))
  25.     (lisp:set f top-level-value)
  26.     f))
  27.  
  28. (define (fluid f)
  29.   (lisp:symbol-value f))
  30.  
  31. (define (set-fluid! f val)
  32.   (lisp:set f val))
  33.  
  34. (define (let-fluid f val thunk)
  35.   (lisp:progv (list f) (list val) (thunk)))
  36.  
  37. ; Tables
  38.  
  39. (define (make-table)
  40.   ;; Default size in VAX LISP is 71, which seems rather large.
  41.   (lisp:values (lisp:make-hash-table :size 20 :rehash-size 2.0)))
  42.  
  43. (define (table-set! table key val)
  44.   (lisp:setf (lisp:gethash key table) val))
  45.  
  46. (define (table-ref table key)
  47.   (lisp:gethash key table #f))
  48.  
  49. ; Multiple values
  50.  
  51. (define values #'lisp:values)
  52.  
  53. (lisp:proclaim '(lisp:inline with-values))
  54.  
  55. (define (with-values thunk proc)
  56.   (lisp:multiple-value-call proc (thunk)))
  57.  
  58. ; Pretty-printer used by translator
  59. ; Two cases:
  60. ;  - If package is scheme-package, then unqualified symbols must print
  61. ;    without package prefixes, and qualified ones must print with.
  62. ;  - Otherwise, the opposite, and the package prefix for unqualified
  63. ;    symbols ought to be 
  64.  
  65. (define cl-readtable (lisp:copy-readtable 'lisp:nil))
  66.  
  67. (lisp:defun write-pretty (form port package)
  68.   (lisp:let ((lisp:*package* package)
  69.          (lisp:*print-case* :upcase)
  70.          (lisp:*readtable* cl-readtable))
  71.     (lisp:declare (lisp:special cl-readtable))
  72.     (lisp:format port "~&")
  73.     (lisp:write form :stream port
  74.              :pretty lisp:t
  75.              :length 'lisp:nil
  76.              :level 'lisp:nil)
  77.     (lisp:values)))
  78.  
  79. ; Package stuff, etc.
  80.  
  81. ; These things are needed by the runtime system, too, BEFORE the
  82. ; translator can be loaded.  Maybe the code should just be replicated?
  83.  
  84. (define intern-renaming-perhaps #'scheme-hacks:intern-renaming-perhaps)
  85.  
  86. (define (qualified-symbol? sym)
  87.   (not (eq? (scheme-hacks:qualified-symbol-p sym) 'lisp:nil)))
  88.  
  89. (define (make-package-using id use-list)
  90.   (let* ((name (symbol->string id))
  91.      (probe (lisp:find-package name))
  92.      (package
  93.       (cond ((not (eq? probe 'lisp:nil))
  94.              (for-each (lambda (use)
  95.                  (if (not (or (eq? use scheme-hacks::lisp-package)
  96.                       (memq use use-list)))
  97.                  (lisp:unuse-package use probe)))
  98.                (lisp:package-use-list probe))
  99.          probe)
  100.         (else (lisp:make-package name :use use-list)))))
  101.     (lisp:use-package (if (eq? id 'scheme)
  102.               use-list    ;Kludge
  103.               (cons scheme-hacks:lisp-package use-list))
  104.               package)
  105.     package))
  106.  
  107. (define (make-package-exporting id syms)
  108.   (let* ((name (symbol->string id))
  109.      (new (lisp:or (lisp:find-package name)
  110.                (lisp:make-package name :use '()))))
  111.     (lisp:import syms new)
  112.     (lisp:export syms new)
  113.     new))
  114.  
  115.  
  116. ; lisp:namestring
  117. ; lisp:truename
  118. ; lisp:merge-pathnames
  119. ; lisp:make-pathname
  120. ; lisp:package-name
  121.  
  122. ; Etc.
  123.  
  124. (define make-photon #'scheme-hacks:make-photon)
  125.  
  126. (define (scheme-implementation-version)
  127.   (string-append (lisp:lisp-implementation-type)
  128.          " "
  129.          (lisp:lisp-implementation-version)))
  130.