;;; -*- Mode: Common-Lisp; Package: SI; Base: 10 -*-

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

;;;		"Almost Scheme"
;;;
;;;   An implementation of Scheme running on top of
;;;   TI Explorer Common Lisp.

;; This file follows the "Revised^3 Report on the
;; Algorithmic Language Scheme", SIGPLAN Notices, Dec. 1986.

;; Readtable differences from Common Lisp:
;;  colon is an alphabetic character [2.1]
;;  #| is not a comment.
;;  #t and #f [2.3]
;;  #e, #i, #l, #s, #d [2.3]

;; Limitations of this implementation:
;; The false object is EQ to the empty list.
;; The false object and the true object are both symbols.
;; Rest arg is not "newly-consed" so cannot be altered. [4.1.4]

;; Compiler changes needed:
;;   Variable defined in global environment references function cell of symbol.
;;   CAR of form is evaluated as an expression.  [4.1.3]
;;   () is not a legal expression unless quoted. [4.1.3]

;; Notes that might be of interest for the implementation:
;;   It is an error to alter a constant. [4.1.2]
;;   Order of evaluation of function arguments is unspecified. [4.1.3]

;;Revision history:
;; 11/14/87 DNG - Avoid error on (DEFINE X 'X).
;;		Fix bugs in LIST->VECTOR and CASE.
;; 11/20/87 DNG - Enhance NAME-FUNCTION to give name to a LAMBDA within a LETREC etc.
;;		Optimize LETREC with constant initial values.
;; 11/21/87 DNG - Fixed bug in FORCE.
;; 12/02/87 DNG - Fix evaluator's definition of SET! and STRING-SET! .
;; 12/05/87 DNG - Re-implemented SYMBOL->STRING to include a package prefix in 
;;		the returned string.  Moved SET! to the "EVAL" file.
;; 12/12/87 DNG - When defining a global variable, forward the symbol's value 
;;		cell to the function cell.  Updated READ to bind *READTABLE* and *PACKAGE*.
;;		Use new special form WITH-SCHEME-SEMANTICS to control the mode of the 
;;		compiler and evaluator.
;; 12/14/87 DNG - Partially backed out the forwarding of the value cell 
;;		because it was breaking other things.
;; 12/19/87 DNG - In compiled code, always optimize LENGTH, STRING-LENGTH, and 
;;		VECTOR-LENGTH to LISP:LENGTH.  More adjustments to handling of top-level DEFINE.
;; 12/29/87 DNG - Modify IF to default the else value to NIL instead of 
;;		UNSPECIFIED for PC Scheme compatibility.
;;  1/09/88 DNG - Permit LCM with no arguments.  Fixed DO to evaluate all step 
;;		expressions before updating any of the variables.
;;  1/16/88 DNG - Modify the expansion of DEFINE to permit more than one level 
;;		of lists as the first argument.
;;  1/29/88 DNG - Fix STRING<? etc. to return T instead of a number.
;;  2/11/88 DNG - Fix bugs in named LET.
;;  2/12/88 CLM - Add (fix n) format to NUMBER->STRING.
;;  2/12/88 DNG - Fix DEFINE-OPT to not dis-optimize SCHEME-LAMBDA-WITH-NAME.
;;  2/20/88 DNG - Re-implemented CASE in order to handle strings correctly.
;;		Fixed INPUT-PORT? and OUTPUT-PORT? for dynamic closures.
;;  3/09/88 DNG - Modify SYMBOL? to return false for #F.
;;  3/31/88 DNG - Moved definition of NUMBER->STRING to another file.
;;  4/16/88 DNG - Moved several compiler optimizers to file "optimize" so that 
;;		they won't be included in the runtime-only system.
;;  5/19/88 DNG - Re-implemented WRITE and DISPLAY to use Scheme syntax.
;;  9/03/88 DNG - Modified WRITE and DISPLAY to reference SCHEME-READTABLE instead of *READTABLE*.
;;  1/28/89 DNG - Made DELAY a little more efficient by using a boa-constructor.

(eval-when (eval compile load)
(defpackage SCHEME (:use nil))
(defpackage SCHEME-USER (:use "SCHEME"))
(defconstant scheme-package (find-package "SCHEME"))
(defconstant scheme-user-package (find-package "SCHEME-USER")))

(defflavor unspecified-value () () :no-vanilla-flavor)
;; An object that can be passed around but has no legal operations except :PRINT-SELF.
(defmethod (unspecified-value :print-self) (stream &rest ignore)
  (si:printing-random-object (self stream :typep)))
(defmethod (unspecified-value :init) ignore)
(defmethod (unspecified-value :send-if-handles) ignore) ; to avoid error in DESCRIBE
(defparameter unspecified (make-instance 'unspecified-value))

(proclaim '(special scheme-readtable))

;;;  4.1.2

(export '(lisp:quote) scheme-package)

;;;  4.1.4

(export '(scheme:lambda) scheme-package)

(defmacro scheme:lambda (formals &body body)
  (declare (arglist &quote formals &body body))
  `(function (lisp:lambda ,(convert-formals formals)
	       (with-scheme-semantics . ,(undefinify body)))))

(defun convert-formals (formals)
  (typecase formals
    (null '())
    (cons (if (null (cdr (last formals)))
	      formals
	    ;; else dotted list, convert to use &rest arg.
	    (let* ((new (copy-list formals))
		   (last-pair (last new)))
	      (setf (cdr last-pair) `(&rest ,(cdr last-pair)))
	      new)))
    (symbol `(&rest ,formals))
    (t (error "~S is not a valid formal argument list." formals)
       nil)))


;;;  4.1.5

(export '(scheme:if) scheme-package)

(defmacro scheme:if (test consequent &optional alternate)
  ;; Differs from LISP:IF by not taking more than 3 args.
  ;; If the alternate is not supplied, then the value is "unspecified", but 
  ;; there is code that relies on the fact that PC Scheme defaults the 
  ;; alternate to false.
  `(cond (,test ,consequent)
	 (t ,alternate)))

;;;  4.1.6

(export '(scheme:set!) scheme-package)

;; Because SET! is a basic special form, there is no run-time function defined 
;; for it here.  Instead, there are handlers defined for it in files "EVAL" 
;; and "COMPILER".


;;;  4.2.1

(export '(scheme:cond scheme:case scheme:else lisp:and lisp:or) scheme-package)
(defmacro scheme:cond (&rest clauses)
  (let* ((clauses (copy-list clauses))
         (last (last clauses)))
    (if (eq (caar last) 'scheme:else)
        (setf (caar last) 't)
      (setf (cdr last) '((t unspecified))))
    `(lisp:cond . ,clauses)))

;; %% above does not yet support the "=>" syntax

(defmacro scheme:case (key &body clauses)
  "Select one of a series of clauses to evaluate based on the value of a controlling expression."
  (let (test-exp cond-exp)
    (setq test-exp
	  ;; If KEY is an eval-at-load-time,
	  ;; we will treat it as a random expression, which is right.
	  (cond ((or (atom key)
		     (and (member (car key) '(car cdr caar cadr cdar cddr) :test #'eq)
			  (atom (cadr key))))
		 key)
		(t '.case.item.)))
    (do ((tail clauses (rest tail)))
	((null tail))
      (let ((clause (first tail)))
	(macro-type-check-warning 'scheme:case (car clause))
	(unless (cdr clause)
	  (error "CASE clause ~S lacks an expression." clause))
	(push (cond ((eq (car clause) 'scheme:else)
		     (unless (null (cdr tail))
		       (error "~S is not the last CASE clause." clause))
		     `(t . ,(cdr clause)))
		    ((consp (car clause))
		     `((scheme:memv ,test-exp ',(car clause))
		       . ,(cdr clause)))
		    (t (comment ; PC Scheme allows this
			 (error "CASE test ~S is not a list." (car clause)))
		       `((scheme:eqv? ,test-exp ',(car clause))
			 . ,(cdr clause))))
	      cond-exp)))
    (comment ; for PC Scheme compatibility, the result defaults to nil.
      (unless (eq (first (first cond-exp)) 't)
	(push '(t unspecified) cond-exp)))
    (setq cond-exp (cons 'cond (nreverse cond-exp)))
    (if (eql test-exp key)
	cond-exp
      `(let ((.case.item. ,key))
	 ,cond-exp))))

#| old, original definition, doesn't work for strings.
(defmacro scheme:case (key &rest clauses)
  (let* ((else nil)
         (x (loop for clause in clauses
		  collect (if (eq (car clause) 'scheme:else)
			      (progn (setq else t)
				     (cons 't (cdr clause)))
			    (progn (comment ; PC Scheme seems to allow this
				     (unless (listp (car clause))
				       (error "CASE test ~S is not a list."
					      (car clause))))
				   (unless (cdr clause)
				     (error "CASE clause ~S lacks an expression."
					    clause))
				   clause)))
	    ))
    (unless else
      (setq x (nconc x '((t unspecified)))))
    `(lisp:case ,key . ,x)))
 |#


;;  4.2.2

(export '(scheme:let scheme:let* scheme:letrec) scheme-package)

(defmacro scheme:let (bindings &body body)
  (if (and bindings (symbolp bindings))		; named let [4.2.4]
      (let ((name bindings)
	    (bindings (first body))
	    (body (rest body)))
	`((scheme:named-lambda (,name . ,(mapcar #'first bindings))
	    . ,body)
	  . ,(mapcar #'second bindings)))
    (unless body
      (error "LET without any body expressions."))
    ;; the nil below is so DECLAREs are not permitted.
    `(let ,(process-bindings bindings) nil . ,(undefinify body))))

(defun process-bindings (bindings)
  (loop for binding in bindings
	collect (if (atom binding)
		    binding ;;  %%%   Should also give a warning here.
		  (list (first binding)
			(name-function (first binding) (second binding))))))


(defmacro scheme:let* (bindings &body body)
  (unless body
    (error "LET* without any body expressions."))
  ;; the nil below is so DECLAREs are not permitted.
  `(let* ,(process-bindings bindings) nil . ,(undefinify body)))

(defmacro scheme:letrec (bindings &body body)
  (let ((vars nil)
	(sets nil))
    (dolist (binding bindings)
      (let ((var (first binding))
	    (val (second binding)))
	(cond ((constantp val)
	       (push binding vars))
	      (t (push `(,var (compiler:undefined-value)) vars)
		 (push var sets)
		 (push (name-function var val) sets)))))
    `(let* ,(nreverse vars) (psetq . ,(nreverse sets)) . ,(undefinify body))))

(defun name-function (name value)
  ;; if VALUE is a function, call it NAME.
  (cond ((atom value) value)
	((eq (car value) 'scheme:lambda)
	 ;; give the function a name to aid debugging.
	 `(scheme-lambda-with-name (,name . ,(second value))
	    . ,(cddr value)))
	((and (member (car value) 'scheme:(let let* letrec fluid-let) :test #'eq)
	      (= (length value) 3))
	 (let ((new (name-function name (third value))))
	   (if (eq new (third value))
	       value
	     (list (first value) (second value) new))))
	(t value)))

(defmacro scheme-lambda-with-name (form &body body)
  ;; Like SCHEME:NAMED-LAMBDA except that the name is not defined.
  (declare (arglist &quote formals &body body))
  `(function (lisp:named-lambda ,(first form)
				,(convert-formals (rest form))
				(with-scheme-semantics
				  . ,(undefinify body)))))

;;  4.2.3

(export '(scheme:begin scheme:sequence) scheme-package)
(defmacro scheme:begin (exp1 &rest more-exp)
  (declare (arglist &body expressions))
  "Execute the expressions in sequence, returning the value of the last one."
  `(progn ,exp1 . ,more-exp))
(deff-macro scheme:sequence #'scheme:begin) ; used in Abelson & Susman

;;  4.2.4

(export '(scheme:do) scheme-package)
(defmacro scheme:do (vars test &body commands)
  (let ((block (gensym))
	(initvars (loop for var in vars
			collect (list (first var) (second var))))
	(steps (loop for var in vars
		     unless (null (cddr var))
		     nconcing (list (first var) (third var))))
	)
    `(block ,block
       (let ,initvars
	 (tagbody top
	     (and ,(car test)
		  (return-from ,block
		    ,(if (cdr test)
			 `(progn . ,(cdr test))
		       'unspecified)))
	     (progn . , commands)
	     (compiler:unshare-stack-closure-vars
	       . ,(mapcar #'first vars))
	     (psetq . ,steps)
	     (go top))))))

;;  4.2.5 and 6.9

(export '(scheme:delay scheme:force) scheme-package)
(defstruct (promise (:constructor make-a-promise (value)) ; new version
		    (:constructor make-promise) ; this one just for supporting old object files
		    (:predicate delayed-object-p) (:copier nil))
  (evaluated nil)
  value)
(defmacro scheme:delay (expression)
  (if (or (numberp expression)
	  (stringp expression)
	  (compiler:quotep expression))
      expression
    `(make-a-promise #'(lambda ()
			 (with-scheme-semantics ,expression)))))
(defun scheme:force (promise)
  (cond ((typep promise 'promise)
	 (let ((value (promise-value promise)))
	   (unless (promise-evaluated promise)
	     (setf value (funcall value)
		   (promise-value promise) value
		   (promise-evaluated promise) t))
	   value))
	(t promise)))

;;  4.2.6

(export '(scheme:quasiquote scheme:unquote scheme:unquote-splicing)
        scheme-package)

;; If anyone needs QUASIQUOTE, there is a definition in Pseudoscheme that could be adapted.
;; It doesn't look worth bothering with now.


;;  5.2

(export '(scheme:define scheme:pcs-integrate-define) scheme-package)

(defmacro scheme:define (variable &body expression)
  (declare (arglist &quote variable expression))
  (multiple-value-bind (name value)
      (normalize-define variable expression)
    (if (and (consp value)
	     (eq (first value) 'quote)
	     (eq (second value) name))
	`(defparameter ,name ,value) ; to avoid error in FDEFINE on (DEFINE X 'X)
      `(define-internal ',name ,value))))

(defconstant the-unassigned-value '|#!unassigned|) ; PC Scheme uses this as default value.
(defvar scheme:pcs-integrate-define nil
  "Use NAMED-LAMBDA instead of LAMBDA in the expansion of (DEFINE (name ...)...)?")

(defun normalize-define (variable body)
  (declare (values name value))
  (cond ((consp variable)
	 (normalize-define (car variable)
			   (if (and scheme:pcs-integrate-define
				    (symbolp (car variable)))
			       `((scheme:named-lambda ,variable
				   . ,body))
			     `((scheme:lambda ,(cdr variable)
				 . ,body)))))
	((rest body)
	 (error "Too many arguments to (DEFINE ~S ...).") variable)
	((null body) ; PC Scheme permits this
	 (values variable the-unassigned-value))
	(t (values variable (name-function variable (car body))))))

(defun define-internal (variable expression)
  (if (and (null si:*interpreter-environment*)
	   (null si:*interpreter-function-environment*))
      (define-globally-for-scheme variable expression)
    (error "DEFINE of ~S appears in invalid context." variable))
  )

(defun define-globally-for-scheme (symbol value)
  (when (fdefine symbol value t)
    (remprop symbol 'compiler:INTEGRABLE)
    ;;(remprop symbol 'inline)
    (unless (boundp symbol)
      ;; Forward the value cell to the function cell so that Common Lisp code can 
      ;; access it as a special variable.
      (%p-store-tag-and-pointer (value-cell-location symbol)
				Dtp-One-Q-Forward
				(function-cell-location symbol)))
    symbol))

(defmacro def-global-scheme-variable (symbol expression)
  ;; syntactic sugar to help META-.
  (declare (arglist &quote symbol &eval expression))
  `(define-globally-for-scheme ',symbol ,expression))

(defun undefinify (body)
  (let ((defines nil))
    (loop while (and body
		     (consp (first body))
		     (eq (first (first body)) 'scheme:define))
	  do (push (pop body) defines))
    (if (null defines)
	body
      (let ((bindings nil)
	    (trivial t))
	(dolist (d defines)
	  (multiple-value-bind (name value)
	      (normalize-define (second d) (cddr d))
	    (push (list name value)
		  bindings)
	    (when (and trivial
		       (typecase value
			 (symbol (member value bindings :test #'eq :key #'car))
			 (cons (not (eq (car value) 'quote)))
			 (t nil)))
	      ;; possiblity of recursive reference exists
	      (setq trivial nil))))
	`((,(if trivial 'let* 'scheme:letrec) ,bindings . ,body))))))

;;  6.1

(export '(lisp:not scheme:boolean? scheme:nil scheme:t) scheme-package)
(defsubst scheme:boolean? (object)
  "Is the argument either the true object or the false object?"
  (member object '(t nil)))
(def-global-scheme-variable scheme:nil 'lisp:nil)
(def-global-scheme-variable scheme:t 'lisp:t)


;;  6.2

(export '(scheme:eqv? scheme:eq? scheme:equal?) scheme-package)

;; %%% problem: "all empty vectors are operationally equivalent to each other"
;; %%%  also empty strings.

#|  ;; This definition of EQV? conforms to the Revised^3 Report, but not PC Scheme.
    ;; See file PCS for the definition currently being used.
 (defsubst scheme:eqv? (obj1 obj2)
   (eql obj1 obj2))
|#

;; %%% is EQV? the same as EQL for numbers of different types?

(defsubst scheme:eq? (obj1 obj2) (eq obj1 obj2))
(defun scheme:equal? (obj1 obj2)
  (declare (optimize speed (safety 0)))
  (or (eql obj1 obj2)
      (typecase obj1
	(cons (and (consp obj2)
		   (scheme:equal? (car obj1) (car obj2))
		   (scheme:equal? (cdr obj1) (cdr obj2))))
	(array (if (stringp obj1)
		   (and (stringp obj2) (string= obj1 obj2))
		 (and (vectorp obj1)
		      (vectorp obj2)
		      (= (length obj1) (length obj2))
		      (dotimes (i (length obj1) t)
			(unless (scheme:equal? (aref obj1 i)
					       (aref obj2 i))
			  (return nil)))
		      )))
	(t nil))))

;; Optimizer for EQUAL? moved to file "optimize".

;;  6.3

(export '(scheme:pair? lisp:cons lisp:car lisp:cdr) scheme-package)

(defsubst scheme:pair? (object) (consp object))

;; %% should be error to take CAR or CDR of an empty list.

(export '(scheme:set-car! scheme:set-cdr!) scheme-package)
(defsubst scheme:set-car! (pair object)
  (rplaca pair object)) ; returned value is "unspecified", but PCS returns the cons
(defsubst scheme:set-cdr! (pair object)
  (rplacd pair object)) ; returned value is "unspecified", but PCS returns the cons

(export '(CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CAAR CADAAR CADADR CADAR 
	  CADDAR CADDDR CADDR CADR CDAAAR CDAADR CDAAR CDADAR CDADDR CDADR CDAR
	  CDDDR CDDR
          CDDAAR CDDADR CDDAR CDDDAR CDDDDR) scheme-package)
(export '(scheme:null? lisp:list scheme:length lisp:append scheme:reverse)
        scheme-package)
(defsubst scheme:null? (object) (null object))
(defun scheme:length (list)
  (check-type list list)
  (length list))
(compiler:optimize-pattern (scheme:length t) (length 1))
(compiler:fold-constant-arguments 'scheme:length)
(deff scheme:reverse #'si:reverse-list)

(export '(scheme:list-tail scheme:list-ref scheme:last-pair) scheme-package)
(defsubst scheme:list-tail (list k) (nthcdr k list))
(defsubst scheme:list-ref (list k) (nth k list))
(defsubst scheme:last-pair (list) (last list))

(export '(global:memq scheme:memv scheme:member) scheme-package)
;; MEMV moved to PCS file to support PC Scheme semantics for EQV?
;;(defsubst scheme:memv (object list) (sys:member-eql object list))
(defsubst scheme:member (object list)
  (si:member-test object list #'scheme:equal?))
(compiler:optimize-pattern (si:member-test string t #'scheme:equal?)
                           (si:member-equal 1 2))
(compiler:optimize-pattern (si:member-test number t #'scheme:equal?)
                           (si:member-eql 1 2))

(export '(global:assq scheme:assv scheme:assoc) scheme-package)
(defsubst scheme:assv (object alist) (sys:assoc-eql object alist))
(defsubst scheme:assoc (object alist)
  (si:assoc-test object alist #'scheme:equal?))

;;;  6.4  Symbols

;; Note: only some implementations have slashification or uninterned symbols.

(export '(scheme:symbol? scheme:symbol->string scheme:string->symbol)
        scheme-package)

(defsubst scheme:symbol? (object)
  "Returns true if object is a symbol, otherwise returns false."
  (and object ; (symbol? #f) ==> #f
       (symbolp object)
       ;; (not (eq object t)) ; oddly, (symbol? #!true) => #!true on PC Scheme.
       ))


(defun scheme:symbol->string (symbol)
  "Returns the name of SYMBOL as a string."
  (symbol->string-internal symbol scheme-user-package))

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

(defun symbol->string-internal (symbol default-package)
  (let ((name (symbol-name symbol)))
    (if (or (eq (symbol-package symbol) default-package)
	    (eq (find-symbol name default-package)
		symbol))
	name
      (let ((*package* default-package))
	(with-output-to-string (stream)
	  (print-pname-string symbol stream nil))))))

(defun scheme:string->symbol (string) 
  "Returns the symbol whose name is STRING."
  (declare (string string) (optimize speed))
  (string->symbol-internal string scheme-user-package))

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

(defun string->symbol-internal (string default-package)
  (declare (string string) (optimize speed))
  (let* ((cc1 (position #\: string :test #'eql))
	 (cc2 (and cc1 (position #\: string :test #'eql :from-end t)))
	 pkg)
    (if (and cc1
	     (or (= cc2 cc1) (= cc2 (1+ cc1)))
	     (setq pkg (find-package (subseq string 0 cc1))))
	(values (intern (subseq string (1+ cc2)) pkg))
      (values (intern string default-package))) ))

;;;  6.5  Numbers

; 6.5.3
;
; #b binary
; #o octal
; #d decimal
; #x hex
;
; #e exact
; #i inexact
; #s single (or short?) precision flonum
; #l long precision flonum

;;  6.5.4  Numerical operations

(export '(scheme:number? scheme:complex? scheme:real? scheme:rational? 
                         scheme:integer?) scheme-package)

(defsubst scheme:number? (object) (numberp object))
(defsubst scheme:complex? (object) (numberp object)) ; not the same as LISP:COMPLEXP !
(defsubst scheme:real? (object)
  "Is the argument a non-complex number?"
  (realp object))
(defsubst scheme:rational? (object) (rationalp object))
(defsubst scheme:integer? (object) (integerp object))

(export '(scheme:zero? scheme:positive? scheme:negative? 
          scheme:odd? scheme:even? scheme:exact? scheme:inexact?)
        scheme-package)

(defsubst scheme:zero? (number) (zerop number))
(defsubst scheme:positive? (number) (plusp number))
(defsubst scheme:negative? (number) (minusp number))
(defsubst scheme:odd? (number) (oddp number))
(defsubst scheme:even? (number) (evenp number))
(defsubst scheme:exact? (number) (typep number 'rational)) ; %%% but in PCS it always returns false
(defsubst scheme:inexact? (number) 
          (not (typep number 'rational)))  ; %%% but in PCS it always returns true

(export '( = < > <= >= max min + * - / abs ) scheme-package)
(export '(scheme:quotient scheme:remainder scheme:modulo) scheme-package)

(defsubst scheme:quotient (n1 n2) (truncate n1 n2)) ; args must be integers
(defsubst scheme:remainder (n1 n2) (rem n1 n2))
(defsubst scheme:modulo (n1 n2) (mod n1 n2))

(export '(numerator denominator gcd #| lcm |# ) scheme-package)

(eval-when (eval compile load) ; temporary patch to undo export of LISP:LCM
  (when (eq (find-symbol "LCM" scheme-package) 'lisp:LCM)
    (unintern 'lisp:LCM scheme-package)))
(export '(scheme:LCM) scheme-package)
;; This definition is temporary until Common Lisp is fixed to allow (LCM) [SPR 7112].
(defun scheme:LCM (&rest numbers)
  "Return the least common multiple of all the numbers."
  (if (null numbers)
      1
    (apply #'lisp:LCM numbers)))
(compiler:fold-constant-arguments 'scheme:lcm)

(export '(scheme:floor scheme:ceiling scheme:truncate scheme:round 
                       lisp:rationalize) ; is this the same ???
        scheme-package)
(defsubst scheme:floor (number) (floor number)) ; only takes one argument
(defsubst scheme:ceiling (number) (ceiling number))
(defsubst scheme:truncate (number) (truncate number))
(defsubst scheme:round (number) (round number))

(export '(exp log sin cos tan asin acos atan sqrt expt) scheme-package)
(export '(scheme:make-rectangular scheme:make-polar
          scheme:real-part scheme:imag-part
          scheme:magnitude scheme:angle) scheme-package)     
(defsubst scheme:make-rectangular (real imaginary) (complex real imaginary))
(defsubst scheme:make-polar (magnitude radians) (* magnitude (cis radians)))
(defsubst scheme:real-part (number) (realpart number))
(defsubst scheme:imag-part (number) (imagpart number))
(defsubst scheme:magnitude (number) (abs number))
(defsubst scheme:angle (complex)  ; -pi < r <= pi
  (phase complex))

(export '(scheme:exact->inexact scheme:inexact->exact) scheme-package)
(defun scheme:exact->inexact (number)
       (etypecase number
                  (integer (if (< (abs number) 9999)
                               (float number 1.0s0)
                               (if (< (abs number) 999999)
                                   (float number 1.0f0)
                                   (float number 1.0d0))))
                  (ratio (float number 1.0f0))
                  (float number)
                  (complex (complex (scheme:exact->inexact (realpart number))
				    (scheme:exact->inexact (imagpart number))))
                  ))

(defun scheme:inexact->exact (number)
  (cond ((complexp number)
	 (complex (scheme:inexact->exact (realpart number))
		  (scheme:inexact->exact (imagpart number))))
	((> (abs number) 10000000)
	 number)
	(t (let* ((factor #.(* 1000 3 7))
		  (ratio (/ (round (* number factor)) factor)))
	     (if (= ratio number)
		 ratio
	       number)))))

(compiler:fold-constant-arguments 'scheme:inexact->exact)
(compiler:fold-constant-arguments 'scheme:exact->inexact)


;;  6.5.5  Numerical input and output

(export '( scheme:number->string scheme:string->number
	  scheme:int scheme:rat scheme:fix scheme:flo scheme:sci scheme:rect 
	  scheme:polar scheme:heur scheme:exactness scheme:radix) scheme-package)

(comment ; A more complete implementation of this is now defined in file
         ; "PNUM2S.LISP" (although it is half as fast is the one below).
;; The following incomplete version was adapted from Pseudoscheme version 159.
(defun scheme:number->string (num format)
  (case (car format)
    (scheme:heur (write-to-string num))
    (scheme:fix
     (let ((n (car-safe (cdr format))))
       (format nil "~,Vf" (or n 7) num)))   
    (otherwise 
     (cerror "Act as if the format was (HEUR)."
	     "Unimplemented format: (NUMBER->STRING '~s '~s)"
	     num format)
     (write-to-string num))))
 )

(defun scheme:string->number (string exactness radix)
  ;; %%% Note: this does not currently work for non-decimal floating point.
  (let* ((*read-base* (case (char (symbol-name radix) 0)
			((#\B) 2)
			((#\O) 8)
			((#\D) 10)
			((#\X) 16)
			(t (error "Bad radix arg ~S to STRING->NUMBER"
				  radix))))
	 (efn (case (char (symbol-name exactness) 0)
		((#\E) #'scheme:inexact->exact)
		((#\I) #'scheme:exact->inexact)
		(t (cerror "Continue."
			   "Bad exactness arg ~S to STRING->NUMBER" exactness)
		   #'identity)))
	 (*readtable* scheme-readtable))
    (funcall efn
	     (with-input-from-string (s string)
	       (read s)))))


;;  6.6  Characters

(export 'scheme:(char? char=? char<? char>? char<=? char>=?) scheme-package)
(defsubst scheme:char? (object) (characterp object))
(defsubst scheme:char<? (char1 char2) (char< char1 char2))
(defsubst scheme:char>? (char1 char2) (char> char1 char2))
(defsubst scheme:char<=? (char1 char2) (char<= char1 char2))
(defsubst scheme:char>=? (char1 char2) (char>= char1 char2))
(defsubst scheme:char=? (char1 char2) (char= char1 char2))

(export 'scheme:(char-ci? char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?) scheme-package)
(defsubst scheme:char-ci? (object) (characterp object))
(defsubst scheme:char-ci<? (char1 char2) (char-lessp char1 char2))
(defsubst scheme:char-ci>? (char1 char2) (char-greaterp char1 char2))
(defsubst scheme:char-ci<=? (char1 char2) (char-not-greaterp char1 char2))
(defsubst scheme:char-ci>=? (char1 char2) (char-not-lessp char1 char2))
(defsubst scheme:char-ci=? (char1 char2) (char-equal char1 char2))

(export 'scheme:(char-alphabetic? char-numeric? char-whitespace?) scheme-package)
(defsubst scheme:char-alphabetic? (char) (alpha-char-p char))
(defsubst scheme:char-numeric? (char) (digit-char-p char))
(defsubst scheme:char-whitespace? (char)
          (member (the character char)
                  '(#\space #\tab #\lf #\ff #\return #\rubout) :test #'eql))

(export 'scheme:(char-upper-case? char-lower-case?) scheme-package)
(defsubst scheme:char-upper-case? (letter) (upper-case-p letter))
(defsubst scheme:char-lower-case? (letter) (lower-case-p letter))

(export 'scheme:(char->integer integer->char) scheme-package)
(defsubst scheme:char->integer (char) (char-int char))
(defsubst scheme:integer->char (n) (int-char n))

(export '(lisp:char-upcase lisp:char-downcase) scheme-package)


;;  6.7  Strings

(export 'scheme:(string? make-string string-length string-ref string-set!)
        scheme-package)
(defsubst scheme:string? (object) (stringp object))
(defvar the-empty-string "")
(proclaim '(compiler:try-inline scheme:make-string))
(defun scheme:make-string (length &optional char)
  (if (= length 0)
      the-empty-string
    (if char
	(make-array length :element-type 'string-char :initial-element char)
      (make-string length))))

(defun scheme:string-length (string)
  (check-type string string)
  (length string))
(compiler:optimize-pattern (scheme:string-length t) (length 1))

(defsubst scheme:string-ref (string index)
  (char string index))
(defun scheme:string-set! (string index char)
  (check-type string string)
  (check-type char character)
  (setf (char string index) char)
  string ; returned value is "unspecified", but this is what PCS does.
  )
(compiler:optimize-pattern (scheme:string-set! t t t) (set-ar-1 1 2 3))

(export 'scheme:(string=? string<? string>? string<=? string>=?) scheme-package)
(defsubst scheme:string<? (string1 string2) (and (string< string1 string2) t))
(defsubst scheme:string>? (string1 string2) (and (string> string1 string2) t))
(defsubst scheme:string<=? (string1 string2) (and (string<= string1 string2) t))
(defsubst scheme:string>=? (string1 string2) (and (string>= string1 string2) t))
(defsubst scheme:string=? (string1 string2) (string= string1 string2))

(export 'scheme:(string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?) scheme-package)
(defsubst scheme:string-ci<? (string1 string2) (and (string-lessp string1 string2) t))
(defsubst scheme:string-ci>? (string1 string2) (and (string-greaterp string1 string2) t))
(defsubst scheme:string-ci<=? (string1 string2) (and (string-not-greaterp string1 string2) t))
(defsubst scheme:string-ci>=? (string1 string2) (and (string-not-lessp string1 string2) t))
(defsubst scheme:string-ci=? (string1 string2) (string-equal string1 string2))

(export '(global:substring global:string-append 
          scheme:string->list scheme:list->string
          scheme:string-copy scheme:string-fill!) scheme-package)
(proclaim '(inline scheme:string->list scheme:string-fill!))
(defun scheme:string->list (string) (coerce (the string string) 'list))
(defsubst scheme:list->string (chars-list)
  (coerce (the list chars-list) 'string))
(defun scheme:string-copy (string)
  (check-type string string)
  (copy-seq (the string string)))
(compiler:optimize-pattern (scheme:string-copy string) (copy-seq 1))
(defun scheme:string-fill! (string char)
  ;; the result if officially "unspecified", but PCS returns the modified string, as does FILL.
  (fill (the string string) (the character char)))
  


;;  6.8  Vectors

;; Note: vector constants are not self-evaluating.

(export '(scheme:vector? scheme:make-vector lisp:vector scheme:vector-length
                         scheme:vector-ref scheme:vector-set!)
	scheme-package)

(proclaim '(inline scheme:vector?))
(defun scheme:vector? (object)
  (and (vectorp object)
       (not (stringp object))))

(defvar the-empty-vector (vector))
(defsubst scheme:make-vector (length &optional fill)
  (if (= length 0)
      the-empty-vector ; so that empty vectors are EQV? 
    (make-array (the fixnum length) :initial-element fill)))

(defun scheme:vector-length (vector)
  (check-type vector vector)
  (length vector))
(compiler:optimize-pattern (scheme:vector-length t) (length 1))

(defsubst scheme:vector-ref (vector index)
  (aref vector index))
(defun scheme:vector-set! (vector index value)
  (check-type vector vector)
  (setf (aref vector index) value)
  vector) ; offically "unspecified"
(compiler:optimize-pattern (scheme:vector-set! t t t) (set-ar-1 1 2 3))

(export 'scheme:(vector->list list->vector vector-fill!) scheme-package)
(proclaim '(inline scheme:vector->list scheme:list->vector scheme:vector-fill!))
(defun scheme:vector->list (vector) (coerce (the vector vector) 'list))
(defun scheme:list->vector (list) (coerce (the list list) 'vector))

(defun scheme:vector-fill! (vector value)
  (fill (the vector vector) value)) ; result is "unspecified"
  


;;  6.9

(export '(scheme:procedure? lisp:apply scheme:call-with-current-continuation) scheme-package)

(defun scheme:procedure? (object)
  (let ((dtp (si:%data-type object)))
    (declare (type (integer 0 31) dtp))
    (cond ((member dtp '#.(list DTP-Function DTP-Closure DTP-Lexical-Closure DTP-U-Entry))
	   t)
	  ((eql dtp si:dtp-list)
	   (and (MEMBER (CAR object) si:function-start-symbols :TEST #'EQ)
		t))
	  (t nil))))
(compiler:fold-constant-arguments 'scheme:procedure?)


(export '(scheme:map) scheme-package)
(defun scheme:map (procedure list &rest more-lists)
       (apply #'mapcar procedure list more-lists))
(compiler:defcompiler-synonym scheme:map mapcar)

(export '(scheme:for-each) scheme-package)
(defun scheme:for-each (procedure list &rest more-lists)
          (apply #'mapc procedure list more-lists)
          unspecified)
(compiler:add-optimizer scheme:for-each for-each-opt mapc)
(defun for-each-opt (form) (cons 'mapc (rest form)))


(defmacro scheme:call-with-current-continuation (procedure)
  (let ((tag (gensym)))
    `(block ,tag
       (funcall ,procedure #'(lambda (value-to-return-from-continuation)
			       ;; Note that this funny arg name is tested in CONTINUATION?
			       (return-from ,tag value-to-return-from-continuation))))))


;;  6.10  Input and output

;;  6.10.1 Ports

(export 'scheme:( call-with-input-file call-with-output-file input-port? output-port?
		  current-input-port current-output-port
		  with-input-from-file with-output-to-file
		  open-input-file open-output-file
		  close-input-port close-output-port) scheme-package)

(defvar the-eof-object '|#!eof|)
(eval `(defconstant ,the-eof-object ',the-eof-object)) ; make it self-evaluating

(proclaim '(compiler:try-inline scheme:call-with-input-file scheme:call-with-output-file
				scheme:with-input-from-file scheme:with-output-to-file))

(defun scheme:call-with-input-file (string procedure)
  "Call PROCEDURE, passing one argument which is an input port to the file named by STRING."
  (values (with-open-file (port string :direction :input :element-type :default)
	    (funcall procedure port))))

(defun scheme:call-with-output-file (string procedure)
  "Call PROCEDURE, passing one argument which is an output port to the file named by STRING."
  (values (with-open-file (port string :direction :output)
	    (funcall procedure port))))

(defun scheme:input-port? (object)
  (and (case (%data-type object)
	 ((#.dtp-instance #.dtp-closure) (streamp object))
	 ((#.dtp-symbol) (get object 'si:io-stream-p)))
       (input-stream-p object)
       t))

(defun scheme:output-port? (object)
  (and (case (%data-type object)
	 ((#.dtp-instance #.dtp-closure) (streamp object))
	 ((#.dtp-symbol) (get object 'si:io-stream-p)))
       (output-stream-p object)
       t))

(defsubst scheme:current-input-port () *standard-input*)
(defsubst scheme:current-output-port () *standard-output*)

(defun scheme:with-input-from-file (string thunk)
  "Call PROCEDURE, passing one argument which is an input port from the file named by STRING."
  (values (with-open-file (*standard-input* string :direction :input :element-type :default)
	    (funcall thunk))))

(defun scheme:with-output-to-file (string thunk)
  "Call PROCEDURE, passing one argument which is an output port to the file named by STRING."
  (values (with-open-file (*standard-output* string :direction :output)
	    (funcall thunk))))

(defun scheme:open-input-file (filename)
  (open filename :direction :input :element-type :default))

(defun scheme:open-output-file (filename)
  (open filename :direction :output))

(defun scheme:close-input-port (port)
  (check-type port (and stream (satisfies input-stream-p)) "an input port")
  (close port)
  unspecified)
(defun scheme:close-output-port (port)
  (check-type port (and stream (satisfies output-stream-p)) "an output port")
  (close port)
  unspecified)
(compiler:optimize-pattern (scheme:close-input-port t) (close 1) (null compiler:p1value))
(compiler:optimize-pattern (scheme:close-output-port t) (close 1) (null compiler:p1value))

;;  6.10.2 Input

(export '(scheme:read scheme:read-char scheme:char-ready? scheme:eof-object?) si:scheme-package)

(defun scheme:read (&optional (port *standard-input*))
  (declare (arglist &optional port))
  (let ((*READTABLE* SCHEME-READTABLE)
	(SI:*READER-SYMBOL-SUBSTITUTIONS* NIL))
    (read-preserving-whitespace port nil the-eof-object)))

(compiler:add-optimizer scheme:read read-opt)
(defun read-opt (form)
  ;; Read into the same package the program was compiled in.
  `(scheme-read-internal ,(if (rest form) (second form) '*standard-input*)
			 ',*package*))

(defun scheme-read-internal (port pkg)
  (let ((*READTABLE* SCHEME-READTABLE)
	(SI:*READER-SYMBOL-SUBSTITUTIONS* NIL)
	(*PACKAGE* pkg))
    (read-preserving-whitespace port nil the-eof-object)))

(defun scheme:read-char (&optional (port *standard-input*))
  (declare (arglist &optional port))
  ;; Note: Scheme READ-CHAR is not supposed to echo, while Common Lisp READ-CHAR 
  ;;  is expected to echo [though CLtL is ambiguous].
  ;;  Consequently, use :TYI instead of LISP:READ-CHAR.
  (let ((value (send port :tyi nil)))
    (if (null value)
	the-eof-object
      (int-char value))))

(defun scheme:char-ready? (&optional (port *standard-input*))
  (declare (arglist &optional port))
  (cond ((send port :listen) t)
	((typep port 'SYS:BASIC-BUFFERED-INPUT-STREAM) ; need to return true at end of file
	 (if (send port :tyipeek nil)
	     nil
	   the-eof-object)) ; return EOF object for compatibility with PC Scheme
	((eq port #'si:null-stream)
	 the-eof-object)
	(t nil)))

(defsubst scheme:eof-object? (object) (eq object the-eof-object))

;;  6.10.3 Output

(export '(scheme:write scheme:display scheme:newline scheme:write-char) scheme-package)
(remprop 'scheme:display 'inline) ; temporary to undo previos inline
(remprop 'scheme:write 'inline)   ; temporary to undo previos inline

(defun scheme:write (object &optional (port (scheme:current-output-port)))
  "Write with slashification."
  (declare (arglist object &optional port))
  (let ((*print-escape* t)
	(character-attribute-table (character-attribute-table scheme-readtable)))
    (print-scheme-object object 0 port ))
  unspecified)

(defun scheme:display (object &optional (port (scheme:current-output-port)))
  "Write without slashification."
  (declare (arglist object &optional port))
  (let ((*print-escape* NIL)
	(character-attribute-table (character-attribute-table scheme-readtable)))
    (print-scheme-object object 0 port))
  (values) ; officially unspecified, PC Scheme returns non-printing object.
  )

(defun scheme:newline (&optional (port *standard-output*))
  (declare (arglist &optional port))
  (send port :tyo (char-int #\newline))
  unspecified)

(defun scheme:write-char (char &optional (port *standard-output*))
  (declare (arglist char &optional port))
  (send port :tyo (char-int char))
  unspecified)

(defun print-scheme-object (object i-prindepth stream
			    &optional (which-operations (which-operations-for-print stream)))
  ;; Like SYS:PRINT-OBJECT, except using Scheme syntax.
  (typecase object
    (fixnum (print-fixnum object stream))
    (null (write-string "()" stream))
    (symbol (cond ((eq object 't)
		   (write-string "#T" stream))
		  ((eq object the-eof-object)
		   (write-string "#!EOF" stream))
		  ((eq object the-unassigned-value)
		   (write-string "#!UNASSIGNED"))
		  (t (print-pname-string object stream t ))))
    (string
     (if (<= (array-active-length object) (array-total-size object))
	 (print-quoted-string object stream t)
       (print-random-object object stream t i-prindepth
			    which-operations)))
    (float (let ((type (type-of object)))
	     (if (or (eq type *read-default-float-format*)
		     (eq type 'short-float))
		 (print-flonum object stream)
	       (let ((*read-default-float-format* type)) ; force print-flonum to use E
		 ;; write the appropriate Scheme prefix
		 (write-char #\# stream)
		 (write-char (if (eq type 'single-float) #\S #\L) stream)
		 (print-flonum object stream)))))
    (t (let ()
	 (unless (eq #'sys:print-object #'print-scheme-object)
	   (bind '#,(locf #'sys:print-object) #'print-scheme-object))
	 (dont-optimize
	   (funcall '#,#'sys:print-object object i-prindepth stream which-operations))))))

;;  6.10.4  User Interface

(export '(scheme:load scheme:transcript-on scheme:transcript-off) scheme-package)

(defun scheme:load (filename)
  "Load a Scheme file (either source or object)."
  (with-scheme-on
    (lisp:load filename)))

(defsubst scheme:transcript-on (filename) (dribble-all filename))
(defsubst scheme:transcript-off () (dribble-end))

;;; ---------

(pushnew ':SCHEME *features*)
