;;;-*- Mode:Common-Lisp; Package:SI; Base:10; Fonts:(CPTFONT HL12 HL12BI CPTFONTB) -*-

;;; Copyright (C) 1987,1988 Texas Instruments Incorporated. All rights reserved.

Ï2;;;       PC Scheme compatibility supportÏ*

;; 11/14/87 DNG - Added Ï3delete!Ï*, Ï3delq!Ï*, Ï3port?Ï*, Ï3window?Ï*, and Ï1print-lengthÏ*.
;; 11/16/87 DNG - Improved Ï3print-length.Ï*
;; 11/19/87 DNG - New definition of Ï3eqv?Ï* to support comparing strings.
;; 11/21/87 DNG - Added support for streams and substrings, Ï3reverse!Ï*, 
;;		Ï3file-exists?Ï*, Ï3add1Ï*, Ï3sub1Ï*, Ï3read-lineÏ*, Ï3string-null?Ï*,
;;		Ï3fresh-lineÏ*, Ï3minusÏ*, Ï3float?Ï*, and Ï3randomÏ*.
;;		New definition of Ï3memvÏ* to match the changes to Ï3eqv?Ï*.
;;		Fixed Ï3%cl-functionÏ* to work for TV: functions.
;; 11/30/87 DNG - Added Ï3delayed-object?Ï* .
;; 12/01/87 DNG - Faster versions of Ï3substring-find-next-char-in-setÏ* and 
;;		Ï3substring-find-next-char-in-setÏ* .
;; 12/02/87 DNG - Fixed definition of Ï3string-null?Ï* to be in right package.
;;		Added Ï3open-extend-fileÏ* and Ï3open-input-stringÏ* .
;;		Changed Ï3pcs-machine-typeÏ* from 0 to 1.
;; 12/05/87 DNG - Fixed Ï3named-lambdaÏ* to locally define the function name.
;;		Added Ï3%logiorÏ*, Ï3%logandÏ*, Ï3%setfÏ*, and Ï3%dont-optimizeÏ*.
;; 12/12/87 DNG - Use new special form WITH-SCHEME-SEMANTICS to control the 
;;		mode of the compiler and evaluator.
;; 12/14/87 DNG - Modified Ï3define-integrableÏ* to not try to compile the function.
;; 12/21/87 DNG - Added Ï3freezeÏ* and Ï3thawÏ*.
;; 12/23/87 DNG - Added Ï3flush-inputÏ*, Ï3input-portÏ*, Ï3output-portÏ*, Ï3scheme-resetÏ*, 
;;		Ï3integer->stringÏ*, Ï3get-file-positionÏ*, Ï3set-file-position!Ï*,
;;		Ï3randomizeÏ*, Ï3dos-chdirÏ*, and Ï3ascii->symbolÏ*.
;;		Fixed Ï3float?Ï* and Ï3open-input-stringÏ* to be in the right package.
;; 12/28/87 DNG - Fixed Ï3randomizeÏ* for floating point zero.
;;  1/09/88 DNG - Fixed Ï3define-integrableÏ*, Ï3reset-scheme-top-levelÏ*, and Ï3writelnÏ*.
;;		Added Ï3read-atomÏ*, Ï3explodeÏ*, Ï3list*Ï*, and Ï3floatÏ* .
;;  1/16/88 DNG - Fix Ï3read-atomÏ* to handle [ ] { } as special tokens. 
;;		Add Ï3apply-ifÏ*.  Modify Ï1whenÏ* to return the same value as in PC Scheme.
;;  1/29/88 DNG - Fix Ï3substring<?Ï* and Ï3substring-ci<?Ï* to return T instead of 
;;		a number.  Extend Ï3read-atomÏ* to handle period.
;;  1/30/88 DNG - Fix Ï3line-lengthÏ* to use :inside-width instead of :width, and 
;;		to default to 80 instead of 0.
;;  2/12/88 DNG - Fix Ï3flush-inputÏ* to stop at end of line instead of end of file.
;;		Added Ï3implodeÏ*.
Ï1;;  2/18/88 DNG - Implemented Ï3set-line-length!Ï* to really do something, and 
;;Ï*		Ï1updated Ï3line-lengthÏ* to return the value set.  Added
;;Ï*		(:method basic-buffered-output-stream :read-cursorpos)Ï1.
;;  2/20/88 DNG - Moved some compiler optimizers to the new file Ï*"optimizers"Ï1.
;;Ï*		Ï1Fixed Ï3port?Ï* to work on a dynamic closure.
;;  2/23/88 DNG - Fix Ï3memvÏ* to not call itself.
;;  3/09/88 DNG - Redefined Ï3runtimeÏ* to be relative to today instead of last boot.
;;Ï*		Ï1Fix Ï3print-lengthÏ* for dotted lists.
;;  3/21/88 DNG - New definition of Ï3gensymÏ* .
;;  3/25/88 DNG - Added Ï3assertÏ*, Ï3dos-file-sizeÏ*, and Ï3piÏ* .
;;  4/07/88 DNG - Add recognition of Ï*|,.|Ï1 to Ï*read-atomÏ1 .
;;  4/11/88 DNG - Add check to Ï3define-integrableÏ* to report error if symbol is 
;;Ï*		Ï1defined to itself.  
;;  4/13/88 DNG - Added Ï3open-binary-input-fileÏ* and Ï3open-binary-output-fileÏ* .
;;  4/21/88 DNG - Fixed so Ï*current-columnÏ1 will work on microExplorer.
;;  5/19/88 DNG - Updated Ï*print,Ï1 Ï*pp,Ï1 and Ï*print-lengthÏ1 to use Scheme syntax and 
;;Ï*		Ï1so that Ï*ppÏ1 observes its width argument.
;;  9/03/88 DNG - Modified Ï*printÏ1 and Ï*ppÏ1 to reference Ï*scheme-readtableÏ1 instead of Ï**readtable*Ï1.
;;  1/27/89 DNG - Enhanced the default sort predicate to handle lists better.
;;  2/25/89 DNG - Fixed Ï3read-atomÏ*Ï* Ï1to pass the port argument to Ï*unread-charÏ1.Ï*

