home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / core.lisp < prev    next >
Encoding:
Text File  |  1991-09-09  |  6.3 KB  |  220 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHI; -*-
  2. ; File core.lisp / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Pseudoscheme runtime system
  5.  
  6. (lisp:in-package "SCHEME-INTERNAL")
  7.  
  8. (import '(scheme-hacks:make-photon
  9.       scheme-hacks:qualified-symbol-p
  10.       scheme-hacks:intern-renaming-perhaps
  11.       scheme-hacks:find-symbol-renaming-perhaps
  12.       scheme-hacks:lisp-package))
  13.  
  14. (export '(lisp-package))
  15.  
  16. ; The Scheme booleans
  17. ;   - must be self-evaluating
  18. ;   - can't be structures, because they will appear as constants in
  19. ;     compiled files
  20. ;   - must be uniquely created
  21. ;   - can't be symbols without slowing down Scheme's SYMBOL? predicate
  22. ;   - simlarly for numbers, pairs, etc.
  23. ; What values are self-evaluating Common Lisp objects with a read/print
  24. ; syntax that aren't used for anything in Scheme?  ...
  25. ; There aren't any.
  26.  
  27. (defvar false 'false)  ;You can set this to 'nil if you want
  28. (defvar true  't)
  29.  
  30. (proclaim '(inline truep true? scheme-symbol-p))
  31.  
  32. ; Convert Scheme boolean to Lisp boolean.
  33. ;  E.g. (lisp:if (truep foo) ...)
  34.  
  35. (defun truep (scheme-test)
  36.   (not (eq scheme-test false)))
  37.  
  38. ; Convert Lisp boolean to Scheme boolean.
  39. ;  E.g. (cons (true? (lisp:numberp x)) ...)
  40. ; This assumes that the argument is never the empty list.
  41.  
  42. (defun true? (cl-test) (or cl-test false))
  43.  
  44. (defun scheme-symbol-p (x)
  45.   (declare (optimize (safety 0)))    ;compilers are stupid
  46.   (and (symbolp x) (not (eq (car (symbol-plist x)) 'not-a-symbol))))
  47.  
  48. (setf (get true  'not-a-symbol) t)
  49. (setf (get false 'not-a-symbol) t)
  50. (setf (get nil   'not-a-symbol) t)    ;used for Scheme's empty list
  51.  
  52. ;
  53.  
  54. (defvar scheme-package scheme-hacks:scheme-package)
  55. (defvar scheme-readtable scheme-hacks:scheme-readtable)
  56.  
  57. ; Miscellaneous objects
  58.  
  59. (defvar unspecified (make-photon "#{Unspecified}"))
  60. (defvar unassigned  (make-photon "#{Unassigned}"))
  61.  
  62. (defvar eof-object
  63.   (if (find-package "PSEUDOSCHEME")
  64.       ;; Temporary hack for coexistence with old versions of Pseudoscheme!
  65.       (intern "EOF-OBJECT" (find-package "PSEUDOSCHEME"))
  66.       (make-photon "#{end-of-file}")))
  67.  
  68. ; PROCEDURE?
  69.  
  70. (defparameter closures-might-be-conses-p
  71.   #+Lucid nil  ;suppress message about compiler optimizations
  72.   #-Lucid
  73.   (or (consp (eval '#'(lambda (x) x)))    ;VAX LISP 2.1
  74.       (consp (let ((g (gensym)))
  75.            (eval `(progn (defun ,g () 0) #',g)))) ;Symbolics
  76.       (consp (compile nil '(lambda (x) x))) ;just for kicks
  77.       (consp (funcall (compile nil '(lambda (x) ;VAX LISP 2.2
  78.                       #'(lambda () (prog1 x (incf x)))))
  79.               0))))
  80.  
  81. (defun procedurep (obj)
  82.   (and (functionp obj)
  83.        (not (symbolp obj))
  84.        (or (not (consp obj))
  85.        closures-might-be-conses-p)))
  86.  
  87. ; Mumble
  88.  
  89. (proclaim '(inline booleanp char-whitespace-p output-port-p))
  90.  
  91. (defun booleanp (obj)
  92.   (or (eq obj schi:true)
  93.       (eq obj schi:false)))
  94.  
  95. (defun char-whitespace-p (char)
  96.   (or (char= char #\space)
  97.       (not (graphic-char-p char))))
  98.  
  99. (defun input-port-p (obj)
  100.   (and (streamp obj)
  101.        (input-stream-p obj)))
  102.  
  103. (defun output-port-p (obj)
  104.   (and (streamp obj)
  105.        (input-stream-p obj)))
  106.  
  107. ;This function is new in CLtL II / ANSI.
  108. (defun realp (obj)
  109.   (and (numberp obj)
  110.        (not (complexp obj))))
  111.  
  112. ; Auxiliary for SET!
  113.  
  114. (defun set!-aux (name value CL-sym)
  115.   (case (get CL-sym 'defined)
  116.     ((:assignable))
  117.     ((:not-assignable)
  118.      (cerror "Assign it anyhow"
  119.          "Variable ~S isn't supposed to be SET!"
  120.          (or name CL-sym)))
  121.     ((nil)
  122.      (unless (qualified-symbol-p name)   ;(set! foo:bar ...)
  123.        (warn "SET! of undefined variable ~S" (or name CL-sym)))))
  124.   (setf (symbol-value CL-sym) value)
  125.   (if (procedurep value)
  126.       (setf (symbol-function CL-sym) value)
  127.       (fmakunbound CL-sym))
  128.   unspecified)
  129.  
  130. ; Auxiliary for lambda-expression-containing top-level forms on Symbolics
  131.  
  132. (defmacro at-top-level (&rest forms)
  133.   (if (member :lispm *features*)
  134.       (let ((g (gentemp "[TOP]")));;!?!?
  135.     `(progn (defun ,g () ,@forms)
  136.         (prog1 (,g)
  137.           (fmakunbound ',g))))
  138.       `(progn ,@forms)))
  139.  
  140. (defvar *translated-file-type* (preferred-case "PSO"))
  141.  
  142. ; Prelude on all translated files
  143.  
  144. (defvar *target-package* nil)        ;bound by scheme-load
  145.  
  146. (defparameter cl-readtable (copy-readtable nil))
  147.  
  148. (Defmacro begin-translated-file ()
  149.   `(progn (in-package (package-name *target-package*))
  150.       (eval-when (eval compile load)
  151.         (setq *readtable* cl-readtable))))
  152.  
  153. ; Auxiliaries for top-level DEFINE
  154.  
  155. (defun set-value-from-function (CL-sym &optional name) ;Follows a DEFUN
  156.   (setf (symbol-value CL-sym) (symbol-function CL-sym))
  157.   (after-define CL-sym name))
  158.  
  159. (defun really-set-function (CL-sym value)
  160.   (cond ((procedurep value)
  161.      #+Lucid
  162.      (lcl:define-function CL-sym value)
  163.      #-Lucid
  164.      (setf (symbol-function CL-sym) value))
  165.     (t
  166.      (fmakunbound CL-sym))))
  167.  
  168. (defun set-function-from-value (CL-sym &optional name) ;Follows a SETQ
  169.   (let ((value (symbol-value CL-sym)))
  170.     (really-set-function CL-sym value)
  171.     #+Symbolics
  172.     (scl:record-source-file-name CL-sym (if (procedurep value) 'defun 'defvar))
  173.     (after-define CL-sym name)))
  174.  
  175. ; Follows (SETQ *FOO* ...)
  176.  
  177. (defun set-forwarding-function (CL-sym &optional name)
  178.   (setf (symbol-function CL-sym)
  179.     #'(lambda (&rest args)
  180.         (apply (symbol-value CL-sym) args)))
  181.   (after-define CL-sym name))
  182.  
  183. (defun after-define (CL-sym name)
  184.   (setf (get CL-sym 'defined) t)
  185.   (when name
  186.     (make-photon #'(lambda (port)
  187.              (let ((*package* scheme-package))
  188.                (format port "~S defined." name))))))
  189.  
  190. ; EQUAL?
  191.  
  192. ; Differs from Common Lisp EQUAL in that it descends into vectors.
  193. ; This is here instead of in rts.lisp because it's an auxiliary for
  194. ; open-coding MEMBER and ASSOC, and the rule is that all auxiliaries
  195. ; are in the SCHI package (not REVISED^4-SCHEME).
  196.  
  197. (defun scheme-equal-p (obj1 obj2)
  198.   (cond ((eql obj1 obj2) t)
  199.         ((consp obj1)            ;pair?
  200.          (and (consp obj2)
  201.           (scheme-equal-p (car obj1) (car obj2))
  202.           (scheme-equal-p (cdr obj1) (cdr obj2))))
  203.     ((simple-string-p obj1)        ;string?
  204.      (and (simple-string-p obj2)
  205.           (string= (the simple-string obj1)
  206.                (the simple-string obj2))))
  207.     ((simple-vector-p obj1)
  208.      (and (simple-vector-p obj2)
  209.           (let ((z (length (the simple-vector obj1))))
  210.         (declare (fixnum z))
  211.         (and (= z (length (the simple-vector obj2)))
  212.              (do ((i 0 (+ i 1)))
  213.              ((= i z) t)
  214.                (declare (fixnum i))
  215.                (when (not (scheme-equal-p
  216.                    (aref (the simple-vector obj1) i)
  217.                    (aref (the simple-vector obj2) i)))
  218.              (return nil)))))))
  219.         (t nil)))
  220.