home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / rts.lisp < prev    next >
Encoding:
Text File  |  1992-02-12  |  8.8 KB  |  316 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: REVISED^4-SCHEME; -*-
  2. ; File rts.lisp / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Revised^4 Scheme runtime system
  5.  
  6. (in-package "REVISED^4-SCHEME") ;should already exist.
  7.  
  8. (defmacro defune (name bvl &body body)
  9.   (let ((new-name
  10.      (scheme-hacks:intern-renaming-perhaps (symbol-name name)
  11.                            *package*)))
  12.     `(progn #+LispM 'compile
  13.         (defun ,new-name ,bvl ,@body)
  14.         (schi:set-value-from-function ',new-name)
  15.         ',name)))
  16.  
  17. (when (symbolp (symbol-function 'null))    ;Symbolics loses
  18.   (setf (symbol-function 'null)
  19.     (symbol-function (symbol-function 'null))))
  20.  
  21. ; Definitions for CAR and CDR for when they are *not* open-coded.
  22. ; There really ought to be definitions for CDADDR and friends, but the
  23. ; programmer is too lazy to produce them.
  24.  
  25. (defune car (pair)
  26.   (if (not (consp pair))
  27.       (error "Argument to CAR isn't a pair -- ~S" pair)
  28.       (car pair)))
  29.  
  30. (defune cdr (pair)
  31.   (if (not (consp pair))
  32.       (error "Argument to CDR isn't a pair -- ~S" pair)
  33.       (cdr pair)))
  34.  
  35. ; Non-open-coded standard Scheme procedures, in alphabetical order (almost)
  36.  
  37. ; MAKE-PROMISE (auxiliary for DELAY macro)
  38.  
  39. (defstruct (promise (:print-function print-promise)
  40.             (:predicate promisep)
  41.             (:constructor make-promise (thunk-or-value)))
  42.   (forced-yet-p nil)
  43.   thunk-or-value)
  44.  
  45. (defun print-promise (obj stream escapep)
  46.   (declare (ignore escapep))
  47.   (if (promise-forced-yet-p obj)
  48.       (format stream "#{Forced ~S}" (promise-thunk-or-value obj))
  49.       (format stream "#{Delayed}")))
  50.  
  51. ; FORCE
  52.  
  53. (defune force (obj)
  54.   (cond ((promisep obj)
  55.          (let ((tv (promise-thunk-or-value obj)))
  56.            (cond ((promise-forced-yet-p obj) tv)
  57.                  (t (let ((val (funcall tv)))
  58.                       (setf (promise-thunk-or-value obj) val)
  59.                       (setf (promise-forced-yet-p obj) t)
  60.                       val)))))
  61.         (t obj)))
  62.  
  63. ; LIST?
  64.  
  65. (defune list? (l)            ;New in R4RS
  66.   (do ((l l (cddr l))
  67.        (lag l (cdr lag)))
  68.       ((not (consp l)) (schi:true? (null l)))
  69.     (when (not (consp (cdr l)))
  70.       (return (schi:true? (null (cdr l)))))
  71.     (when (eq (cdr l) lag)
  72.       (return schi:false))))
  73.  
  74. ; LOAD -- forward reference to not-yet-existing EVAL module
  75.  
  76. #+DEC (proclaim '(function schi:scheme-load))
  77.  
  78. (defune load (filespec &rest optional-args)
  79.   (apply #'schi:scheme-load filespec optional-args))
  80.  
  81. ; MAKE-STRING
  82.  
  83. (defune make-string (size &optional (fill #\?))
  84.   (cond (fill (make-string size :initial-element fill))
  85.         (t (make-string size))))
  86.  
  87. ; MAKE-VECTOR
  88.  
  89. (defune make-vector (size &optional (fill schi:unspecified))
  90.   (make-sequence 'vector size :initial-element fill))
  91.  
  92. ; NOT
  93.  
  94. (defune not (obj)
  95.   (schi:true? (eq obj schi:false)))
  96.  
  97. ; NUMBER->STRING
  98.  
  99. (defune number->string (num &optional (radix 10))
  100.   (let ((*print-base* (if (equal radix '(scheme::heur))
  101.               10
  102.               radix)))
  103.     (write-to-string num)))
  104.  
  105. ; READ
  106.  
  107. (defune read (&optional (port *standard-input*))
  108.   (read-with-sharpsharp "##" port))
  109.  
  110. (defun read-with-sharpsharp (sharpsharp &optional (port *standard-input*))
  111.   (let ((*package* schi:scheme-package)
  112.     (*readtable* schi:scheme-readtable)
  113.     (scheme-hacks:*sharp-sharp* sharpsharp))
  114.     (read-preserving-whitespace port nil schi:eof-object)))
  115.  
  116. ; READ-CHAR
  117.  
  118. (defune read-char (&optional (port *standard-input*))
  119.   (read-char port nil schi:eof-object))
  120.  
  121. (defune peek-char (&optional (port *standard-input*))
  122.   (peek-char nil port nil schi:eof-object))
  123.  
  124. ; STRING
  125.  
  126. (defune string (&rest chars)
  127.   (coerce chars 'string))
  128.  
  129. ; STRING->NUMBER
  130.  
  131. (defune string->number (string &optional (radix 10))
  132.   (with-input-from-string (s string)
  133.     (let ((n (let ((*read-base* radix))
  134.            (read s nil schi:eof-object))))
  135.       (if (or (not (numberp n))
  136.           (not (eq (read s nil schi:eof-object)
  137.                schi:eof-object)))
  138.       schi:false
  139.       n))))
  140.  
  141. ; STRING-APPEND
  142.  
  143. (defune string-append (&rest strings)
  144.   (apply #'concatenate 'simple-string strings))
  145.  
  146. ; SYMBOL->STRING
  147. ;  The hair here is all to make printers written in Scheme produce
  148. ;  informative output, which wouldn't be the case if symbol->string were
  149. ;  the same is symbol-name.
  150.  
  151. (defune symbol->string (symbol)
  152.   (let ((name (symbol-name symbol))
  153.     (package (symbol-package symbol)))
  154.     (cond ((eq package schi:scheme-package) name)
  155.       ((not (schi:scheme-symbol-p symbol))
  156.        (error "symbol->string: invalid argument - ~S"
  157.           symbol))
  158.       (t (multiple-value-bind (sym-again status)
  159.          (find-symbol name package)
  160.            (declare (ignore sym-again))
  161.            (let ((fakename
  162.               (concatenate 'string
  163.                    (if (keywordp symbol)
  164.                        ""
  165.                        (package-name package))
  166.                    (if (eq status :external)
  167.                        ":"
  168.                        "::")
  169.                    name)))
  170.          (warn "returning ~s for (symbol->string '~s)"
  171.                fakename
  172.                symbol)
  173.          fakename))))))
  174.  
  175. ; VECTOR?
  176.  
  177. (proclaim '(inline vector?))
  178. (defune vector? (obj)
  179.   (schi:true? (and (simple-vector-p obj)
  180.            ;; Structures are vectors in Symbolics, Exploder, and CLISP.
  181.            #+(or tops-20 Lispm)
  182.            (not (typep obj 'lisp::structure))
  183.            ;; Strings are simple vectors in CLISP (this is a bug)
  184.            #+tops-20
  185.            (not (stringp obj)))))
  186.  
  187. ; WRITE
  188. ; Do a real printer some time.
  189. ; It seems sensible to respect *print-pretty*, in any case.
  190.  
  191. (defune write (obj &optional (port *standard-output*))
  192.   (write-internal obj port t))
  193.  
  194. (defune display (obj &optional (port *standard-output*))
  195.   (write-internal obj port nil))
  196.  
  197. (defun write-internal (obj port escapep)
  198.   (let ((*package* schi:scheme-package)
  199.     (*readtable* schi:scheme-readtable))
  200.     (cond ((null obj)
  201.        (princ "()" port))
  202.       ((eq obj schi:false)
  203.        (write-char #\# port)
  204.        ;; Respect *print-case*
  205.        (let ((*package* (symbol-package 'f)))
  206.          (prin1 'f port)))
  207.       ((eq obj schi:true)
  208.        (write-char #\# port)
  209.        ;; Respect *print-case*
  210.        (let ((*package* (symbol-package 't)))
  211.          (prin1 't port)))
  212.       ((and (consp obj)
  213.         (eq (car obj) 'scheme::quote)
  214.         (consp (cdr obj))
  215.         (null (cddr obj)))
  216.        (write-char #\' port)
  217.        (write (cadr obj) :stream port :escape escapep :array t))
  218.       (t
  219.        (write obj :stream port :escape escapep :array t)))
  220.     schi:unspecified))
  221.  
  222. ; CASE-AUX
  223. ;  Usually this should be open-coded, but sometimes it may not be.
  224.  
  225. (defune case-aux (key key-lists else-thunk &rest clause-thunks)
  226.   (do ((ks key-lists (cdr ks))
  227.        (ts clause-thunks (cdr ts)))
  228.       ((null ks) (funcall else-thunk))
  229.     (if (member key (car ks))
  230.     (return (funcall (car ts))))))
  231.  
  232. ; RATIONALIZE - implementation from IEEE Scheme standard
  233.  
  234. (defune rationalize (x e)
  235.   (let ((e (abs e)))
  236.     (simplest-rational (- x e) (+ x e))))
  237.  
  238. (defun simplest-rational (x y)
  239.   (labels ((simplest-rational-internal
  240.         (x y)
  241.         (multiple-value-bind (fx x-fx)
  242.         (floor x)
  243.           (multiple-value-bind (fy y-fy)
  244.           (floor y)
  245.         (if (not (< fx x))
  246.             fx
  247.             (if (= fx fy)
  248.             (+ fx
  249.                (/ 1
  250.                   (simplest-rational-internal
  251.                    (/ 1 y-fy)
  252.                    (/ 1 x-fx))))
  253.             (+ 1 fx)))))))
  254.     (if (not (< x y))
  255.     (if (rationalp x)
  256.         x
  257.         (error "(rationalize <irrational> 0) - ~S" x))
  258.     (if (plusp x)
  259.         (simplest-rational-internal x y)
  260.         (if (minusp y)
  261.         (- 0
  262.            (simplest-rational-internal (- 0 y)
  263.                            (- 0 x)))
  264.         0)))))
  265.  
  266. ; Printer hooks
  267.  
  268. #+DEC
  269. (progn
  270. (system::define-list-print-function scheme::quote (list stream)
  271.   (declare (list list))
  272.   (if (two-element-list-p list)
  273.       (format stream "'~W" (second list))
  274.       (format stream "~1!~@{~W~^ ~:_~}~." list)))
  275.  
  276. (system::define-list-print-function scheme::quasiquote (list stream)
  277.   (declare (list list))
  278.   (if (two-element-list-p list)
  279.       (format stream "`~W" (second list))
  280.       (format stream "~1!~@{~W~^ ~:_~}~." list)))
  281.  
  282. (system::define-list-print-function scheme::unquote (list stream)
  283.   (declare (list list))
  284.   (if (two-element-list-p list)
  285.       ;;+++ Should insert a space for , @FOO
  286.       (format stream ",~W" (second list))
  287.       (format stream "~1!~@{~W~^ ~:_~}~." list)))
  288.  
  289. (system::define-list-print-function scheme::unquote-splicing (list stream)
  290.   (declare (list list))
  291.   (if (two-element-list-p list)
  292.       (format stream ",@~W" (second list))
  293.       (format stream "~1!~@{~W~^ ~:_~}~." list)))
  294.  
  295. (defun two-element-list-p (obj)
  296.   (and (consp obj) (consp (cdr obj)) (null (cddr obj))))
  297. );ngorp
  298.  
  299. #+Symbolics
  300. (progn 'compile
  301. ; This stuff seems to not work!
  302. (zl:defprop scheme::quasiquote grind-quasiquote si:grind-macro)
  303. (defun grind-quasiquote (e loc) loc
  304.   (si:gtyo #.(zl:character (char-code #\`)))
  305.   (si:grind-form (cadr e) (zl:locf (cadr e))))
  306. (zl:defprop scheme::unquote grind-unquote si:grind-macro)
  307. (defun grind-unquote (e loc) loc
  308.   (si:gtyo #.(zl:character (char-code #\,)))
  309.   (si:grind-form (cadr e) (zl:locf (cadr e))))
  310. (zl:defprop scheme::unquote-splicing grind-unquote-splicing si:grind-macro)
  311. (defun grind-unquote-splicing (e loc) loc
  312.   (si:gtyo #.(zl:character (char-code #\,)))
  313.   (si:gtyo #.(zl:character (char-code #\@)))
  314.   (si:grind-form (cadr e) (zl:locf (cadr e))))
  315. );ngorp
  316.