(export '(scheme:named-lambda) scheme-package)
(defmacro scheme:named-lambda (form &body body)
  (let* ((variable (first form)))
    `(scheme:letrec ((,variable (scheme-lambda-with-name ,form . ,body)))
       ,variable)))

(export '(scheme:compile-file scheme:compile scheme:eval) scheme-package)
;; Ï3compile-fileÏ* and Ï3compileÏ* have been moved to file "optimize" in order to not 
;; be included in the Scheme runtime-only system.

(defmacro def-alias-function (name-being-defined same-as-name)
  `(progn (deff ,name-being-defined ',same-as-name)
	  (compiler:add-optimizer ,name-being-defined compiler:substitute-function-name ,same-as-name)
	  ',name-being-defined))

(export '( scheme:environment? scheme:user-initial-environment
	  scheme:user-global-environment) scheme-package)
;; We don't really support environments as first-class objects in this 
;; implementation, but try to permit trivial references to the global envirionment.
(defflavor environment () () )
(def-global-scheme-variable scheme:user-initial-environment (make-instance 'environment))
(def-global-scheme-variable scheme:user-global-environment (make-instance 'environment))
(defsubst scheme:environment? (object)
  "Is the argument an environment object?"
  (typep object 'environment))

(defun scheme:eval (expression &optional (environment nil envp))
  "Evaluate a Scheme expression."
  (declare (arglist expression &optional environment))
  (when (and envp (not (scheme:environment? environment)))
    (cerror "Proceed using the USER-INITIAL-ENVIRONMENT."
	    "The second argument to ~S, ~S, is not an environment object." 'scheme:eval environment))
  (with-scheme-on
    (LET ((SI:*INTERPRETER-ENVIRONMENT* nil)
	  (SI:*INTERPRETER-FUNCTION-ENVIRONMENT* nil))
      (SYS:*EVAL expression))))

(export '(scheme:define-integrable) scheme-package)
(defmacro scheme:define-integrable (&whole form name expression)
  (declare (arglist name value))
  "Define NAME to be replaced by the VALUE expression wherever it appears."
  (check-type name symbol)
  (cond 
     #| ; removed 1/9/88 - wrong if going to be used as a variable instead of a function.
        ((symbolp expression) `(scheme:alias ,name ,expression))
     |#
	((constantp expression) `(defconstant ,name ,expression))
     #|    ; removed 12/14/87; this is the way I thought it should work, but not what PC Scheme actually does.
	((member (car expression) '(scheme:lambda scheme-lambda-with-name lisp:function) :test #'eq)
	 `(progn (proclaim '(inline ,name))
		 (scheme:define ,name ,expression)))
     |#
        ((eq name expression)
	 (error "Circular definition: ~S" form))
	(t `(define-integrable-1 ',name ',expression)) ))

(defun define-integrable-1 (name expression)
  (when (sys:record-source-file-name name 'defun)
    (setf (get name 'compiler:INTEGRABLE) expression) ; used in COMPILER:P1
    (fmakunbound name)
    (remprop name 'inline)
    name))


;;;  --  I/O  --

(unintern 'lisp:print scheme-package)Ï1 ; temporary to undo old definitionÏ*
(export '(scheme:print scheme:princ scheme:prin1 scheme:writeln scheme:fresh-line 
	  scheme:read-line scheme:read-atom scheme:pp scheme:flush-input) si:scheme-package)

(defun scheme:Ï3printÏ* (object &optional (port (scheme:current-output-port)))
  "Print OBJECT on PORT with quoting if needed, with a Newline before and a Space after."
  (send port :tyo #\newline)
  (let ((*print-escape* t)
	(character-attribute-table (character-attribute-table scheme-readtable)))
    (print-scheme-object object 0 port)
    (send port :tyo #\space))
  unspecified)

(def-alias-function scheme:Ï3princÏ* scheme:display)
(def-alias-function scheme:Ï3prin1Ï* scheme:write)

(defun scheme:Ï3writelnÏ* (&rest objects)
  (dolist (object objects)
    (scheme:display object))
  (scheme:newline))

(defun scheme:Ï3ppÏ* (object &optional (port (scheme:current-output-port)) (width nil))
  Ï1"Pretty-print"Ï*
  (declare (arglist object &optional port width))
  (let ((*print-pretty* t)
	(*print-escape* t)
	(character-attribute-table (character-attribute-table scheme-readtable))
	(*standard-output* port)
	(pp-line-length (1- (or width (scheme:line-length port)))))
    (fresh-line port)
    (bind '#,(locf #'sys:print-object) #'print-scheme-object)
    (output-pretty-object object)
    (write-char #\space))
  (values))

(defsubst scheme:Ï3fresh-lineÏ* () (lisp:fresh-line) unspecified)

(defun scheme:Ï3flush-inputÏ* (&optional (port (scheme:current-input-port)))
  "Discard any characters in the input buffer up to and including the next end-of-line."
  (loop while (send port :listen)
	do (let ((x (send port :tyi)))
	     (when (or (null x)
		       (eql x (char-int #\newline)))
	       (return))))
  unspecified)

(proclaim '(inline scheme:read-line))
(defun scheme:Ï3read-lineÏ* (&optional (port (scheme:current-input-port)))
  (lisp:read-line port nil the-eof-object))

(export 'scheme:( |(| |)| |,| |'| |`| |,@| |,.| |#(| |[| |]| |{| |}| |.|) ; used by READ-ATOM
	 scheme-package)
(defun scheme:Ï3read-atomÏ* (&optional (port (scheme:current-input-port)))
  (read-atom-internal port *package*))
(compiler:add-optimizer scheme:read-atom read-atom-opt)
(defun read-atom-opt (form)
  ;; Read into the same package the program was compiled in.
  `(read-atom-internal ,(if (rest form) (second form) '*standard-input*)
			 ',*package*))
(defun read-atom-internal (port pkg)
  (let (char)
    (loop do (setq char (scheme:read-char port))
	  while (scheme:char-whitespace? char))
    (cond ((scheme:eof-object? char)
	   char)
	  ((member char '(#\( #\) #\' #\` #\[ #\] #\{ #\} ))
	   (list (intern (string char) scheme-package)))
	  ((member char '(#\, #\# #\.))
	   (let ((next (scheme:read-char port)))
	     (cond ((scheme:eof-object? next)
		    (list (intern (string char) scheme-package)))
		   ((eql char #\#)
		    (if (eql next #\()
			'( scheme:|#(| )
		      (progn (unread-char next port)
			     (unread-char char port)
			     (scheme-read-internal port pkg))))
		   ((eql char #\.)
		    (if (digit-char-p next *read-base*)
			(progn (unread-char next port)
			       (unread-char char port)
			       (scheme-read-internal port pkg))
		      (progn (unread-char next port)
			     '( scheme:|.| ))))
		   ((eql next #\@)
		    '( scheme:|,@| ))
		   ((eql next #\.)
		    '( scheme:|,.| ))
		   (t (unread-char next port)
		      '( scheme:|,| )))))
	  (t (unread-char char port)
	     (scheme-read-internal port pkg)))))

(export '( scheme:standard-input scheme:standard-output
	  scheme:input-port scheme:output-port) scheme-package)
(def-global-scheme-variable scheme:Ï3standard-inputÏ* si:SYN-TERMINAL-IO)
(def-global-scheme-variable scheme:Ï3standard-outputÏ* si:SYN-TERMINAL-IO)
(def scheme:input-port
  (forward-value-cell 'scheme:Ï3input-portÏ* '*standard-input*)
  (setf (documentation 'scheme:input-port 'variable)
	"Fluid variable whose value is the current default input port."))
(def scheme:output-port
  (forward-value-cell 'scheme:Ï3output-portÏ* '*standard-output*)
  (setf (documentation 'scheme:output-port 'variable)
	"Fluid variable whose value is the current default output port."))

(export '(scheme:fast-load) scheme-package)
(deff scheme:Ï3fast-loadÏ* 'scheme:load)

(export '(scheme:line-length scheme:set-line-length! scheme:current-column) scheme-package)
(defvar line-length-plist '()) ; plist of windows and line lengths
(defun scheme:Ï3line-lengthÏ* (&optional (port (scheme:current-output-port)))
  "How many characters per line can be written to this port?"
  (cond
    ;; First, see if SET-LINE-LENGTH! has specified a value.
    ((send port :send-if-handles :get 'scheme:line-length)) 
    ((and line-length-plist
	  (getf line-length-plist (if (symbolp port) (symbol-function port) port) nil)))
    ;; If the port is a window, find how wide it is.
    ((send port :operation-handled-p :inside-width)
     (values (truncate (send port :inside-width)
		       (or (send port :send-if-handles :char-width)
			   (tv:font-char-width (or (send port :send-if-handles :current-font)
						   fonts:cptfont))))))
    ;; Else don't know, arbitrarily return 80 since that's what PC Scheme does for a file port.
    (t 80)))

(defun scheme:Ï3set-line-length!Ï* (number &optional (port (scheme:current-output-port)))
  (check-type number (integer 0))
  (cond ((send port :operation-handled-p :putprop) ; file ports can handle this
	 (send port :putprop number 'scheme:line-length))
	((eql number (scheme:line-length port))) ; if same as default, don't do anything
	;; For a window, save the value in a global variable.
	(t (setf (getf line-length-plist (if (symbolp port) (symbol-function port) port))
		 number)
	   (pushnew '(setq line-length-plist nil) SYS:LOGOUT-LIST :test #'equal)
	   ))
  unspecified)

(defun scheme:Ï3current-columnÏ* (&optional (port (scheme:current-output-port)))
  (1+ (send port :read-cursorpos :character)))

(unless (or (not (type-specifier-p 'SYS:BASIC-BUFFERED-OUTPUT-STREAM))
	    (fdefinedp '(:method SYS:BASIC-BUFFERED-OUTPUT-STREAM :INCREMENT-CURSORPOS)))
Ï1  ;; Until SPR 5952 is fixed, this method is added so that file output ports 
  ;; can support the Ï*scheme:current-columnÏ1 function. 
  ;; This version is not perfect because it will return too small a value if 
  ;; invoked between writing out the buffer and the next end of line.
  ;;   -- D.N.G. 2/18/88Ï*
  (DEFMETHOD (SYS:BASIC-BUFFERED-OUTPUT-STREAM :READ-CURSORPOS) (&OPTIONAL UNITS)
    (UNLESS (EQ UNITS ':CHARACTER)
      (ERROR "UNITS is ~S; only ~S is meaningful here." UNITS ':CHARACTER))
    (IF (NULL STREAM-OUTPUT-BUFFER)Ï1 ; haven't started writing yetÏ*
	(VALUES 0 0)
      (LET ((NX (POSITION #\NEWLINE (THE STRING STREAM-OUTPUT-BUFFER)
			  :END STREAM-OUTPUT-INDEX :FROM-END T)))
	(VALUES (IF (NULL NX)
		    STREAM-OUTPUT-INDEX Ï1; at least this much, but could be more.Ï*
		  (- STREAM-OUTPUT-INDEX NX 1))
		0))))
  )

(export '(scheme:print-length) scheme-package)
(defun scheme:Ï3print-lengthÏ* (object)
  "Return the number of characters needed to DISPLAY the OBJECT."
  (typecase object
    (string (length object))
    (character 1)
    (symbol (cond ((eq object 'nil) 2) ; ()
		  ((eq object 't) 2) ; #T
		  (t (length (symbol-name object)))))
    (cons (let ((count 1))
	    (do ((tail object (cdr tail)))
		((atom tail)
		 (unless (null tail) ; dotted list
		   (setf count (+ count (scheme:print-length tail) 3))))
	      (setf count (+ count (scheme:print-length (car tail)) 1)))
	    count))
    (t (length (princ-to-string object))) ; %%% this is gross, needs to be made more efficient.  %%%
    ))

(export '(scheme:get-file-position scheme:set-file-position!) scheme-package)
(defsubst scheme:Ï3get-file-positionÏ* (port)
  (file-position port))
(defun scheme:Ï3set-file-position!Ï* (port num-bytes location)
  (file-position port (ecase location
			(0 num-bytes) ; from beginning
			(1 (+ (file-position port) num-bytes)) ; from current position
			(2 (- (file-length port) num-bytes)) ; from end
			))
  unspecified)

(export '(scheme:port?) scheme-package)
(proclaim '(compiler:try-inline scheme:port?))
(defun scheme:Ï3port?Ï* (object)
  ;; Don't just call STREAMP because ports should be a disjoint type from Scheme procedures.
  (and (case (%data-type object)
	 ((#.dtp-instance #.dtp-closure) (streamp object))
	 ((#.dtp-symbol) (get object 'si:io-stream-p))
	 (otherwise nil))
       t))

;; note: scheme:window? has been moved to the "windows" file.

(export '(scheme:file-exists?) scheme-package)
(defun scheme:Ï3file-exists?Ï* (filespec) (and (probe-file filespec) t))

(export '(scheme:open-extend-file scheme:open-input-string) scheme-package)
(defun scheme:Ï3open-extend-fileÏ* (filename)
  (open filename :direction :output :if-exists :append))

(defsubst scheme:Ï3open-input-stringÏ* (string) (make-string-input-stream string))

(export '(scheme:open-binary-input-file scheme:open-binary-output-file) 
	scheme-package)
Ï1;; On MS/DOS, a binary file does not have conversion of the line separator 
;; representation.  On the Lisp Machine file system, it doesn't really make 
;; any difference, but the following code will do the right thing 
;; for accessing raw data files on different hosts Ï*[Ï1such as UnixÏ*]Ï1 without 
;; doing any character code translation Ï*[Ï1such as converting Ï*#\newlineÏ1 (#x8D) to 
;; an ASCII line feed (#x0A)].Ï*
(defun scheme:Ï3open-binary-input-fileÏ* (filename)
  Ï1"Open a file for reading raw data without any character code translation."Ï*
  (open filename :direction :input :byte-size 8 :characters nil))
(defun scheme:Ï3open-binary-output-fileÏ* (filename)
  Ï1"Open a file for writing raw data without any character code translation."Ï*
  (open filename :direction :output :byte-size 8 :characters nil))


;;;  --  Symbols  --

(export '(global:putprop scheme:getprop remprop scheme:proplist) scheme-package)
(defsubst scheme:getprop (symbol property) (get symbol property))
(defsubst scheme:proplist (symbol) (symbol-plist symbol))

(export '(scheme:string->uninterned-symbol) scheme-package)
(defsubst scheme:string->uninterned-symbol (string) (make-symbol string))

(export '(scheme:symbol->ascii scheme:ascii->symbol) scheme-package)
(defun scheme:symbol->ascii (symbol)
  "Returns the ASCII code of the first character of the symbol's name."
  (char-int (char (symbol-name symbol) 0)))

(defun scheme:ascii->symbol (n)
  (string->symbol-internal (string (int-char n)) scheme-user-package))
(compiler:add-optimizer scheme:ascii->symbol ascii-symbol-opt)
(defun ascii-symbol-opt (form)
  `(string->symbol-internal (string (int-char ,(second form))) ',*package*))

(export '(scheme:rec) scheme-package)
(defmacro scheme:rec (variable expression)
  `(scheme:letrec ((,variable ,expression))
     ,variable))

(export '(scheme:unbound?) scheme-package)
(defmacro scheme:unbound? (symbol)
  `(not (or (variable-boundp ,symbol)
	    (fboundp ',symbol))))
Ï1;; See optimizer for Ï*unbound?Ï1 in file Ï*"optimize"Ï1.Ï*

(eval-when (eval compile load)Ï1 ; temporary patch 3/21/88Ï*
  (when (eq 'scheme:gensym 'lisp:gensym)
    (unintern 'LISP:GENSYM "SCHEME")))
(export '(scheme:gensym) scheme-package)
;; Note: if SPR 7694 is fixed, we may want to go back to using LISP:GENSYM.
(let ((prefix "G") ; string used as prefix of names made by GENSYM
      (counter 0)) ; Counter used for next GENSYM'd symbol.
  (defun scheme:Ï3gensymÏ* (&optional arg)
    Ï1"Return a new uninterned symbol with a generated name.Ï*"
    (etypecase arg
      (null )
      (integer (setq counter arg))
      (string (setq prefix arg)))
    (let ((pname (format nil "~A~A" prefix counter)))
      (incf counter)
      (make-symbol pname))))

(export '(scheme:explode scheme:implode) scheme-package)
(deff scheme:explode 'zlc:explodec) ; doesn't handle package prefixes
(defun scheme:implode (list)
  ;; Differs from ZLC:IMPLODE by allowing strings or symbols more than one character long.
  ;; Doesn't handle packages right since uses current package instead of compile-time package.
  (let* ((count (length list))
	 (name (make-string count))
	 (index 0))
    (dolist (object list)
      (setf (char name index)
	    (etypecase object
	      (symbol (char (symbol-name object) 0))
	      (string (char object 0))
	      (character object)
	      (fixnum (int-char object))))
      (incf index))
    (string->symbol-internal name *package*)))
	    

;;;  --  Lists  --

(export '(scheme:atom? lisp:list*) scheme-package)
(defsubst scheme:atom? (object) (atom object))

(export '(scheme:copy scheme:sort! lisp:mapcar lisp:mapc scheme:append! scheme:reverse!)
	si:scheme-package)
(defsubst scheme:copy (pair) (copy-tree pair))
(defsubst scheme:reverse! (list) (nreverse list))

(defsubst scheme:sort! (sortee &optional (predicate #'general-sort-predicate))
  (declare (arglist sortee &optional predicate))
  (sort sortee predicate))

(defun general-sort-predicate (a b) ; is A less than B?
  ;; This version differs from PC Scheme in that strings are grouped with 
  ;; vectors after lists, while the PC Scheme sequence is: 
  ;;	numbers, characters, strings, symbols, lists, vectors.
  (declare (optimize speed (safety 0)))
  (cond ((eql a b) nil)
	((numberp a) (or (not (numberp b)) (< a b)))
	((and (consp a) (consp b)) ; treat DTP-LIST and DTP-STACK-LIST the same.
	 (or (general-sort-predicate (car a) (car b))
	     (and (equal (car a) (car b))
		  (general-sort-predicate (cdr a) (cdr b)))))
	(t (let ((da (sys:%data-type a))
		 (db (sys:%data-type b)))
	     (declare (fixnum da db))
	     (if (eql da db)
		 (cond ((eql da sys:dtp-character) (char< a b))
		       ((eql da sys:dtp-array)
			(if (stringp a)
			    (or (not (stringp b)) (string< a b))
			  (< (length a) (length b))))
		       ((eql da sys:dtp-symbol) (string< a b))
		       ((member da '(#.sys:dtp-function #.sys:dtp-closure #.sys:dtp-lexical-closure))
			(general-sort-predicate (function-name a) (function-name b)))
		       (t (< (sys:%pointer a) (sys:%pointer b))))
	       (and (not (numberp b))
		    (let ((dtp-sort-order
			    '#.(let ((array (make-array 32 :initial-element 31 :element-type '(integer 0 63))))
				 (dotimes (i (length array))
				   (setf (aref array i) (+ 32 i)))
				 (do ((tail 'sys:( DTP-Fix DTP-Single-Float DTP-Short-Float DTP-Extended-Number 
						  DTP-Character DTP-Symbol DTP-List Dtp-Stack-List DTP-Array DTP-Instance 
						  DTP-Function DTP-Closure DTP-Lexical-Closure DTP-U-Entry DTP-Locative)
					    (cdr tail))
				      (i 0 (1+ i)))
				     ((null tail))
				   (setf (aref array (symbol-value (car tail))) i))
				 array)))
		      (< (aref dtp-sort-order da) (aref dtp-sort-order db)))))))))

(defsubst scheme:append! (&rest lists) (apply #'nconc lists))

(export '(scheme:delete! scheme:delq!) scheme-package)
(defsubst scheme:delq! (object list)
  "Delete OBJECT from LIST, comparing by EQ?."
  (sys:delete-list-eq object list))
(defsubst scheme:delete! (object list)
  "Delete OBJECT from LIST, comparing by EQUAL?."
  (sys:delete-list object list #'scheme:equal?))
(compiler:optimize-pattern (sys:delete-list character t #'scheme:equal?)
			   (sys:delete-list-eq 1 2))
(compiler:optimize-pattern (sys:delete-list number t #'scheme:equal?)
			   (sys:delete-list-eql 1 2))
(compiler:optimize-pattern (sys:delete-list string t #'scheme:equal?)
			   (sys:delete-list-equal 1 2))

;;;  --  Streams  --

(export 'scheme:( cons-stream head tail the-empty-stream empty-stream?
		  list->stream stream->list stream?) scheme-package)
;; In this implementation, streams are not a distinct data type, so the 
;; predicate STREAM? has not been implemented.  Probably streams should be 
;; implemented as a named structure.  Note that in PC Scheme, streams are 
;; actually implemented as vectors whose first element is #!STREAM, with the 
;; undocumented consequence that VECTOR? is true of a stream.

(defmacro scheme:cons-stream (head tail)
  `(cons ,head (scheme:delay ,tail)))
(defsubst scheme:head (stream) (car stream))
(defsubst scheme:tail (stream)
  (setf (cdr stream)
	(scheme:force (cdr stream))))
(defconstant scheme:the-empty-stream '())
(defsubst scheme:empty-stream? (stream) (null stream))
(defun scheme:list->stream (list)
  (check-type list list)
  list)
(compiler:optimize-pattern (scheme:list->stream list) (progn 1))
(defun scheme:stream->list (stream)
  (if (scheme:empty-stream? stream)
      '()
    (cons (scheme:head stream)
	  (scheme:stream->list (scheme:tail stream)))))

;;;  --  Arithmetic  --

(export '(1+ scheme:-1+ scheme:add1 scheme:sub1 scheme:minus scheme:pi) si:scheme-package)
(defsubst scheme:-1+ (n) (1- n))
(defsubst scheme:add1 (n) (1+ n))
(defsubst scheme:sub1 (n) (1- n))
(defsubst scheme:minus (n) (- n))

(export 'scheme:(<> >? <? =? <=? >=? <>?) si:scheme-package)
(defsubst scheme:<> (n1 n2) (/= n1 n2))
(def-alias-function scheme:>? >)
(def-alias-function scheme:<? <)
(def-alias-function scheme:>=? >=)
(def-alias-function scheme:<=? <=)
(def-alias-function scheme:=? =)
(def-alias-function scheme:<>? scheme:<>)

(export '(scheme:float? scheme:float) scheme-package)
(defsubst scheme:float (number) (float number))
(defsubst scheme:float? (object) (floatp object))

(def scheme:Ï3piÏ*
     ;; Don't use DEFCONSTANT because we need to permit local shadowing.
     (define-integrable-1 'scheme:Ï3piÏ* lisp:pi)
     (set 'scheme:pi lisp:pi) ; this for UCL top-level arg checking
  )

;;;  --  Random numbers  --

(export '(scheme:random scheme:randomize) scheme-package)
(eval-when (eval compile)
  (setf (get 'let 'si:may-surround-defun) t))
(let ((random-seed (random-create-array 71. 35. 12231987))) ; 3rd number is arbitrary
(defun scheme:random (integer)
  "Returns a random number less than the argument, but not less than zero."
  (check-type integer integer)
  (let ((*random-state* random-seed))
    (random integer)))
(defun scheme:randomize (number)
  (setq random-seed
	(if (zerop number)			; create seed from clock
	    (make-random-state t)
	  (random-create-array			; create seed based on argument value
	    71. 35. (if (fixnump number)
			number
		      (let ((hash (sxhash number)))
			(if (zerop hash) ; value of 0 doesn't work as seed
			    (1+ (mod (abs number) (truncate most-positive-fixnum 2)))
			  hash))))))
  unspecified)
  ) ; end of LET random-seed 

;;;  --  Strings  --

(export '(scheme:string-null? scheme:integer->string) scheme-package)
(defsubst scheme:string-null? (string) (equal string the-empty-string))

(defun scheme:integer->string (integer base)
  (declare (unspecial base))
  (check-type integer integer)
  (let ((*print-base* base))
    (princ-to-string integer)))

(export 'scheme:( scheme:substring<? scheme:substring=? scheme:substring-ci<?
		 scheme:substring-ci=? scheme:substring-find-next-char-in-set
		 scheme:substring-find-previous-char-in-set scheme:substring-fill!
		 scheme:substring-move-left! scheme:substring-move-right!)
	scheme-package)

(defun scheme:substring<? (string1 start1 end1 string2 start2 end2)
  (minusp (string-compare-case string1 string2 start1 start2 end1 end2)))
(defun scheme:substring=? (string1 start1 end1 string2 start2 end2)
  (string= string1 string2
	   :start1 start1 :end1 end1
	   :start2 start2 :end2 end2))
(defun scheme:substring-ci<? (string1 start1 end1 string2 start2 end2)
  (minusp (string-compare string1 string2 start1 start2 end1 end2)))
(defun scheme:substring-ci=? (string1 start1 end1 string2 start2 end2)
  (string-equal string1 string2
		:start1 start1 :end1 end1
		:start2 start2 :end2 end2))

(defun scheme:substring-find-next-char-in-set (string start end charset)
  (declare (string string))
  (etypecase charset
    (character (position (the character charset) string :start start :end end))
    (string (if (= (length charset) 1)
		(position (char charset 0) string :start start :end end)
	      (string-search-set charset string start end t)
	      ))))

(defun scheme:substring-find-previous-char-in-set (string start end charset)
  (declare (string string))
  (etypecase charset
    (character (position (the character charset) string :start start :end end :from-end t))
    (string (if (= (length charset) 1)
		(position (char charset 0) string :start start :end end :from-end t)
	      (string-reverse-search-set charset string end start t)
	      ))))

(defun scheme:substring-fill! (string start end fillchar)
  (fill (the string string) (the character fillchar) :start start :end end))



;;;  --  Control flow  --

(export '(scheme:begin0 scheme:apply-if) si:scheme-package)
(defmacro scheme:begin0 (&rest forms)
  "Evaluate all of the arguments in order, returning the value of the first one."
  `(prog1 . ,forms))

(export '(scheme:when scheme:apply-if) si:scheme-package)
;; We don't just export LISP:WHEN because we want to give a style-check 
;; warning if the user tries to use the value of SCHEME:WHEN.
(deff-macro scheme:when 'lisp:when)
(setf (documentation 'scheme:when)
      "Evaluate the BODY forms if the PREDICATE form is true.
The value returned is unspecified.")

(defmacro scheme:apply-if (predicate procedure exp)
  "If PREDICATE is true, apply PROCEDURE to the value of PREDICATE, else evaluate EXP."
  (let ((temp1 (gensym)))
    `(let ((,temp1 ,predicate))
       (if ,temp1
	   (funcall ,procedure ,temp1)
	 ,exp))))

(export '(scheme:call/cc scheme:continuation? scheme:proc? scheme:closure?) si:scheme-package)
(deff scheme:call/cc 'scheme:call-with-current-continuation)
(defun scheme:continuation? (object)
  (and (scheme:procedure? object)
       (equal (arglist object) '(value-to-return-from-continuation))))

(def-alias-function scheme:proc? scheme:procedure?)
(defun scheme:closure? (object)
  "Is the object a procedure but not a continuation?"
  (and (scheme:procedure? object)
       (not (equal (arglist object) '(value-to-return-from-continuation)))))


;;;  --  Fluid variables  --

(export 'scheme:(fluid fluid-bound? set-fluid! fluid-let fluid-lambda) scheme-package)
(defmacro scheme:fluid (variable)
  "Returns the value of a fluid variable whose name is VARIABLE (which is not evaluated)."
  (check-type variable symbol)
  `(symbol-value ',variable))
(defmacro scheme:fluid-bound? (variable)
  "Does the symbol VARIABLE have a binding as a fluid variable?"
  (check-type variable symbol)
  `(boundp ',variable))
(defmacro scheme:set-fluid! (variable object)
  "Assign OBJECT as the value of fluid variable VARIABLE."
  (check-type variable symbol)
  `(set ',variable ,object)) ; result is "unspecified"

(comment
  ;; This original implementation has been replaced by handlers in files 
  ;; EVAL and OPTIMIZE in order to work around SPR 2644.  -- DNG 3/21/88
  (defmacro scheme:fluid-let (bindings &body body)
    (let ((names (binding-names bindings)))
      `(let ,(process-bindings bindings)
	 (declare (special . ,names))
	 (let ()
	   (declare (unspecial . ,names))
	   nil
	   . ,body))))
  )

(defun binding-names (bindings)
  (loop for var in bindings
	unless (member var si:lambda-list-keywords :test #'eq)
	collect (if (atom var) var (car var))))

(defmacro scheme:fluid-lambda (formals &body body)
  (declare (arglist &quote formals &body body))
  (let* ((args (convert-formals formals))
	 (names (binding-names args)))
    `(function (lisp:lambda ,args
		 (declare (special . ,names))
		 (let ()
		   (declare (unspecial . ,names))
		   (with-scheme-semantics
		     . ,body))))))

;;;  --  Macros and syntax extension  --

(export '(scheme:macro scheme:syntax scheme:alias) scheme-package)

(defmacro scheme:macro (name expander)
  "Define NAME to be a macro; EXPANDER is a procedure of one argument which expands it."
  (let ((fn (if (and (consp expander)
		     (eq (first expander) 'scheme:lambda))
		`(scheme-lambda-with-name (,name ,(first (second expander)) &optional .environment.)
		   .environment.
		   . ,(cddr expander))
	      `(scheme-lambda-with-name (,name form &optional environment)
		 environment
		 (,expander form)))))
    `(deff-macro ,name (cons 'macro ,fn))))

(defmacro scheme:syntax (pattern expansion)
  (check-type pattern list)
  (check-type expansion list)
  (let ((args nil)) ; list of argument names
    (labels ((collect-args (x)
	         (if (atom x)
		     (unless (null x)
		       (push x args))
		   (progn (collect-args (car x))
			  (collect-args (cdr x))))
		 (values))
	     (expand (x)
		 (if (atom x)
		     (if (member x args :test #'eq)
			 x
		       `(quote ,x))
		   (let ((temp nil))
		     (do ((tail x (cdr tail)))
			 ((atom tail)
			  (if (null tail)
			      (cons 'si:xr-bq-list
				    (nreverse temp))
			    (progn (push (expand tail) temp)
				   (cons 'si:xr-bq-list*
					 (nreverse temp)))))
		       (push (expand (car tail)) temp) )))))
      (collect-args (cdr pattern))
      `(defmacro ,(car pattern) ,(cdr pattern)
	 ,(expand expansion)))))

(defmacro scheme:alias (name1 name2)
  "Define NAME1 to be the same as the function or special form NAME2.
Neither argument is evaluated."
  (let ((quoted-name `(quote ,name1)))
    `(eval-when (eval compile load)
       (fdefine ,quoted-name ',name2 t)
       (compiler:add-optimizer ,name1 compiler:substitute-function-name ,name2)
       ,quoted-name)))


;;;  --  Misc.  --

(export '(scheme:true scheme:false) scheme-package) ; %%% ought to flag these as obsolete somehow
(def-global-scheme-variable scheme:true t)
(def-global-scheme-variable scheme:false nil)

;; Note: the following definition of EQV? differs from the Revised^3 Report by 
;;	supporting comparison of strings.
;; Also, there is some confusion about whether numbers should be compared by 
;; EQL or =; this definition is consistent with the way PC Scheme 2.0 works 
;; even though page 7-67 of the TI Scheme manual says that = is used for 
;; numbers.  It may actually use = in PC Scheme release 3?
(defun scheme:eqv? (obj1 obj2)
  (declare (optimize speed (safety 0)))
  (cond ((eql obj1 obj2) t)
	((vectorp obj1)
	 (if (stringp obj1)
	     (and (stringp obj2) (equal obj1 obj2))
	   (and (vectorp obj2)
		(zerop (length obj1))
		(zerop (length obj2)))))
	(t nil)))
                                              
(defun scheme:memv (object list)
  (declare (optimize (safety 0) (speed 3) (compilation-speed 0)))
  (if (member (%data-type object)
	      '(#.DTP-Symbol #.DTP-Fix #.DTP-Character))
      (member object list :test #'eq)
    ;; don't use MEMBER here because it would get optimized back into MEMV.
    (sys:member-test object list #'scheme:eqv?)))

(export '(scheme:*the-non-printing-object*) scheme-package)
;; This is an approximation that will have the intended effect in the Lisp 
;; Listener when used as the result value of a function.
(scheme:define-integrable scheme:*the-non-printing-object* (lisp:values))

(defconstant #.the-unassigned-value the-unassigned-value) ; self-evaluating symbol
(export '(scheme:unassigned?) scheme-package) ; undocumented feature
(defsubst scheme:unassigned? (object) (eq object the-unassigned-value))

(export '(scheme:delayed-object?) scheme-package)
(defsubst scheme:delayed-object? (object) (typep object 'promise))

(export '(scheme:freeze scheme:thaw) scheme-package)
(defmacro scheme:freeze (&rest expressions)
  "Return a thunk which will evaluate the expressions later when envoked by THAW."
  `(scheme:lambda () . ,expressions))
(defsubst scheme:thaw (thunk) (funcall thunk))

(export '(scheme:define-structure scheme:include scheme:|#!STRUCTURE|) scheme-package)


;;;  --  PC environment utilities  --

(export '( scheme:edwin scheme:bkpt scheme:error scheme:assert scheme:gc
	  scheme:dos-file-copy scheme:dos-dir scheme:dos-chdir scheme:dos-change-drive
	  scheme:dos-rename scheme:dos-delete scheme:dos-file-size
	  scheme:exit lisp:describe
	  scheme:pcs-machine-type
	  scheme:reset scheme:scheme-reset scheme:reset-scheme-top-level) si:scheme-package)
(defsubst scheme:edwin () "Invoke the text editor." (ed))
(defun scheme:reset () (signal 'sys:abort "Abort."))

(defun scheme:scheme-reset ()
  (setq *standard-output* #'scheme:standard-output)
  (setq *standard-input* #'scheme:standard-input)
  (scheme:reset))

(defun scheme:reset-scheme-top-level ()
  ;; This should restore the initial value of SCHEME-TOP-LEVEL, but since that 
  ;; is not supported, this function doesn't currently do anything.
  unspecified)

(defun scheme:bkpt (message value)
  (break "[BKPT] ~A ~S" message value)
  unspecified)
(defun scheme:error (message &rest values)
  (declare (arglist message-string . values))
  "Signal an error."
  (lisp:error "~A  ~{~S  ~}" message values))
(setf (get 'scheme:error :error-reporter) t)

(defparameter continue-message-format "Continue execution anyway.")
(defparameter assert-message-format "ASSERT failure.~%(ASSERT ~S~@{ ~S~})")
(defmacro scheme:Ï3assertÏ* (predicate &rest messages)
  "If PREDICATE is not true, enter the debugger, displaying MESSAGES."
  `(progn (or ,predicate
	      (cerror continue-message-format
		      assert-message-format  ',predicate . ,messages))
	  unspecified))

(defun scheme:dos-file-copy (source destination)
  (and (copy-file source destination)
       0))
(defun scheme:dos-dir (filename)
  "Return list of the file names from a directory."
  (mapcar #'namestring (directory filename)))
(defun scheme:dos-chdir (directory-spec)
  "Change default directory.  Returns the previous default."
  (prog1 (and *DEFAULT-PATHNAME-DEFAULTS*
	      (namestring (send (cdr (first *DEFAULT-PATHNAME-DEFAULTS*))
				:new-pathname :name nil :type nil :version nil)))
	 (catch-error-restart (error "Continue without changing directories.")
	   (let ((path (pathname directory-spec)))
	     (fs:set-default-pathname path *DEFAULT-PATHNAME-DEFAULTS*)
	     (fs:set-default-pathname path FS:LOAD-PATHNAME-DEFAULTS)))))
(deff scheme:dos-change-drive #'scheme:dos-chdir)

(defun scheme:dos-rename (current new)
  "Rename a file.  Returns 0 if succesful."
  (multiple-value-bind (old-name old-truname new-truename)
      (rename-file current new :error nil)
    (declare (ignore old-name old-truname))
    (if (pathnamep new-truename) 0 -1)))

(defun scheme:dos-delete (filespec)
  "Delete a file."
  (ignore-errors (delete-file filespec)
		 (return-from scheme:dos-delete 0))
  -1)

(defun scheme:dos-file-size (filespec)
  "Return the number of characters in a file."
  (check-type filespec string)
  (values (file-length filespec)))

(export '(scheme:runtime) scheme-package)
(defun scheme:runtime ()
  "Returns a fixnum time in hundredths of a second since midnight."
  (declare (optimize (safety 0) (speed 3)))
  (let (seconds minutes hours microseconds)
    (without-interrupts
      (time:UPDATE-TIMEBASE)
      (setq seconds time:*LAST-TIME-SECONDS*
	    minutes time:*LAST-TIME-MINUTES*
	    hours   time:*LAST-TIME-HOURS*
	    microseconds time:*SAVED-MICROSECOND-OVERFLOW*) )
    (+ (* (+ (* (+ minutes (* hours 60)) 60) seconds) 100)
       (mod (floor microseconds 10000.) 100.)
       )))
(comment ; this alternate definition is faster and is standard Common Lisp, but does not exactly match PC Scheme.
(defun scheme:runtime ()
  "Returns an integer time in hundredths of a second since last boot."
  (values (round (* (get-internal-run-time) 5)
		 3)))
 )

(defun scheme:gc (&optional compact)
  ;; Not clear what should be done with this.
  ;; Maybe should just always do nothing.
  (when compact
    (gc-immediately :max-gen 0 :promote t))
  unspecified)
(proclaim '(notinline scheme:gc))

(defun scheme:exit ()
  "Leave Scheme, returning to Common Lisp mode."
  (turn-common-lisp-on)
  (signal 'sys:abort "Exit."))

;; Compiler switches
(export '(compiler:pcs-integrate-t-and-nil compiler:pcs-debug-mode) scheme-package)

;; Debug tools
(export 'scheme:( advise-entry advise-exit
		 break break-both break-entry break-exit
		 trace trace-both trace-entry trace-exit
		 unadvise unadvise-entry unadvise-exit
		 unbreak unbreak-entry unbreak-exit
		 untrace untrace-entry untrace-exit
		 *args* *proc* *result*
		 ) scheme-package)

;;;  --  Scheme translator compatibility  --

(defconstant scheme:pcs-machine-type 1) ; 1 => TIPC (doesn't seem right, but that's what the translator does)

(export '(scheme:%cl-function) scheme-package)
(defmacro scheme:%cl-function (function)
  (check-type function symbol)
  (let ((pkg (symbol-package function)))
    `(function ,(if (or (eq pkg *package*)
			(eq pkg scheme-package))
		    ;; probably not the one we really want.
		    ;; Not that we really expect it to be in the compiler package, but it inherits
		    ;; from all of the right places: LISP, TICL, SYS, and ZLC.
		    (intern (symbol-name function) sys:pkg-compiler-package)
		  function))))

(export '(scheme:%logior scheme:%logand scheme:%setf scheme:%dont-optimize) scheme-package)
(scheme:alias scheme:%logand lisp:logand)
(scheme:alias scheme:%logior lisp:logior)
(scheme:alias scheme:%setf lisp:setf)
(scheme:alias scheme:%dont-optimize dont-optimize)
