home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / p-utils.pso < prev    next >
Encoding:
Text File  |  1992-02-17  |  5.3 KB  |  146 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2.  
  3. ; This file was generated by Pseudoscheme 2.8a
  4. ;  running in Lucid Common Lisp 4.0.1
  5. ;  from file /amd/night/b/jar/pseudo/p-utils.scm
  6.  
  7. (SCHI:BEGIN-TRANSLATED-FILE)
  8. (DEFUN LAST-PAIR (X) (LAST X))
  9. (SCHI:SET-VALUE-FROM-FUNCTION 'LAST-PAIR
  10.                               'SCHEME::LAST-PAIR)
  11. (DEFUN VECTOR-POSQ
  12.        (THING V)
  13.        (OR (POSITION THING
  14.                      (THE SIMPLE-VECTOR V))
  15.            SCHI:FALSE))
  16. (SCHI:SET-VALUE-FROM-FUNCTION 'VECTOR-POSQ
  17.                               'SCHEME::VECTOR-POSQ)
  18. (DEFUN STRING-POSQ
  19.        (C S)
  20.        (OR (POSITION C
  21.                      (THE SIMPLE-STRING S))
  22.            SCHI:FALSE))
  23. (SCHI:SET-VALUE-FROM-FUNCTION 'STRING-POSQ
  24.                               'SCHEME::STRING-POSQ)
  25. (DEFUN MAKE-FLUID
  26.        (TOP-LEVEL-VALUE)
  27.        (LET ((F (GENSYM "FLUID")))
  28.          (SET F TOP-LEVEL-VALUE)
  29.          F))
  30. (SCHI:SET-VALUE-FROM-FUNCTION 'MAKE-FLUID
  31.                               'SCHEME::MAKE-FLUID)
  32. (DEFUN FLUID (F) (SYMBOL-VALUE F))
  33. (SCHI:SET-VALUE-FROM-FUNCTION 'FLUID 'SCHEME::FLUID)
  34. (DEFUN SET-FLUID! (F VAL) (SET F VAL))
  35. (SCHI:SET-VALUE-FROM-FUNCTION 'SET-FLUID!
  36.                               'SCHEME::SET-FLUID!)
  37. (DEFUN LET-FLUID
  38.        (F VAL THUNK)
  39.        (PROGV (LIST F)
  40.               (LIST VAL)
  41.               (FUNCALL THUNK)))
  42. (SCHI:SET-VALUE-FROM-FUNCTION 'LET-FLUID
  43.                               'SCHEME::LET-FLUID)
  44. (DEFUN MAKE-TABLE
  45.        NIL
  46.        (VALUES (MAKE-HASH-TABLE :SIZE 20 :REHASH-SIZE 2.0)))
  47. (SCHI:SET-VALUE-FROM-FUNCTION 'MAKE-TABLE
  48.                               'SCHEME::MAKE-TABLE)
  49. (DEFUN TABLE-SET!
  50.        (TABLE KEY VAL)
  51.        (SETF (GETHASH KEY TABLE) VAL))
  52. (SCHI:SET-VALUE-FROM-FUNCTION 'TABLE-SET!
  53.                               'SCHEME::TABLE-SET!)
  54. (DEFUN TABLE-REF
  55.        (TABLE KEY)
  56.        (GETHASH KEY TABLE SCHI:FALSE))
  57. (SCHI:SET-VALUE-FROM-FUNCTION 'TABLE-REF
  58.                               'SCHEME::TABLE-REF)
  59. (LOCALLY (DECLARE (SPECIAL .VALUES))
  60.          (SETQ .VALUES #'VALUES))
  61. (SCHI:SET-FUNCTION-FROM-VALUE '.VALUES 'SCHEME::VALUES)
  62. (PROCLAIM '(INLINE SCHEME::WITH-VALUES))
  63. (DEFUN WITH-VALUES
  64.        (THUNK PROC)
  65.        (MULTIPLE-VALUE-CALL PROC (FUNCALL THUNK)))
  66. (SCHI:SET-VALUE-FROM-FUNCTION 'WITH-VALUES
  67.                               'SCHEME::WITH-VALUES)
  68. (LOCALLY (DECLARE (SPECIAL CL-READTABLE))
  69.          (SETQ CL-READTABLE (COPY-READTABLE 'NIL)))
  70. (SCHI:SET-FUNCTION-FROM-VALUE 'CL-READTABLE
  71.                               'SCHEME::CL-READTABLE)
  72. (DEFUN WRITE-PRETTY
  73.        (FORM PORT .PACKAGE)
  74.        (LET (FUNCALL
  75.              (*PACKAGE* .PACKAGE)
  76.              (*PRINT-CASE* :UPCASE)
  77.              (*READTABLE* CL-READTABLE))
  78.          (DECLARE (SPECIAL CL-READTABLE))
  79.          (FORMAT PORT "~&")
  80.          (WRITE FORM
  81.                 :STREAM
  82.                 PORT
  83.                 :PRETTY
  84.                 SCHI:TRUE
  85.                 :LENGTH
  86.                 'NIL
  87.                 :LEVEL
  88.                 'NIL)
  89.          (VALUES)))
  90. (LOCALLY (DECLARE (SPECIAL INTERN-RENAMING-PERHAPS))
  91.          (SETQ INTERN-RENAMING-PERHAPS #'SCHEME-HACKS:INTERN-RENAMING-PERHAPS))
  92. (SCHI:SET-FUNCTION-FROM-VALUE 'INTERN-RENAMING-PERHAPS
  93.                               'SCHEME::INTERN-RENAMING-PERHAPS)
  94. (DEFUN QUALIFIED-SYMBOL?
  95.        (SYM)
  96.        (SCHI:TRUE? (NOT (EQ (SCHEME-HACKS:QUALIFIED-SYMBOL-P SYM)
  97.                             'NIL))))
  98. (SCHI:SET-VALUE-FROM-FUNCTION 'QUALIFIED-SYMBOL?
  99.                               'SCHEME::QUALIFIED-SYMBOL?)
  100. (DEFUN MAKE-PACKAGE-USING
  101.        (ID USE-LIST)
  102.        (LET ((NAME (SYMBOL->STRING ID)))
  103.          (LET ((PROBE (FIND-PACKAGE NAME)))
  104.            (LET ((.PACKAGE
  105.                    (IF (NOT (EQ PROBE 'NIL))
  106.                        (PROGN
  107.                          (MAPC
  108.                            #'(LAMBDA (USE)
  109.                               (IF
  110.                                (NOT
  111.                                 (OR (EQ USE SCHEME-HACKS:LISP-PACKAGE)
  112.                                  (MEMBER USE USE-LIST :TEST #'EQ)))
  113.                                (UNUSE-PACKAGE USE PROBE)))
  114.                            (PACKAGE-USE-LIST PROBE))
  115.                          PROBE)
  116.                        (MAKE-PACKAGE NAME :USE USE-LIST))))
  117.              (USE-PACKAGE
  118.                (IF (EQ ID 'SCHEME::SCHEME)
  119.                    USE-LIST
  120.                    (CONS SCHEME-HACKS:LISP-PACKAGE USE-LIST))
  121.                .PACKAGE)
  122.              .PACKAGE))))
  123. (SCHI:SET-VALUE-FROM-FUNCTION 'MAKE-PACKAGE-USING
  124.                               'SCHEME::MAKE-PACKAGE-USING)
  125. (DEFUN MAKE-PACKAGE-EXPORTING
  126.        (ID SYMS)
  127.        (LET ((NAME (SYMBOL->STRING ID)))
  128.          (LET ((NEW (OR (FIND-PACKAGE NAME)
  129.                         (MAKE-PACKAGE NAME :USE 'NIL))))
  130.            (IMPORT SYMS NEW)
  131.            (EXPORT SYMS NEW)
  132.            NEW)))
  133. (SCHI:SET-VALUE-FROM-FUNCTION 'MAKE-PACKAGE-EXPORTING
  134.                               'SCHEME::MAKE-PACKAGE-EXPORTING)
  135. (LOCALLY (DECLARE (SPECIAL MAKE-PHOTON))
  136.          (SETQ MAKE-PHOTON #'SCHEME-HACKS:MAKE-PHOTON))
  137. (SCHI:SET-FUNCTION-FROM-VALUE 'MAKE-PHOTON
  138.                               'SCHEME::MAKE-PHOTON)
  139. (DEFUN SCHEME-IMPLEMENTATION-VERSION
  140.        NIL
  141.        (STRING-APPEND (LISP-IMPLEMENTATION-TYPE)
  142.                       " "
  143.                       (LISP-IMPLEMENTATION-VERSION)))
  144. (SCHI:SET-VALUE-FROM-FUNCTION 'SCHEME-IMPLEMENTATION-VERSION
  145.                               'SCHEME::SCHEME-IMPLEMENTATION-VERSION)
  146.