xref: /dports/math/reduce/Reduce-svn5758-src/generic/emacs/REDUCE/esl.el

;;; esl.el --- ESL (Emacs Standard LISP) -*- lexical-binding:t -*-

;; Copyright (C) 2017-2018 Francis J. Wright

;; Author: Francis J. Wright <https://sourceforge.net/u/fjwright>
;; Created: 17 Nov 2017
;; Version: $Id: esl.el 4800 2018-10-11 17:45:34Z fjwright $
;; Keywords: languages
;; Homepage: https://sourceforge.net/p/reduce-algebra/code/HEAD/tree/trunk/generic/emacs/REDUCE/
;; Package-Version: 0.1
;; Package-Requires: ((emacs "25") cl-lib)

;; This file is not part of GNU Emacs.

;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of
;; the License, or (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This file aims to provide an emulation of most of Standard LISP
;; (enough to run REDUCE) as an upper-case LISP (to keep it distinct
;; from the underlying Emacs Lisp). However, lambda must be kept lower
;; case.  READ and FEXPRs are not implemented, and the only way to
;; input Standard LISP is to use the Emacs Lisp reader with Emacs Lisp
;; syntax.

;; Some functions that correspond to Emacs Lisp special forms or subrs
;; (built-in functions) must be defined as macros rather than aliases,
;; either to run correctly or so that REDUCE files can be compiled.

;;; Primitive Data Types
;;; ====================

;; integer -- Elisp integers are of fixed size (61 bits) but Slisp
;; integers are of arbitrary size, which I currently provide by
;; calling functions in the GNU Emacs Calculator ("Calc") package by
;; Dave Gillespie.

;; floating -- 1. is an integer in Elisp but a float in
;; Slisp.  Otherwise probably OK.

;; id -- symbol in Elisp.  The Slisp escape chacacter is ! but the
;; Elisp escape character is \.  This difference is handled by EXPLODE
;; and COMPRESS, and would need to be handled by READ if implemented.
;; In Slisp, lower case letters are automatically converted to upper
;; case when the !*RAISE flag is T.  But upper case letters are
;; automatically output as lower case when the !*LOWER flag is T.

;; string -- To include a double quote character in a string in Slisp
;; double it, but in Elisp escaped it with \.  This difference would
;; need to be handled by READ if implemented.

;; dotted-pair, vector, function-pointer -- probably OK.

;; T and NIL -- Elisp only recognises t and nil, so T and NIL are
;; implemented as constants set to t and nil.  They are also converted
;; to lower case by COMPRESS.

;; ftype -- in Slisp, the set of ids {EXPR, FEXPR, MACRO} represents
;; the class of definable function types.  FEXPRs are not implemented.

;; comments -- in Slisp these begin with % but in Elisp they begin
;; with ;.  This difference would need to be handled by READ if
;; implemented.

;; REMARK -- very little of REDUCE is written in Lisp notation and
;; RLISP uses its own reader.  I only need to be able to read the Lisp
;; bootstrap code, boot.sl, that defines RLISP, so I have edited
;; boot.sl as boot.el to use upper case and Emacs Lisp read syntax.
;; (Syntax tables are not used by the Emacs Lisp reader, which has its
;; own built-in syntactic rules which cannot be changed!)

;;; Code:

;; I use the GNU Emacs Common Lisp Emulation library mainly to support
;; the Standard LISP `PROG' form, but I also need it in Emacs 25 for
;; `GENSYM'.  Also, Emacs 26 provides the `cxxxxr' family of functions
;; but Emacs 25 only provides `cxxr', so I use the Standard LISP
;; `CXXXXR' functions, which I have defined exactly as in Emacs 26.

(require 'cl-lib)
(require 'seq)				 ; necessary in batch mode -- no idea why!

;; I also use the GNU Emacs Calc library for arbitrary length integers.

(require 'calc)
(require 'calc-ext)

;;; System GLOBAL Variables
;;; =======================

;; Defined early to keep the Emacs Lisp compiler happy.  (This file
;; should be compiled.)

(defvar *COMP nil
  "*COMP = NIL global
The value of !*COMP controls whether or not PUTD compiles the
function defined in its arguments before defining it. If !*COMP is
NIL the function is defined as an EXPR. If !*COMP is something
else the function is first compiled. Compilation will produce certain
changes in the semantics of functions particularly FLUID type access.")

(put '*COMP 'GLOBAL t)

(defvar EMSG* nil
  "EMSG* = NIL global
Will contain the MESSAGE generated by the last ERROR call.")

(put 'EMSG* 'GLOBAL t)

(defconst $EOF$ :$EOF$
  "$EOF$ = <an uninterned identifier> global
The value of !$EOF!$ is returned by all input functions when the end
of the currently selected input file is reached.")

(put '$EOF$ 'GLOBAL t)

(defconst $EOL$ :$EOL$
  "$EOL$ = <an uninterned identifier> global
The value of !$EOL!$ is returned by READCH when it reaches the
end of a logical input record. Likewise PRINC will terminate its
current line (like a call to TERPRI) when !$EOL!$ is its argument.")

(put '$EOL$ 'GLOBAL t)

(defvar *GC nil						; currently ignored!
  "*GC = NIL global
!*GC controls the printing of garbage collector messages. If NIL
no indication of garbage collection may occur. If non-NIL various
system dependent messages may be displayed.")

(put '*GC 'GLOBAL t)

(with-no-warnings			   ; suppress warning about lack of prefix
  (defconst NIL nil
	"NIL = NIL global
NIL is a special global variable. It is protected from being
modified by SET or SETQ."))

(put 'NIL 'GLOBAL t)

(defvar *RAISE t					  ; ESL uses upper case internally
  "*RAISE = NIL global
If !*RAISE is non-NIL all characters input through Standard LISP
input/output functions will be raised to upper case. If !*RAISE is
NIL characters will be input as is.")

(put '*RAISE 'GLOBAL t)

(with-no-warnings			   ; suppress warning about lack of prefix
  (defconst T t
	"T = T global
T is a special global variable. It is protected from being
modified by SET or SETQ."))

(put 'T 'GLOBAL t)

;; Not Standard LISP but PSL and assumed by REDUCE:
(defvar *ECHO nil
  "*echo = [Initially: nil] switch
The switch echo is used to control the echoing of input. When (on echo)
is placed in an input file, the contents of the file are echoed on the standard
output device. Dskin does not change the value of *echo, so one may say
(on echo) before calling dskin, and the input will be echoed.")

(defvar *REDEFMSG t
  "*redefmsg = [Initially: t] switch
If *redefmsg is not nil, the message
*** Function `FOO' has been redefined
is printed whenever a function is redefined by PUTD.")
;; Should this also apply to DE & DM?

;;; FUNCTIONS
;;; =========


;;; Elementary Predicates
;;; =====================

;; (defmacro ATOM (u)				   ; boot.el does not compile if alias
;;   "ATOM(U:any):boolean eval, spread
;; Returns T if U is not a pair.
;; EXPR PROCEDURE ATOM(U);
;;    NULL PAIRP U;"
;;   (declare (debug t))
;;   `(or (atom ,u) (math-integerp ,u)))

;; Above macro doesn't work, I think because `u' gets evaluated twice.

(defun ATOM (u)
  "ATOM(U:any):boolean eval, spread
Returns T if U is not a pair.
EXPR PROCEDURE ATOM(U);
   NULL PAIRP U;"
  (or (atom u) (math-integerp u)))

(defalias 'CODEP 'functionp
  "CODEP(U:any):boolean eval, spread
Returns T if U is a function-pointer.")

(defun CONSTANTP (u)
  "CONSTANTP(U:any):boolean eval, spread
Returns T if U is a constant (a number, string, function-pointer, or vector).
EXPR PROCEDURE CONSTANTP(U);
   NULL OR(PAIRP U, IDP U);"
  (null (or (symbolp u) (PAIRP u))))

(defalias 'EQ 'eq
  "EQ(U:any, V:any):boolean eval, spread
Returns T if U points to the same object as V. EQ is not a reliable
comparison between numeric arguments.")

(defun EQN (u v)
  "EQN(U:any, V:any):boolean eval, spread
Returns T if U and V are EQ or if U and V are numbers and have
the same value and type."
  (or (eql u v) (math-equal u v)))

(defalias 'EQUAL 'equal
  "EQUAL(U:any, V:any):boolean eval, spread
Returns T if U and V are the same. Dotted-pairs are compared
recursively to the bottom levels of their trees. Vectors must
have identical dimensions and EQUAL values in all
positions. Strings must have identical characters. Function
pointers must have EQ values. Other atoms must be EQN equal.")

(defalias 'FIXP 'math-integerp
  "FIXP(U:any):boolean eval, spread
Returns T if U is an integer (a fixed number).")

(defalias 'FLOATP 'floatp
  "FLOATP(U:any):boolean eval, spread
Returns T if U is a floating point number.")

(defalias 'IDP 'symbolp
  "IDP(U:any):boolean eval, spread
Returns T if U is an id.")

(defun MINUSP (u)
  "MINUSP(U:any):boolean eval, spread
Returns T if U is a number and less than 0. If U is not a number
or is a positive number, NIL is returned.
EXPR PROCEDURE MINUSP(U);
   IF NUMBERP U THEN LESSP(U, 0) ELSE NIL;"
  (cond ((numberp u) (< u 0))
		((math-integerp u) (math-negp u))))

(defalias 'NULL 'null
  "NULL(U:any):boolean eval, spread
Returns T if U is NIL.
EXPR PROCEDURE NULL(U);
   U EQ NIL;")

(defun NUMBERP (u)
  "NUMBERP(U:any):boolean eval, spread
Returns T if U is a number (integer or floating).
EXPR PROCEDURE NUMBERP(U);
   IF OR(FIXP U, FLOATP U) THEN T ELSE NIL;"
  (or (numberp u) (math-integerp u)))

(defun ONEP (u)
  "ONEP(U:any):boolean eval, spread.
Returns T if U is a number and has the value 1 or 1.0. Returns NIL
otherwise.
EXPR PROCEDURE ONEP(U);
   OR(EQN(U, 1), EQN(U, 1.0));"
  (if (math-integerp u)
	  (math-equal u 1)
	(eql u 1.0)))

(defun PAIRP (u)
  "PAIRP(U:any):boolean eval, spread
Returns T if U is a dotted-pair."
  (and (consp u) (not (math-integerp u))))

(defalias 'STRINGP 'stringp
  "STRINGP(U:any):boolean eval, spread
Returns T if U is a string.")

(defalias 'VECTORP 'vectorp
  "VECTORP(U:any):boolean eval, spread
Returns T if U is a vector.")

(defun ZEROP (u)
  "ZEROP(U:any):boolean eval, spread
Returns T if U is a number and has the value 0 or 0.0. Returns
NIL otherwise.
EXPR PROCEDURE ZEROP(U);
   OR(EQN(U, 0), EQN(U, 0.0));"
  (cond ((numberp u) (zerop u))
		((math-integerp u) (math-zerop u))))


;;; Functions on Dotted-Pairs
;;; =========================

(defalias 'CAR 'car
  "CAR(U:dotted-pair ):any eval, spread
CAR(CONS(a, b)) --> a. The left part of U is returned. The type
mismatch error occurs if U is not a dotted-pair.")

(defalias 'CDR 'cdr
  "CDR(U:dotted-pair ):any eval, spread
CDR(CONS(a, b)) --> b. The right part of U is returned. The type
mismatch error occurs if U is not a dotted-pair.")

;; The composites of CAR and CDR are supported up to 4 levels. The
;; following code is copied from "subr.el" with minor modifications.

(eval-and-compile	 ; needed to compile calls of CX..XR in this file.
(defun esl--compiler-macro-CXXR (form x)
  (let* ((head (car form))
         (n (downcase (symbol-name head)))
		 (head (intern-soft n))
         (i (- (length n) 2)))
    (if (not (string-match "c[ad]+r\\'" n))
        (if (and (fboundp head) (symbolp (symbol-function head)))
            (esl--compiler-macro-CXXR (cons (symbol-function head) (cdr form))
                                     x)
          (error "Compiler macro for CXXR applied to non-CXXR form"))
      (while (> i (match-beginning 0))
        (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x))
        (setq i (1- i)))
      x))))

(defun CAAR (x)
  "Return the car of the car of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (car x)))

(defun CADR (x)
  "Return the car of the cdr of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (cdr x)))

(defun CDAR (x)
  "Return the cdr of the car of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (car x)))

(defun CDDR (x)
  "Return the cdr of the cdr of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (cdr x)))

(defun CAAAR (x)
  "Return the `car' of the `car' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (car (car x))))

(defun CAADR (x)
  "Return the `car' of the `car' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (car (cdr x))))

(defun CADAR (x)
  "Return the `car' of the `cdr' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (cdr (car x))))

(defun CADDR (x)
  "Return the `car' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (cdr (cdr x))))

(defun CDAAR (x)
  "Return the `cdr' of the `car' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (car (car x))))

(defun CDADR (x)
  "Return the `cdr' of the `car' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (car (cdr x))))

(defun CDDAR (x)
  "Return the `cdr' of the `cdr' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (cdr (car x))))

(defun CDDDR (x)
  "Return the `cdr' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (cdr (cdr x))))

(defun CAAAAR (x)
  "Return the `car' of the `car' of the `car' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (car (car (car x)))))

(defun CAAADR (x)
  "Return the `car' of the `car' of the `car' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (car (car (cdr x)))))

(defun CAADAR (x)
  "Return the `car' of the `car' of the `cdr' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (car (cdr (car x)))))

(defun CAADDR (x)
  "Return the `car' of the `car' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (car (cdr (cdr x)))))

(defun CADAAR (x)
  "Return the `car' of the `cdr' of the `car' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (cdr (car (car x)))))

(defun CADADR (x)
  "Return the `car' of the `cdr' of the `car' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (cdr (car (cdr x)))))

(defun CADDAR (x)
  "Return the `car' of the `cdr' of the `cdr' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (cdr (cdr (car x)))))

(defun CADDDR (x)
  "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (car (cdr (cdr (cdr x)))))

(defun CDAAAR (x)
  "Return the `cdr' of the `car' of the `car' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (car (car (car x)))))

(defun CDAADR (x)
  "Return the `cdr' of the `car' of the `car' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (car (car (cdr x)))))

(defun CDADAR (x)
  "Return the `cdr' of the `car' of the `cdr' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (car (cdr (car x)))))

(defun CDADDR (x)
  "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (car (cdr (cdr x)))))

(defun CDDAAR (x)
  "Return the `cdr' of the `cdr' of the `car' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (cdr (car (car x)))))

(defun CDDADR (x)
  "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (cdr (car (cdr x)))))

(defun CDDDAR (x)
  "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (cdr (cdr (car x)))))

(defun CDDDDR (x)
  "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X."
  (declare (compiler-macro esl--compiler-macro-CXXR))
  (cdr (cdr (cdr (cdr x)))))

(defalias 'CONS 'cons
  "CONS(U:any, V:any):dotted-pair eval, spread
Returns a dotted-pair which is not EQ to anything and has U as its
CAR part and V as its CDR part.")

(defalias 'LIST 'list
  "LIST([U:any]):list noeval, nospread, or macro
A list of the evaluation of each element of U is returned. The order of
evaluation need not be first to last as the following definition implies.
FEXPR PROCEDURE LIST(U);
   EVLIS U;")

(defun RPLACA (u v)
  "RPLACA(U:pair, V:any):pair eval, spread
The car of the pair U is replaced by V and the modified pair U is
returned.  A type mismatch error occurs if U is not a pair."
  (setcar u v)
  u)

(defun RPLACD (u v)
  "RPLACD(U:pair, V:any):pair eval, spread
The cdr of the pair U is replaced by V and the modified pair U is
returned.  A type mismatch error occurs if U is not a pair."
  (setcdr u v)
  u)

;; PSL functions

(defalias 'FIRST 'car
  "A PSL alternative function name used occasionally in REDUCE.")
(defsubst SECOND (x)
  "A PSL alternative function name used occasionally in REDUCE."
  (CADR x))
(defsubst THIRD (x)
  "A PSL alternative function name used occasionally in REDUCE."
  (CADDR x))
(defsubst FOURTH (x)
  "A PSL alternative function name used occasionally in REDUCE."
  (CADDDR x))
(defalias 'REST 'cdr
  "A PSL alternative function name used occasionally in REDUCE.")

(defalias 'LASTPAIR 'last
  "(lastpair L:pair): any expr
Returns the last pair of a L. It is often useful to think of this
as a pointer to the last element for use with destructive
functions such as rplaca. If L is not a pair then a type mismatch
error occurs.
(de lastpair (l)
	(if (or (atom l) (atom (cdr l)))
		l
	  (lastpair (cdr l))))")

(defsubst LASTCAR (l)
  "(lastcar L:pair): any expr
Returns the last element of the pair L. A type mismatch error
results if L is not a pair."
  (if (atom l) l (car (last l))))

(defsubst NTH (l n)
  "(nth L:pair N:integer): any expr
Returns the Nth element of the list L. If L is atomic or contains
fewer than N elements, an out of range error occurs.
(de nth (l n)
	(cond ((null l) (range-error))
		  ((onep n) (first l))
		  (t (nth (rest l) (sub1 n)))))
Note that this definition is not compatible with Common LISP. The
Common LISP definition reverses the arguments and defines the car
of a list to be the \"zeroth\" element."
  (nth (1- n) l))

(defsubst PNTH (l n)
  "(pnth L:list N:integer): any expr
Returns a list starting with the nth element of the list L. Note
that the result is a pointer to the nth element of L, a
destructive function like rplaca can be used to modify the
structure of L. If L is atomic or contains fewer than N elements,
an out of range error occurs.
(de pnth (l n)
	(cond ((onep n) l)
		  ((not (pairp l)) (range-error))
		  (t (pnth (rest l) (sub1 n)))))"
  (nthcdr (1- n) l))


;;; Identifiers
;;; ===========

(defun esl-string-to-bigint (s)
  "Convert string S to a bigint."
  (math-read-number s))

(defun COMPRESS (u)
  "COMPRESS(U:id-list):{atom-vector} eval, spread
U is a list of single character identifiers which is built into a Standard
LISP entity and returned. Recognized are numbers, strings, and
identifiers with the escape character prefixing special characters. The
formats of these items appear in \"Primitive Data Types\" section 2.1
on page 3. Identifiers are not interned on the OBLIST. Function
pointers may be compressed but this is an undefined use. If an entity
cannot be parsed out of U or characters are left over after parsing
an error occurs:
***** Poorly formed atom in COMPRESS

In ESL: Down-case LAMBDA, NIL, QUOTE and T (but not !T).
Retain ! preceding an identifier beginning with : to prevent it
becoming a keyword, avoiding mangling `:', `:=' and the prompt.
Also, remove ! preceding an identifier and downcase the
identifier to facilitate direct access to Emacs Lisp symbols."
  ;; Concatenate the characters into a string and then handle any !
  ;; characters as follows:
  ;; A string begins with " and should retain any ! characters without
  ;; change.
  ;; A number begins with - or a digit and should not contain any !
  ;; characters.
  ;; Otherwise, assume an identifier. Any ! characters should be
  ;; deleted, except that !! should be replaced by !.
  ;; However, retain a leading !: (except in special cases) to prevent
  ;; a Standard LISP identifier being an Elisp keyword.  This should
  ;; perhaps be handled in a more consistent way!
  (if (equal u '(T)) 't
	(let* ((s (mapconcat #'symbol-name u ""))
		   (s0 (aref s 0)))
	  (cond ((eq s0 ?\")				; STRING
			 ;; In Standard Lisp, "" in a string represents ":
			 (replace-regexp-in-string "\"\"" "\"" (substring s 1 -1)))
			((or (eq s0 ?-)
				 (and (>= s0 ?0) (<= s0 ?9))) ; NUMBER
			 (if (string-match "\\." s)
				 ;; Number is a float. (Emacs does not accept .E as in
				 ;; 123.E-2 so delete such a ".".)
				 (string-to-number (replace-regexp-in-string "\\.E" "E" s))
			   ;; Number is a (possibly big) integer.
			   (esl-string-to-bigint s)))
			(t							; IDENTIFIER
			 (let ((l (length s)) (i 0) (ss nil) e)
			   ;; Retain leading !: in "!:..." but not in "!:", "!:!="
			   ;; or "!:! ", which is used in the REDUCE prompt:
			   (if (and (eq s0 ?!) (eq (aref s 1) ?:) (> l 2)
						(not (equal s "!:! ")) (not (equal s "!:!=")))
				   (setq i 2 ss '(?: ?!)))
			   (while (< i l)			; delete ! but !! --> !
				 (if (eq (setq e (aref s i)) ?!)
					 (when (eq (aref s (1+ i)) ?!)
					   (push ?! ss)
					   (setq i (1+ i)))
				   (push e ss))
				 (setq i (1+ i)))
			   (setq ss (apply #'string (reverse ss)))
			   (if (member ss '("LAMBDA" "NIL" "QUOTE"))
				   (setq ss (downcase ss))
				 (if (and (eq (aref ss 0) ?) (> (length ss) 1))
					 (setq ss (downcase (substring ss 1)))))
			   (make-symbol ss)))))))	; uninterned symbol

(defun esl-bigint-p (b)
  "Return t if B is a bigint."
  (math-integerp b))

(defun esl-bigint-to-string (b)
  "Convert bigint B to a string."
  (math-format-number b))

(defun EXPLODE (u)
  "EXPLODE(U:{atom}-{vector}):id-list eval, spread
Returned is a list of interned characters representing the characters to
print of the value of U. The primitive data types have these formats:
integer -- Leading zeroes are suppressed and a minus sign prefixes the
  digits if the integer is negative.
floating -- The value appears in the format [-]0.nn...nnE[-]mm if the
  magnitude of the number is too large or small to display in
  [-]nnnn.nnnn format. The crossover point is determined by the
  implementation.
id -- The characters of the print name of the identifier are produced
  with special characters prefixed with the escape character.
string -- The characters of the string are produced surrounded by
  double quotes \"...\".
function-pointer -- The value of the function-pointer is created as a
  list of characters conforming to the conventions of the system site.
The type mismatch error occurs if U is not a number, identifier,
string, or function-pointer."
  (seq-map
   (lambda (c) (intern (string c)))
   (cond ((or (stringp u) (numberp u)) (prin1-to-string u))
		 ((esl-bigint-p u) (esl-bigint-to-string u))
		 ;; Assume identifier -- must insert ! before a leading digit and
		 ;; before any special characters in string without \ escapes:
		 (t (let* ((s (prin1-to-string u t)) (l (length s))
				   (i 0) (ss nil) e)
			  (while (< i l)
				(setq e (aref s i))
				(if (not (or (and (not (eq i 0)) (>= e ?0) (<= e ?9))
							 (and (>= e ?A) (<= e ?Z))
							 (and (>= e ?a) (<= e ?z)))) ; unnecessary as ids UC?
					(push ?! ss))
				(push e ss)
				(setq i (1+ i)))
			  (reverse ss))))))

(defalias 'GENSYM (if (fboundp 'gensym) 'gensym 'cl-gensym)
  ;; gensym was not defined before Emacs 26
  "GENSYM():identifier eval, spread
Creates an identifier which is not interned on the OBLIST and
consequently not EQ to anything else.")

(defun INTERN (u)
  "INTERN(U:{id,string}):id eval, spread
INTERN searches the OBLIST for an identifier with the same print
name as U and returns the identifier on the OBLIST if a match is
found. Any properties and global values associated with U may be
lost. If U does not match any entry, a new one is created and
returned. If U has more than the maximum number of characters
permitted by the implementation (the minimum number is 24) an
error occurs:
***** Too many characters to INTERN"
  (intern (if (symbolp u) (symbol-name u) u)))

(defun REMOB (u)
  "REMOB(U:id):id eval, spread
If U is present on the OBLIST it is removed. This does not affect U
having properties, flags, functions and the like. U is returned."
  (unintern u nil)
  u)


;;; Property List Functions
;;; =======================

;; In file "rlisp/superv.red" is the statement
;;
;; FLAG('(DEFLIST FLAG FLUID GLOBAL REMFLAG REMPROP UNFLUID),'EVAL);
;;
;; which (I think) means that the functions listed are evaluated even
;; after `ON DEFN', which is necessary to ensure that some source code
;; reads correctly.  However, `REMPROP' is usually followed by `PUT'
;; to reinstate whatever property was removed, but `PUT' is not
;; flagged `EVAL', so this reinstatement doesn't happen because
;; evaluating `PUT' at the wrong time can cause similar problems,
;; e.g. with `rlisp88'.  Hence, viewing code with `ON DEFN' can break
;; subsequent code.  For example, inputting "rlisp/module.red" with
;; `ON DEFN' removes the `STAT' property from `LOAD_PACKAGE', which
;; then no longer works correctly.  This is a major problem for the
;; way I generate fasl files!
;;
;; I therefore provide a workaround to make the functions DEFLIST,
;; FLAG, REMFLAG and REMPROP save the property list of any identifier
;; before modifying it if it has not already been saved, and provide a
;; function to reinstate the saved property list.  I use this facility
;; when generating fasl files and in `OFF DEFN' (see "eslrend.red"),
;; so that ESL REDUCE should be immune to this `ON DEFN' side-effect.
;;
;; However, this facility only applies to reading REDUCE code and must
;; be disabled when loading a Lisp file, i.e. when the variable
;; `load-in-progress' is non-nil.  This is particularly important when
;; building REDUCE.

(defvar *DEFN nil)

(defvar esl--saved-plist-alist nil
  "Association list of symbols and their saved property lists.
Its value should normally be nil, except while ON DEFN.")

(defun esl--save-plist (symbol)
  "Save property list of symbol SYMBOL if not already saved.
Do not do this if Lisp file load in progress."
  (or load-in-progress
	  (assq symbol esl--saved-plist-alist)
	  (push (cons symbol (copy-tree (symbol-plist symbol)))
			esl--saved-plist-alist)))

(defun esl-reinstate-plists ()
  "Reinstate all saved property lists.
Do not do this if Lisp file load in progress."
  (unless load-in-progress
	(mapc (lambda (s) (setplist (car s) (cdr s)))
		  esl--saved-plist-alist)
	(setq esl--saved-plist-alist nil)))


(defun FLAG (u v)
  "FLAG(U:id-list, V:id):NIL eval, spread
U is a list of ids which are flagged with V. The effect of FLAG is
that FLAGP will have the value T for those ids of U which were
flagged. Both V and all the elements of U must be identifiers or the
type mismatch error occurs."
  (if *DEFN (mapc #'esl--save-plist u))
  (mapc (lambda (x) (put x v t)) u)
  nil)

(defun FLAGP (u v)
  "FLAGP(U:any, V:any):boolean eval, spread
Returns T if U has been previously flagged with V, else NIL. Returns
NIL if either U or V is not an id."
  (if (and (symbolp u) (symbolp v)) (get u v)))

(defun GET (u ind)
  "GET(U:any, IND:id):any eval, spread
Returns the property associated with indicator IND from the
property list of U. If U does not have indicator IND, NIL is
returned.  GET cannot be used to access functions (use GETD
instead)."
  ;; MUST return nil if u is not a symbol.
  (if (symbolp u) (get u ind)))

(defmacro PUT (u ind prop)
  "PUT(U:id, IND:id, PROP:any):any eval, spread
The indicator IND with the property PROP is placed on the
property list of the id U. If the action of PUT occurs, the value
of PROP is returned. If either of U and IND are not ids the type
mismatch error will occur and no property will be placed. PUT
cannot be used to define functions (use PUTD instead)."
  `(put ,u ,ind ,prop))

(defun REMFLAG (u v)
  "REMFLAG(U:any-list, V:id):NIL eval, spread
Removes the flag V from the property list of each member of the
list U. Both V and all the elements of U must be ids or the type
mismatch error will occur."
  (if *DEFN (mapc #'esl--save-plist u))
  (mapc (lambda (x) (cl-remprop x v)) u)
  nil)

(defun REMPROP (u ind)
  "REMPROP(U:any, IND:any):any eval, spread
Removes the property with indicator IND from the property list of U.
Returns the removed property or NIL if there was no such indicator."
  (prog1
	  (get u ind)
	(if *DEFN (esl--save-plist u))
	(cl-remprop u ind)))


;;; Function Definition
;;; ===================

;; NOTE that Standard Lisp macros are nospread and therefore take a
;; single parameter that gets the list of actual arguments, so `DM'
;; and `PUTD' must convert the macro parameter into an &rest
;; parameter.  Also, when a Standard Lisp macro is called it receives
;; its name as its first argument, i.e. the single parameter evaluates
;; to the COMPLETE function call, so `DM' and `PUTD' must modify the
;; macro argument list within the body lambda expression.

;; Ref. Standard LISP Report, page 9: "When a macro invocation is
;; encountered, the body of the macro, a lambda expression, is invoked
;; as a NOEVAL, NOSPREAD function with the macro's invocation bound as
;; a list to the macros single formal parameter."

;; REDUCE handles macros specially, assuming they are Standard LISP
;; macros, whereas ESL functions that are actually defined as Emacs
;; Lisp macros need to be handled by REDUCE as if they were
;; EXPRs. Therefore, it is important that the function type defaults
;; to EXPR, so only macros defined using DM or PUTD are given the
;; property ESL--FTYPE with value MACRO. The ESL--FTYPE property is
;; required so that macros defined in REDUCE can be distinguished from
;; Emacs Lisp macros. Normal functions defined using DE or PUTD are
;; given the property ESL--FTYPE with value EXPR just for symmetry,
;; but this property value is not actually used by GETD.

(defmacro DE (fname params fn)
  "DE(FNAME:id, PARAMS:id-list, FN:any):id noeval, nospread
The function FN with the formal parameter list PARAMS is added to
the set of defined functions with the name FNAME. Any previous
definitions of the function are lost. The function created is of
type EXPR. If the !*COMP variable is non-NIL, the EXPR is first
compiled. The name of the defined function is returned.
FEXPR PROCEDURE DE(U);
   PUTD(CAR U, 'EXPR, LIST('LAMBDA, CADR U, CADDR U));"
  (declare (debug (&define name lambda-list def-body)))
  `(progn
	 (put ',fname 'ESL--FTYPE 'EXPR)
	 (defun ,fname ,params ,fn)
	 ,@(if *COMP  ; splice in list of content or nil.
		   ;; It makes no sense to include code to compile this
		   ;; function when the function definition is being compiled
		   ;; into a fasl file, so examine *COMP when the macro is
		   ;; expanded/compiled and ensure that *COMP is nil when fasl
		   ;; files are being generated.
		   `((let ((byte-compile-warnings '(not free-vars unresolved)))
			   (byte-compile ',fname))))
	 ',fname))

;; *** I'm hoping df is not actually required! ***
;; DF(FNAME:id, PARAM:id-list, FN:any):id noeval, nospread
;; The function FN with formal parameter PARAM is added to the set
;; of defined functions with the name FNAME. Any previous definitions
;; of the function are lost. The function created is of type FEXPR. If
;; the !*COMP variable is T the FEXPR is first compiled. The name
;; of the defined function is returned.
;; FEXPR PROCEDURE DF(U);
;;    PUTD(CAR U, 'FEXPR, LIST('LAMBDA, CADR U, CADDR U));

(defmacro DM (mname param fn)
  "DM(MNAME:id, PARAM:id-list, FN:any):id noeval, nospread
The macro FN with the formal parameter PARAM is added to the set
of defined functions with the name MNAME. Any previous
definitions of the function are overwritten. The function created
is of type MACRO. The name of the macro is returned.
FEXPR PROCEDURE DM(U);
   PUTD(CAR U, 'MACRO, LIST('LAMBDA, CADR U, CADDR U));"
  (declare (debug (&define name lambda-list def-body)))
  `(progn
	 (put ',mname 'ESL--FTYPE 'MACRO)
	 ;; Save the (uncompiled) SL macro form:
	 (put ',mname 'ESL--MACRO '(MACRO lambda ,param ,fn))
	 ;; param must be a list containing a single identifier, which
	 ;; must therefore be spliced into the macro definition.
	 (defmacro ,mname (&rest ,@param)	; spread the arguments
	   ;; Include macro name as first arg:
	   (setq ,@param (cons ',mname ,@param))
	   ,fn)
	 ,@(if *COMP						; see DE
	 	   `((let ((byte-compile-warnings '(not free-vars unresolved)))
	 		   (byte-compile ',mname))))
	 ',mname))

(defun GETD (fname)
  ;; BEWARE that this definition may not work properly for functions
  ;; defined in Emacs Lisp, which will generally contain a
  ;; documentation string and then multiple body forms!
  "GETD(FNAME:any):{NIL, dotted-pair} eval, spread
If FNAME is not the name of a defined function, NIL is returned. If
FNAME is a defined function then the dotted-pair
\(TYPE:ftype . DEF:{function-pointer, lambda})
is returned."
  (and (symbolp fname)
	   (let ((def (symbol-function fname)))
		 (if def
			 (if (eq (get fname 'ESL--FTYPE) 'MACRO)
				 ;; Return the (uncompiled) SL macro form:
				 (get fname 'ESL--MACRO)
			   (cons 'EXPR def))))))

(defun PUTD (fname type body)
  "PUTD(FNAME:id, TYPE:ftype, BODY:function):id eval, spread
Creates a function with name FNAME and definition BODY of type
TYPE. If PUTD succeeds the name of the defined function is
returned. The effect of PUTD is that GETD will return a
dotted-pair with the functions type and definition. Likewise the
GLOBALP predicate will return T when queried with the function
name. If the function FNAME has already been declared as a
GLOBAL or FLUID variable the error:
***** FNAME is a non-local variable
occurs and the function will not be defined. If function FNAME
already exists a warning message will appear:
*** FNAME redefined
The function defined by PUTD will be compiled before definition if
the !*COMP global variable is non-NIL."
  (if (or (get fname 'GLOBAL)			; only if explicitly declared
		  (FLUIDP fname))
	  (error "%s is a non-local variable" fname))
  (if (and *REDEFMSG (symbol-function fname))
	  (message "*** %s redefined" fname))
  ;; body = (lambda (u) body-form) or function object
  (fset fname (if (eq type 'MACRO)
				  (let ((u (CAADR body))) ; must be a symbol!
					;; Save the (uncompiled) SL macro form:
					(put fname 'ESL--MACRO (cons 'MACRO body))
					`(macro
					  lambda (&rest ,u)	; spread the arguments
					  ;; Include macro name as first arg:
					  (setq ,u (cons ',fname ,u))
					  ;; Splice in body-form:
					  ,@(cddr body)))
				body))
  (put fname 'ESL--FTYPE type)
  (if *COMP
  	  (let ((byte-compile-warnings '(not free-vars unresolved)))
  		(byte-compile fname)))
  fname)

(defun REMD (fname)
  "REMD(FNAME:id):{NIL, dotted-pair} eval, spread
Removes the function named FNAME from the set of defined
functions. Returns the (ftype . function) dotted-pair or NIL as
does GETD. The global/function attribute of FNAME is removed and
the name may be used subsequently as a variable."
  (let ((def (GETD fname)))
	(when def
	  (fmakunbound fname)
	  (cl-remprop fname 'ESL--FTYPE))
	def))


;;; Variables and Bindings
;;; ======================

(defun esl--fluid (x)
  "If id X is already GLOBAL then display a warning; otherwise flag X as FLUID."
  (if (GLOBALP x)
	  (lwarn '(esl fluid) :error
			 "GLOBAL %s cannot be changed to FLUID" x)
	(put x 'FLUID t)))

(defmacro FLUID (idlist)
  "FLUID(IDLIST:id-list):NIL eval, spread
The ids in IDLIST are declared as FLUID type variables (ids not
previously declared are initialized to NIL). Variables in IDLIST
already declared FLUID are ignored. Changing a variable's type
from GLOBAL to FLUID is not permissible and results in the error:
***** ID cannot be changed to FLUID"
  ;; A warning, as for PSL, is more convenient than an error!
  (if (memq (car idlist) '(quote QUOTE)) ; QUOTE (UC) should now be redundant
	  ;; Assume a top-level call that needs to output `defvar' forms
	  ;; at compile time.
	  (cons 'prog1
			(cons nil
				  (mapcan
				   (lambda (x)
					 `((with-no-warnings ; suppress warning about lack of prefix
						 (defvar ,x nil "Standard LISP fluid variable."))
					   (unless (FLUIDP ',x)
						 (esl--fluid ',x))))
				   (eval idlist))))
	;; Assume a run-time call that need not output `defvar' forms.
	`(prog1 nil
	   (mapc
		(lambda (x)
		  (unless (FLUIDP x)
			(esl--fluid x)
			(set x nil)))
		,idlist))))

(defun FLUIDP (u)
  "FLUIDP(U:any):boolean eval, spread
If U has been declared FLUID (by declaration only) T is returned,
otherwise NIL is returned."
  (get u 'FLUID))

(defun esl--global (x)
  "If id X is already FLUID then display a warning; otherwise flag X as GLOBAL."
  (if (FLUIDP x)
	  (lwarn '(esl global) :error
			 "FLUID %s cannot be changed to GLOBAL" x)
	(put x 'GLOBAL t)))

(defmacro GLOBAL (idlist)
  "GLOBAL(IDLIST:id-list):NIL eval, spread
The ids of IDLIST are declared GLOBAL type variables. If an id
has not been declared previously it is initialized to
NIL. Variables already declared GLOBAL are ignored. Changing a
variables type from FLUID to GLOBAL is not permissible and
results in the error:
***** ID cannot be changed to GLOBAL"
  ;; A warning, as for PSL, is more convenient than an error!
  (if (memq (car idlist) '(quote QUOTE)) ; QUOTE (UC) should now be redundant
	  ;; Assume a top-level call that needs to output `defvar' forms
	  ;; at compile time.
	  (cons 'prog1
			(cons nil
				  (mapcan
				   (lambda (x)
					 `((with-no-warnings ; suppress warning about lack of prefix
						 (defvar ,x nil "Standard LISP global variable."))
					   (unless (GLOBALP ',x)
						 (esl--global ',x))))
				   (eval idlist))))
	;; Assume a run-time call that need not output `defvar' forms.
	`(prog1 nil
	   (mapc
		(lambda (x)
		  (unless (GLOBALP x)
			(esl--global x)
			(set x nil)))
		,idlist))))

(defun GLOBALP (u)
  "GLOBALP(U:any):boolean eval, spread
If U has been declared GLOBAL or is the name of a defined function,
T is returned, else NIL is returned."
  (or (get u 'GLOBAL) (symbol-function u)))

;; (defalias 'SET 'set
;;   ;; Auto fluid not implemented!
;;   "SET(EXP:id, VALUE:any):any eval, spread
;; EXP must be an identifier or a type mismatch error occurs. The
;; effect of SET is replacement of the item bound to the identifier
;; by VALUE. If the identifier is not a local variable or has not
;; been declared GLOBAL it is automatically declared FLUID with the
;; resulting warning message:
;; *** EXP declared FLUID
;; EXP must not evaluate to T or NIL or an error occurs:
;; ***** Cannot change T or NIL")

(defmacro SET (exp value)					; EXPERIMENTAL!
  ;; Auto fluid not implemented!
  "SET(EXP:id, VALUE:any):any eval, spread
EXP must be an identifier or a type mismatch error occurs. The
effect of SET is replacement of the item bound to the identifier
by VALUE. If the identifier is not a local variable or has not
been declared GLOBAL it is automatically declared FLUID with the
resulting warning message:
*** EXP declared FLUID
EXP must not evaluate to T or NIL or an error occurs:
***** Cannot change T or NIL"
  (declare (debug set))
  `(set ,exp ,value))

(defmacro SETQ (variable value)	   ; boot.el does not compile if alias
  ;; Auto fluid not implemented!
  "SETQ(VARIABLE:id, VALUE:any):any noeval, nospread
If VARIABLE is not local or GLOBAL it is by default declared
FLUID and the warning message:
*** VARIABLE declared FLUID
appears. The value of the current binding of VARIABLE is replaced
by the value of VALUE. VARIABLE must not be T or NIL or an
error occurs:
***** Cannot change T or NIL
MACRO PROCEDURE SETQ(X);
   LIST('SET, LIST('QUOTE, CADR X), CADDR X);"
  (declare (debug setq))
  `(setq ,variable ,value))

(defun UNFLUID (idlist)
  "UNFLUID(IDLIST:id-list):NIL eval, spread
The variables in IDLIST that have been declared as FLUID
variables are no longer considered as fluid variables. Others are
ignored. This affects only compiled functions as free variables
in interpreted functions are automatically considered fluid."
  (mapc (lambda (x)
		  (if (FLUIDP x) (cl-remprop x 'FLUID)))
		idlist)
  nil)


;;; Program Feature Functions
;;; =========================

(defalias 'GO 'go
  "GO(LABEL:id) noeval, nospread -- OK in cl-tagbody
GO alters the normal flow of control within a PROG function. The
next statement of a PROG function to be evaluated is immediately
preceded by LABEL. A GO may only appear in the following situations:
1. At the top level of a PROG referencing a label which also
   appears at the top level of the same PROG.
2. As the consequent of a COND item of a COND appearing on the
   top level of a PROG.
3. As the consequent of a COND item which appears as the
   consequent of a COND item to any level.
4. As the last statement of a PROGN which appears at the top
   level of a PROG or in a PROGN appearing in the consequent of a
   COND to any level subject to the restrictions of 2 and 3.
5. As the last statement of a PROGN within a PROGN or as the
   consequent of a COND in a PROGN to any level subject to the
   restrictions of 2, 3 and 4.
If LABEL does not appear at the top level of the PROG in which
the GO appears, an error occurs:
***** LABEL is not a known label
If the GO has been placed in a position not defined by rules 1-5,
another error is detected:
***** Illegal use of GO to LABEL")

(def-edebug-spec GO 0)

(defmacro PROG (vars &rest program)
  "PROG(VARS:id-list, [PROGRAM:{id, any}]):any noeval, nospread
VARS is a list of ids which are considered fluid when the PROG is
interpreted and local when compiled. The PROGs variables are
allocated space when the PROG form is invoked and are deallocated
when the PROG is exited. PROG variables are initialized to
NIL. The PROGRAM is a set of expressions to be evaluated in order
of their appearance in the PROG function. Identifiers appearing
in the top level of the PROGRAM are labels which can be
referenced by GO. The value returned by the PROG function is
determined by a RETURN function or NIL if the PROG \"falls
through\"."
  (declare (debug ((&rest symbolp) &rest &or symbolp form)))
  ;; This is essentially how `cl-prog' is defined in `cl-macs.el'.

  ;; But cl-tagbody does not like nil sexps in its body, which REDUCE
  ;; may generate, so delete them.
  `(cl-block nil
	 (let ,vars
	   (cl-tagbody . ,(delq nil program)))))

(defmacro PROGN (&rest u)				; does not work as alias
  "PROGN([U:any]):any noeval, nospread
U is a set of expressions which are executed sequentially. The
value returned is the value of the last expression."
  (declare (debug (body)))				; no spec for progn!
  `(progn ,@u))

(defalias 'PROG2 'prog2
  "PROG2(A:any, B:any)any eval, spread
Returns the value of B.
EXPR PROCEDURE PROG2(A, B);
   B;")

;; (defalias 'RETURN 'cl-return
;;   "RETURN(U:any) eval, spread
;; Within a PROG, RETURN terminates the evaluation of a PROG
;; and returns U as the value of the PROG. The restrictions on the
;; placement of RETURN are exactly those of GO. Improper placement
;; of RETURN results in the error:
;; ***** Illegal use of RETURN")

;; (def-edebug-spec RETURN t)

(defmacro RETURN (u)					; EXPERIMENTAL!
  "RETURN(U:any) eval, spread
Within a PROG, RETURN terminates the evaluation of a PROG
and returns U as the value of the PROG. The restrictions on the
placement of RETURN are exactly those of GO. Improper placement
of RETURN results in the error:
***** Illegal use of RETURN"
  (declare (debug t))
  `(cl-return ,u))


;;; Error Handling
;;; ==============

(defun ERROR (number message)
  "ERROR(NUMBER:integer, MESSAGE:any) eval, spread
NUMBER and MESSAGE are passed back to a surrounding ERRORSET (the
Standard LISP reader has an ERRORSET). MESSAGE is placed in the
global variable EMSG!* and the error number becomes the value of
the surrounding ERRORSET. FLUID variables and local bindings are
unbound to return to the environment of the ERRORSET. Global
variables are not affected by the process."
  (setq EMSG* message)
  (signal 'user-error (list number message)))

(define-error 'user-error-no-message "" 'user-error)

(defun ERROR1 ()
  "This is the simplest error return, without a message printed.
It can be defined as ERROR(99,NIL) if necessary.
In PSL it is throw('!$error!$,99)."
  (signal 'user-error-no-message nil))

(defun ERRORSET (u msgp tr)
  "ERRORSET(U:any, MSGP:boolean, TR:boolean):any eval, spread
If an error occurs during the evaluation of U, the value of
NUMBER from the ERROR call is returned as the value of
ERRORSET. In addition, if the value of MSGP is non-NIL, the
MESSAGE from the ERROR call is displayed upon both the standard
output device and the currently selected output device unless the
standard output device is not open. The message appears prefixed
with 5 asterisks. The MESSAGE list is displayed without top level
parentheses. The MESSAGE from the ERROR call will be available in
the global variable EMSG!*. The exact format of error messages
generated by Standard LISP functions described in this document
are not fixed and should not be relied upon to be in any
particular form. Likewise, error numbers generated by Standard
LISP functions are implementation dependent.
If no error occurs during the evaluation of U, the value of
  (LIST (EVAL U)) is returned.
If an error has been signaled and the value of TR is non-NIL a
trace-back sequence will be initiated on the selected output
device. The traceback will display information such as unbindings
of FLUID variables, argument lists and so on in an implementation
dependent format."
  (let ((debug-on-error (or debug-on-error tr)))
	(condition-case err			  ; error description variable
		(list (eval u))			  ; protected form
	  (user-error-no-message nil) ; error1 called -- no message or debugging
	  ((user-error debug)		  ; Standard LISP error
	   (if msgp
		   (let ((msg (cddr err)))
			 (message "***** %s"
					  (if (listp msg)
						  ;; (mapconcat 'identity msg " ")
						  ;; msg may contain objects other than
						  ;; strings, but this formatting may not be optimal:
						  (mapconcat (lambda (x) (prin1-to-string x t)) msg " ")
						msg))))
	   (cadr err))
	  ((error debug)					; Emacs Lisp error
	   (let ((msg (error-message-string err)))
		 (if msgp (message "***** %s" msg))
		 ;; Should return the error number, but internal elisp errors
		 ;; will not have one, so return the error message string
		 ;; instead. What matters is that an atom is returned.
		 msg)))))


;;; Vectors
;;; =======

(defun GETV (v index)
  "GETV(V:vector, INDEX:integer):any eval, spread
Returns the value stored at position INDEX of the vector V. The
type mismatch error may occur. An error occurs if the INDEX does
not lie within 0...UPBV(V) inclusive:
***** INDEX subscript is out of range"
  (aref v index))

(defalias 'IGETV 'GETV)

(defun MKVECT (uplim)
  "MKVECT(UPLIM:integer):vector eval, spread
Defines and allocates space for a vector with UPLIM+1 elements
accessed as 0...UPLIM. Each element is initialized to NIL. An error
will occur if UPLIM is < 0 or there is not enough space for a vector
of this size:
***** A vector of size UPLIM cannot be allocated"
  (make-vector (1+ uplim) nil))

(defun PUTV (v index value)
  "PUTV(V:vector, INDEX:integer, VALUE:any):any eval, spread
Stores VALUE into the vector V at position INDEX. VALUE is
returned. The type mismatch error may occur. If INDEX does not
lie in 0...UPBV(V) an error occurs:
***** INDEX subscript is out of range"
  (aset v index value))

(defalias 'IPUTV 'PUTV)

(defun UPBV (u)
  "UPBV(U:any):NIL,integer eval, spread
Returns the upper limit of U if U is a vector, or NIL if it is not."
  (if (vectorp u) (1- (length u))))


;;; Boolean Functions and Conditionals
;;; ==================================

(defmacro AND (&rest u)			   ; boot.el does not compile if alias
  "AND([U:any]):extra-boolean noeval, nospread
AND evaluates each U until a value of NIL is found or the end of the
list is encountered. If a non-NIL value is the last value it is returned,
or NIL is returned.
FEXPR PROCEDURE AND(U);
BEGIN
   IF NULL U THEN RETURN NIL;
LOOP: IF NULL CDR U THEN RETURN EVAL CAR U
      ELSE IF NULL EVAL CAR U THEN RETURN NIL;
   U := CDR U;
   GO LOOP
END;"
  (declare (debug t))
  `(and ,@u))

(defmacro COND (&rest u)				; does not work as alias
  "COND([U:cond-form]):any noeval, nospread
The antecedents of all U's are evaluated in order of their
appearance until a non-NIL value is encountered. The consequent
of the selected U is evaluated and becomes the value of the
COND. The consequent may also contain the special functions GO
and RETURN subject to the restraints given for these functions in
\"Program Feature Functions\", section 3.7 on page 22. In these
cases COND does not have a defined value, but rather an
effect. If no antecedent is non-NIL the value of COND is NIL. An
error is detected if a U is improperly formed:
***** Improper cond-form as argument of COND"
  (declare (debug cond))
  `(cond ,@u))

(defalias 'NOT 'null		   ; not is defined this way in Emacs Lisp
  "NOT(U:any):boolean eval, spread
If U is NIL, return T else return NIL (same as function NULL).
EXPR PROCEDURE NOT(U);
   U EQ NIL;")

(defmacro OR (&rest u)			   ; boot.el does not compile if alias
  "OR([U:any]):extra-boolean noeval, nospread
U is any number of expressions which are evaluated in order of their
appearance. When one is found to be non-NIL it is returned as the
value of OR. If all are NIL, NIL is returned.
FEXPR PROCEDURE OR(U);
BEGIN SCALAR X;
LOOP: IF NULL U THEN RETURN NIL
       ELSE IF (X := EVAL CAR U) THEN RETURN X;
   U := CDR U;
   GO LOOP
END;"
  (declare (debug t))
  `(or ,@u))


;;; Arithmetic Functions
;;; ====================

;; Run the Calc library quietly:
(setq calc-display-working-message nil)

(defmacro bigpos (&rest digits)
  "Return a big integer representation.
A call of the form (bigpos d1 ... dn) is self-quoting; the result
of evaluating it is the big integer representation itself."
  ;; cf. the definition of `lambda' in "subr.el".
  (list 'quote (cons 'bigpos digits)))

(defmacro bigneg (&rest digits)
  "Return a big integer representation.
A call of the form (bigneg d1 ... dn) is self-quoting; the result
of evaluating it is the big integer representation itself."
  ;; cf. the definition of `lambda' in "subr.el".
  (list 'quote (cons 'bigneg digits)))

(defun esl--arith-op2 (op math-op u v)
  "OP(U:number, V:number); MATH-OP is math-integer version of OP."
  (if (math-integerp u)
	  (if (math-integerp v)
		  (funcall math-op u v)
		;; v is a float or invalid:
		(funcall op (FLOAT u) v))
	;; u is a float or invalid:
	(funcall op u (FLOAT v))))

(defun ABS (u)
  "ABS(U:number):number eval, spread
Returns the absolute value of its argument.
EXPR PROCEDURE ABS(U);
   IF LESSP(U, 0) THEN MINUS(U) ELSE U;"
  (if (numberp u)
	  (abs u)
	;; u is a math-integer or invalid:
	(math-abs u)))

(defun ADD1 (u)
  "ADD1(U:number):number eval, spread
Returns the value of U plus 1 of the same type as U (fixed or floating).
EXPR PROCEDURE ADD1(U);
   PLUS2(U, 1);"
  (PLUS2 u 1))

(defun DIFFERENCE (u v)
  "DIFFERENCE(U:number, V:number):number eval, spread
The value U - V is returned."
  (esl--arith-op2 #'- #'math-sub u v))

(defun DIVIDE (u v)
  "DIVIDE(U:number, V:number):dotted-pair eval, spread
The dotted-pair (quotient . remainder) is returned. The quotient
part is computed the same as by QUOTIENT and the remainder
the same as by REMAINDER. An error occurs if division by zero is
attempted:
***** Attempt to divide by 0 in DIVIDE
EXPR PROCEDURE DIVIDE(U, V);
   (QUOTIENT(U, V) . REMAINDER(U, V));"
  (cons (QUOTIENT u v) (REMAINDER u v)))

;; (EXPT 10 40) overflows!
;; (defun EXPT (u v)
;;  "EXPT(U:number, V:integer):number eval, spread
;; Returns U raised to the V power. A floating point U to an integer
;; power V does not have V changed to a floating number before
;; exponentiation."
;;  (cond ((and (numberp u) (numberp v)) (expt u v))
;; 	   ((math-integerp u) (math-pow u v))
;; 	   ;; u is a float, v is a math-integer, u^v = e^(ln(u)*v):
;; 	   ;; THIS VIOLATES THE SPECIFICATION!
;; 	   (t (exp (* (log u) (FLOAT v))))))

(defun EXPT (u v)
 "EXPT(U:number, V:integer):number eval, spread
Returns U raised to the V power. A floating point U to an integer
power V does not have V changed to a floating number before
exponentiation."
 (cond ((math-integerp u) (math-pow u v))
	   ((and (floatp u) (numberp v)) (expt u v))
	   ;; u is a float, v is a math-integer, u^v = e^(ln(u)*v):
	   ;; THIS VIOLATES THE SPECIFICATION!
	   (t (exp (* (log u) (FLOAT v))))))

;; The IEEE binary64 format (https://en.wikipedia.org/wiki/IEEE_754)
;; uses a 53-bit significand (s) and 11-bit exponent (e).  If the
;; (binary) exponent is 53 or more then the float has zero fractional
;; part, so truncating it cannot lose digits.  An Elisp integer uses
;; 61 bits (range 2**61 - 1 to -2**61), so a float with exponent up to
;; 60 should truncate reliably to an Elisp integer.  Choose a maximum
;; exponent value (emax) between 53 and 60 and only truncate a float
;; with exponent <= emax to reliably obtain an accurate Elisp integer.

(defun FIX (u)
  "FIX(U:number):integer eval, spread
Returns an integer which corresponds to the truncated value of U.
The result of conversion must retain all significant portions of U. If
U is an integer it is returned unchanged."
  (if (math-integerp u)
	  u
	;; u is a float:
	(let* ((emax 58)
		   (s.e (frexp u))				; s float: 0.5 <= s < 1.0
		   (e (cdr s.e)))				; e integer: u = s*2^e
	  (if (<= e emax)
		  (truncate u)
		(math-mul (truncate (ldexp (car s.e) emax)) ; (s*2^emax) *
				  (math-pow 2 (- e emax)))			; (2^(e-emax))
		))))

(defun FLOAT (u)
  "FLOAT(U:number):floating eval, spread
The floating point number corresponding to the value of the
argument U is returned.  Some of the least significant digits of
an integer may be lost do to the implementation of floating point
numbers.  FLOAT of a floating point number returns the number
unchanged.  If U is too large to represent in floating point an
error occurs:
***** Argument to FLOAT is too large"
  ;; Convert ANY number U to a native ELisp float.
  (if (numberp u)
	  (float u)
	;; math-float returns `MANT * 10^EXP' as `(float MANT EXP)'
	(let ((me (cdr (math-float u))))
	  (* (car me) (expt 10.0 (cadr me))))))

(defun GREATERP (u v)
  "GREATERP(U:number, V:number):boolean eval, spread
Returns T if U is strictly greater than V, otherwise returns NIL."
  (esl--arith-op2 #'< #'math-lessp v u))

(defun LESSP (u v)
  "LESSP(U:number, V:number):boolean eval, spread
Returns T if U is strictly less than V, otherwise returns NIL."
  (esl--arith-op2 #'< #'math-lessp u v))

(defmacro MAX (&rest u)
  "MAX([U:number]):number noeval, nospread, or macro
Returns the largest of the values in U. If two or more values are the
same the first is returned.
MACRO PROCEDURE MAX(U);
   EXPAND(CDR U, 'MAX2);"
  (EXPAND u 'MAX2))

(defun MAX2 (u v)
  "MAX2(U:number, V:number):number eval, spread
Returns the larger of U and V. If U and V are the same value U is
returned (U and V might be of different types).
EXPR PROCEDURE MAX2(U, V);
   IF LESSP(U, V) THEN V ELSE U;"
  (if (LESSP u v) v u))

(defmacro MIN (&rest u)
  "MIN([U:number]):number noeval, nospread, or macro
Returns the smallest of the values in U. If two or more values are the
same the first of these is returned.
MACRO PROCEDURE MIN(U);
   EXPAND(CDR U, 'MIN2);"
  (EXPAND u 'MIN2))

(defun MIN2 (u v)
  "MIN2(U:number, V:number):number eval, spread
Returns the smaller of its arguments. If U and V are the same value,
U is returned (U and V might be of different types).
EXPR PROCEDURE MIN2(U, V);
   IF GREATERP(U, V) THEN V ELSE U;"
  (if (GREATERP u v) v u))

(defun MINUS (u)
  "MINUS(U:number):number eval, spread
Returns -U.
EXPR PROCEDURE MINUS(U);
   DIFFERENCE(0, U);"
  (if (numberp u)
	  (- u)
	;; u is a math-integer or invalid:
	(math-neg u)))

(defmacro PLUS (&rest u)
  "PLUS([U:number]):number noeval, nospread, or macro
Forms the sum of all its arguments.
MACRO PROCEDURE PLUS(U);
   EXPAND(CDR U, 'PLUS2);"
  (declare (debug t))
  (EXPAND u #'PLUS2))

(defun PLUS2 (u v)
  "PLUS2(U:number, V:number):number eval, spread
Returns the sum of U and V."
  (esl--arith-op2 #'+ #'math-add u v))

(defun esl-xor (u v)
  "(exclusive-or U V)"
  (cond (u (not v)) (v (not u))))

(defun esl--math-integer-quotient (u v)
  "Correct quotient of math-integers U and V."
  (let ((w (math-quotient (math-abs u) (math-abs v))))
	(if (esl-xor (math-negp u) (math-negp v))
		(math-neg w)
	  w)))

(defun QUOTIENT (u v)
  "QUOTIENT(U:number, V:number):number eval, spread
The quotient of U divided by V is returned. Division of two positive
or two negative integers is conventional. When both U and V are
integers and exactly one of them is negative the value returned is
the negative truncation of the absolute value of U divided by the
absolute value of V. An error occurs if division by zero is attempted:
***** Attempt to divide by 0 in QUOTIENT"
  (esl--arith-op2 #'/ #'esl--math-integer-quotient u v))

(defun REMAINDER (u v)
  "REMAINDER(U:number, V:number):number eval, spread
If both U and V are integers the result is the integer remainder of
U divided by V. If either parameter is floating point, the result is
the difference between U and V*(U/V) all in floating point. If either
number is negative the remainder is negative. If both are positive or
both are negative the remainder is positive. An error occurs if V is
zero:
***** Attempt to divide by 0 in REMAINDER
EXPR PROCEDURE REMAINDER(U, V);
   DIFFERENCE(U, TIMES2(QUOTIENT(U, V), V));"
  (DIFFERENCE u (TIMES2 (QUOTIENT u v) v)))

(defun SUB1 (u)
  "SUB1(U:number):number eval, spread
Returns the value of U less 1. If U is a FLOAT type number, the
value returned is U less 1.0.
EXPR PROCEDURE SUB1(U);
   DIFFERENCE(U, 1);"
  (DIFFERENCE u 1))

(defmacro TIMES (&rest u)
  "TIMES([U:number]):number noeval, nospread, or macro
Returns the product of all its arguments.
MACRO PROCEDURE TIMES(U);
   EXPAND(CDR U, 'TIMES2);"
  (declare (debug t))
  (EXPAND u #'TIMES2))

(defun TIMES2 (u v)
  "TIMES2(U:number, V:number):number eval, spread
Returns the product of U and V."
  (esl--arith-op2 #'* #'math-mul u v))

;; Fast built-in small integer (inum) arithmetic:

(defalias 'IPLUS '+)
(defalias 'ITIMES '*)
(defalias 'IPLUS2 '+)
(defalias 'ITIMES2 '*)
(defalias 'IADD1 '1+)
(defalias 'ISUB1 '1-)
(defalias 'IMINUS '-)
(defalias 'IMINUSP 'cl-minusp)
(defalias 'IDIFFERENCE '-)
(defalias 'IQUOTIENT '/)
(defalias 'IREMAINDER '%)
(defalias 'ILESSP '<)
(defalias 'IGREATERP '>)
(defalias 'ILEQ '<=)
(defalias 'IGEQ '>=)

(defmacro IZEROP (number)
  "Return t if NUMBER is zero."
  `(= ,number 0))

(defmacro IONEP (number)
  "Return t if NUMBER is one."
  `(= ,number 1))

;; Fast built-in floating point functions:

;; (defalias 'ACOS 'acos)
;; (defalias 'ASIN 'asin)
;; (defalias 'ATAN 'atan)
;; (defalias 'ATAN2 'atan)
;; (defalias 'COS 'cos)
;; (defalias 'EXP 'exp)
;; (defalias 'LN 'log)
;; (defalias 'LOG 'log)
;; (defalias 'LOGB 'log)
;; (defsubst LOG10 (x) (log x 10))
;; (defalias 'SIN 'sin)
;; (defalias 'SQRT 'sqrt)
;; (defalias 'TAN 'tan)
;; ;; The following will fail for floats with very large magnitudes since
;; ;; they return fixnums rather than big integers.  If that is a problem
;; ;; then remove these aliases and in particular remove the lose flags
;; ;; in "eslrend.red".
;; (defalias 'CEILING 'ceiling)
;; (defalias 'FLOOR 'floor)
;; (defalias 'ROUND 'round)

;; The above cause errors in the arith test file when trig results or
;; arguments are complex so all commented out for now.


;;; MAP Composite Functions
;;; =======================

;; I use funcall below to avoid compiler warnings.

(defun MAP (x fn)
  "MAP(X:list, FN:function):any eval, spread
Applies FN to successive CDR segments of X. NIL is returned.
EXPR PROCEDURE MAP(X, FN);
   WHILE X DO << FN X; X := CDR X >>;"
  (while x
	(funcall fn x)
	(setq x (cdr x))))

(defun MAPC (x fn)
  "MAPC(X:list, FN:function):any eval, spread
FN is applied to successive CAR segments of list X. NIL is returned.
EXPR PROCEDURE MAPC(X, FN);
   WHILE X DO << FN CAR X; X := CDR X >>;"
  (mapc fn x)
  nil)

(defun MAPCAN (x fn)
  "MAPCAN(X:list, FN:function):any eval, spread
A concatenated list of FN applied to successive CAR elements of X
is returned.
EXPR PROCEDURE MAPCAN(X, FN);
   IF NULL X THEN NIL
      ELSE NCONC(FN CAR X, MAPCAN(CDR X, FN));"
  (mapcan fn x))

(defun MAPCAR (x fn)
  "MAPCAR(X:list, FN:function):any eval, spread
Returned is a constructed list of FN applied to each CAR of list X.
EXPR PROCEDURE MAPCAR(X, FN);
   IF NULL X THEN NIL
      ELSE FN CAR X . MAPCAR(CDR X, FN);"
  (mapcar fn x))

(defun MAPCON (x fn)
  "MAPCON(X:list, FN:function):any eval, spread
Returned is a concatenated list of FN applied to successive CDR
segments of X.
EXPR PROCEDURE MAPCON(X, FN);
   IF NULL X THEN NIL
      ELSE NCONC(FN X, MAPCON(CDR X, FN));"
  (if x	(nconc (funcall fn x) (MAPCON (cdr x) fn))))

(defun MAPLIST (x fn)
  "MAPLIST(X:list, FN:function):any eval, spread
Returns a constructed list of FN applied to successive CDR segments
of X.
EXPR PROCEDURE MAPLIST(X, FN);
   IF NULL X THEN NIL
      ELSE FN X . MAPLIST(CDR X, FN);"
  (if x (cons (funcall fn x) (MAPLIST (cdr x) fn))))


;;; Composite Functions
;;; ===================

(defun APPEND (u v)
  "(append U:list V:list): list expr
Returns a constructed list in which the last element of U is followed by the
first element of V. The list U is copied, but V is not."
  ;; Some REDUCE code assumes the PSL definition, which allows U to
  ;; have any type:
  (if (consp u) (append u v) v))

(defalias 'ASSOC 'assoc
  "ASSOC(U:any, V:alist):{dotted-pair, NIL} eval, spread
If U occurs as the CAR portion of an element of the alist V, the
dotted-pair in which U occurred is returned, else NIL is
returned.  ASSOC might not detect a poorly formed alist so an
invalid construction may be detected by CAR or CDR.
EXPR PROCEDURE ASSOC(U, V);
   IF NULL V THEN NIL
      ELSE IF ATOM CAR V THEN
         ERROR(000, LIST(V, \"is a poorly formed alist\"))
      ELSE IF U = CAAR V THEN CAR V
      ELSE ASSOC(U, CDR V);")

(defun DEFLIST (u ind)
  "DEFLIST(U:dlist, IND:id):list eval, spread
A \"dlist\" is a list in which each element is a two element list: (ID:id
PROP:any). Each ID in U has the indicator IND with property
PROP placed on its property list by the PUT function. The value
of DEFLIST is a list of the first elements of each two element list.
Like PUT, DEFLIST may not be used to define functions.
EXPR PROCEDURE DEFLIST(U, IND);
   IF NULL U THEN NIL
      ELSE << PUT(CAAR U, IND, CADAR U);
              CAAR U >> . DEFLIST(CDR U, IND);"
  (when u
	(if *DEFN (esl--save-plist (caar u)))
	(put (caar u) ind (CADAR u))
	(cons (caar u) (DEFLIST (cdr u) ind))))

(defun DELETE (u v)
  ;; Must be non-destructive, so cannot use Elisp delete function!
  ;; Doing so causes obscure problems, e.g. in the Bareiss code for
  ;; computing determinants and in for all ... let.
  "DELETE(U:any, V:list ):list eval, spread
Returns V with the first top level occurrence of U removed from it.
EXPR PROCEDURE DELETE(U, V);
   IF NULL V THEN NIL
      ELSE IF CAR V = U THEN CDR V
      ELSE CAR V . DELETE(U, CDR V);"
  (cond ((null v) nil)
		((equal (car v) u) (cdr v))
		(t (cons (car v) (DELETE u (cdr v))))))

(defun DIGIT (u)
  "DIGIT(U:any):boolean eval, spread
Returns T if U is a digit, otherwise NIL.
EXPR PROCEDURE DIGIT(U);
   IF MEMQ(U, '(!0 !1 !2 !3 !4 !5 !6 !7 !8 !9))
      THEN T ELSE NIL;"
  (if (memq u '(\0 \1 \2 \3 \4 \5 \6 \7 \8 \9)) t))

(defun LENGTH (x)
  "LENGTH(X:any):integer eval, spread
The top level length of the list X is returned.
EXPR PROCEDURE LENGTH(X);
   IF ATOM X THEN 0
      ELSE PLUS(1, LENGTH CDR X);"
  ;; The Elisp length function cannot be used because it does not
  ;; accept atoms or dotted pairs!
  (if (ATOM x)
	  0
	(1+ (LENGTH (cdr x)))))

(defun LITER (u)
  "LITER(U:any):boolean eval, spread
Returns T if U is a character of the alphabet, NIL otherwise.
EXPR PROCEDURE LITER(U);
   IF MEMQ(U, '(!A !B !C !D !E !F !G !H !I !J !K !L !M
                !N !O !P !Q !R !S !T !U !V !W !X !Y !Z
                !a !b !c !d !e !f !g !h !i !j !k !l !m
                !n !o !p !q !r !s !t !u !v !w !x !y !z))
      THEN T ELSE NIL;"
  ;; This is Emacs Lisp, so no ! escapes:
  (if (memq u '(A B C D E F G H I J K L M
                N O P Q R S T U V W X Y Z
                a b c d e f g h i j k l m
                n o p q r s t u v w x y z))
	  t))

(defalias 'MEMBER 'member
  "MEMBER(A:any, B:list):extra-boolean eval, spread
Returns NIL if A is not a member of list B, returns the remainder of
B whose first element is A.
EXPR PROCEDURE MEMBER(A, B);
   IF NULL B THEN NIL
      ELSE IF A = CAR B THEN B
      ELSE MEMBER(A, CDR B);")

(defalias 'MEMQ 'memq
  "MEMQ(A:any, B:list):extra-boolean eval, spread
Same as MEMBER but an EQ check is used for comparison.
EXPR PROCEDURE MEMQ(A, B);
   IF NULL B THEN NIL
      ELSE IF A EQ CAR B THEN B
      ELSE MEMQ(A, CDR B);")

(defalias 'NCONC 'nconc
  "NCONC(U:list, V:list):list eval, spread
Concatenates V to U without copying U. The last CDR of U is
modified to point to V.
EXPR PROCEDURE NCONC(U, V);
BEGIN SCALAR W;
   IF NULL U THEN RETURN V;
   W := U;
   WHILE CDR W DO W := CDR W;
   RPLACD(W, V);
   RETURN U
END;")

(defun PAIR (u v)
  "PAIR(U:list, V:list):alist eval, spread
U and V are lists which must have an identical number of elements.
If not, an error occurs (the 000 used in the ERROR call is arbitrary
and need not be adhered to). Returned is a list where each element
is a dotted-pair, the CAR of the pair being from U, and the CDR
the corresponding element from V.
EXPR PROCEDURE PAIR(U, V);
   IF AND(U, V) THEN (CAR U . CAR V) . PAIR(CDR U, CDR V)
      ELSE IF OR(U, V) THEN ERROR(000,
         \"Different length lists in PAIR\")
      ELSE NIL;"
  (cond ((and u v) (cons (cons (car u) (car v)) (PAIR (cdr u) (cdr v))))
		((or u v) (error "%s" "000 Different length lists in PAIR"))))

(defalias 'REVERSE 'reverse
  "REVERSE(U:list):list eval, spread
Returns a copy of the top level of U in reverse order.
EXPR PROCEDURE REVERSE(U);
BEGIN SCALAR W;
   WHILE U DO << W := CAR U . W;
                 U := CDR U >>;
   RETURN W
END;")

(defalias 'REVERSIP 'nreverse)			; PSL function

(defun SASSOC (u v fn)
  "SASSOC(U:any, V:alist, FN:function):any eval, spread
Searches the alist V for an occurrence of U. If U is not in the alist
the evaluation of function FN is returned.
EXPR PROCEDURE SASSOC(U, V, FN);
   IF NULL V THEN FN()
      ELSE IF U = CAAR V THEN CAR V
      ELSE SASSOC(U, CDR V, FN);"
  (cond ((null v) (funcall fn))
		((equal u (caar v)) (car v))
		(t (SASSOC u (cdr v) fn))))

(defun SUBLIS (x y)
  "SUBLIS(X:alist, Y:any):any eval, spread
The value returned is the result of substituting the CDR of each
element of the alist X for every occurrence of the CAR part of that
element in Y.
EXPR PROCEDURE SUBLIS(X, Y);
   IF NULL X THEN Y
      ELSE BEGIN SCALAR U;
                 U := ASSOC(Y, X);
                 RETURN IF U THEN CDR U
                        ELSE IF ATOM Y THEN Y
                        ELSE SUBLIS(X, CAR Y) .
                             SUBLIS(X, CDR Y)
                 END;"
  (if (null x)
	  y
	(let ((u (assoc y x)))
	  (cond (u (cdr u))
			((ATOM y) y)
			(t (cons (SUBLIS x (car y)) (SUBLIS x (cdr y))))))))

(defun SUBST (u v w)
  "SUBST(U:any, V:any, W:any):any eval, spread
The value returned is the result of substituting U for all occurrences
of V in W.
EXPR PROCEDURE SUBST(U, V, W);
   IF NULL W THEN NIL
      ELSE IF V = W THEN U
      ELSE IF ATOM W THEN W
      ELSE SUBST(U, V, CAR W) . SUBST(U, V, CDR W);"
  (cond ((null w) nil)
		((equal v w) u)
		((ATOM w) w)
		(t (cons (SUBST u v (car w)) (SUBST u v (cdr w))))))


;;; The Interpreter
;;; ===============

(defalias 'APPLY 'apply
  "APPLY(FN:{id,function}, ARGS:any-list):any eval, spread
APPLY returns the value of FN with actual parameters ARGS. The
actual parameters in ARGS are already in the form required for
binding to the formal parameters of FN. Implementation specific
portions described in English are enclosed in boxes.
EXPR PROCEDURE APPLY(FN, ARGS);
BEGIN SCALAR DEFN;
   IF CODEP FN THEN RETURN
      | Spread the actual parameters in ARGS
	  | following the conventions: for calling
	  | functions, transfer to the entry point
	  | of the function, and return the value
	  | returned by the function.;
   IF IDP FN THEN RETURN
	  IF NULL(DEFN := GETD FN) THEN
	     ERROR(000, LIST(FN, \"is an undefined function\"))
	  ELSE IF CAR DEFN EQ 'EXPR THEN
	     APPLY(CDR DEFN, ARGS)
	  ELSE ERROR(000,
	     LIST(FN, \"cannot be evaluated by APPLY\"));
   IF OR(ATOM FN, NOT(CAR FN EQ 'LAMBDA)) THEN
      ERROR(000,
         LIST(FN, \"cannot be evaluated by APPLY\"));
   RETURN
      | Bind the actual parameters in ARGS to
      | the formal parameters of the lambda
      | expression. If the two lists are not
      | of equal length then ERROR(000, \"Number
      | of parameters do not match\"); The value
      | returned is EVAL CADDR FN.
END;")

(defalias 'EVAL 'eval
  "EVAL(U:any):any eval, spread
The value of the expression U is computed. Error numbers are
arbitrary. Portions of EVAL involving machine specific coding are
expressed in English enclosed in boxes.
EXPR PROCEDURE EVAL(U);
BEGIN SCALAR FN;
   IF CONSTANTP U THEN RETURN U;
   IF IDP U THEN RETURN
      | U is an id. Return the value most
      | currently bound to U or if there
      | is no such binding: ERROR(000,
      | LIST(\"Unbound:\", U));
   IF PAIRP CAR U THEN RETURN
	  IF CAAR U EQ 'LAMBDA THEN APPLY(CAR U, EVLIS CDR U)
	  ELSE ERROR(000, LIST(CAR U,
	     \"improperly formed LAMBDA expression\"))
	  ELSE IF CODEP CAR U THEN
	     RETURN APPLY(CAR U, EVLIS CDR U);
   FN := GETD CAR U;
   IF NULL FN THEN
      ERROR(000, LIST(CAR U, \"is an undefined function\"))
   ELSE IF CAR FN EQ 'EXPR THEN
      RETURN APPLY(CDR FN, EVLIS CDR U)
   ELSE IF CAR FN EQ 'FEXPR THEN
      RETURN APPLY(CDR FN, LIST CDR U)
   ELSE IF CAR FN EQ 'MACRO THEN
      RETURN EVAL APPLY(CDR FN, LIST U)
END;")

(defun EVLIS (u)
  "EVLIS(U:any-list):any-list eval, spread
EVLIS returns a list of the evaluation of each element of U.
EXPR PROCEDURE EVLIS(U);
   IF NULL U THEN NIL
      ELSE EVAL CAR U . EVLIS CDR U;"
  (if u (cons (eval (car u)) (EVLIS (cdr u)))))

(defun EXPAND (l fn)
  "EXPAND(L:list, FN:function):list eval, spread
FN is a defined function of two arguments to be used in the expansion
of a MACRO. EXPAND returns a list in the form:
   (FN L0 (FN L1 ... (FN Ln-1 Ln) ... ))
where n is the number of elements in L, Li is the ith element of L.
EXPR PROCEDURE EXPAND(L,FN);
   IF NULL CDR L THEN CAR L
      ELSE LIST(FN, CAR L, EXPAND(CDR L, FN));"
  (if (null (cdr l))
	  (car l)
	(list fn (car l) (EXPAND (cdr l) fn))))

(defmacro FUNCTION (fn)			 ; rlisp.red does not compile if alias
  "FUNCTION(FN:function):function noeval, nospread
The function FN is to be passed to another function. If FN is to have
side effects its free variables must be fluid or global. FUNCTION is
like QUOTE but its argument may be affected by compilation. We
do not consider FUNARGs in this report."
  (declare (debug function))
  `(function ,fn))

(defmacro QUOTE (u)						; does not work as alias
  "QUOTE(U:any):any noeval, nospread
Stops evaluation and returns U unevaluated.
FEXPR PROCEDURE QUOTE(U);
   CAR U;"
  (declare (debug quote))
  `',u)


;;; Input and Output
;;; ================

;; An ESL filehandle has the form (stream . mode) where mode is 'INPUT
;; or 'OUTPUT and stream is as defined below:

(defvar esl--read-stream nil
  "The current input stream.
The stream nil represents the terminal, an interactive window.
A buffer stream represents the input file opened in it.")

(defvar esl--write-stream nil
  "The current output stream.
The stream nil represents the terminal, an interactive window.
A buffer stream represents the output file to which it will be
saved when it is closed.")

(defconst esl--read-prefix " ESL-IN "
  "Prefixed to file names to make input buffer names.")

(defconst esl--write-prefix " ESL-OUT "
  "Prefixed to file names to make output buffer names.")

(defconst esl--write-prefix-length (length esl--write-prefix)
  "Length of `esl--write-prefix' string.")

(defconst esl--default-output-buffer-name "*Standard LISP*"
  "The name of the terminal window buffer.")

(defvar esl--default-output-buffer nil
 "The terminal window buffer, set when the buffer is created." )

(defun CLOSE (filehandle)
  "CLOSE(FILEHANDLE:any):any eval, spread
Closes the file with the internal name FILEHANDLE writing any
necessary end of file marks and such. The value of FILEHANDLE
is that returned by the corresponding OPEN. The value returned is
the value of FILEHANDLE. An error occurs if the file can not be
closed.
***** FILEHANDLE could not be closed"
  ;; A null filehandle represents the terminal; ignore it.
  (if filehandle
	  (let (buf)
		(if (and (consp filehandle)
				 (bufferp (setq buf (car filehandle)))
				 ;; It might be better to ignore a non-existent file
				 ;; buffer, assuming it has already been closed.
				 (cond ((eq (cdr filehandle) 'INPUT)
						t)
					   ((eq (cdr filehandle) 'OUTPUT)
						(with-current-buffer buf
						  ;; Filename follows esl--write-prefix in
						  ;; buffer name, so...
						  (write-file
						   (substring (buffer-name)
									  esl--write-prefix-length)
						   ;; Require confirmation to overwrite an
						   ;; existing file unless in batch mode:
						   (not noninteractive)))
						t)))
			(kill-buffer buf)
		  (error "%s could not be closed" filehandle))))
  filehandle)

(defun EJECT ()
  "EJECT():NIL eval, spread
Skip to the top of the next output page. Automatic EJECTs are
executed by the print functions when the length set by the PAGE-
LENGTH function is exceeded."
  nil)

(defvar esl--linelength 80
  "Current Standard LISP line length accessed via function `LINELENGTH'.")

(defun LINELENGTH (len)
  "LINELENGTH(LEN:{integer, NIL}):integer eval, spread
If LEN is an integer the maximum line length to be printed before
the print functions initiate an automatic TERPRI is set to the value
LEN. No initial Standard LISP line length is assumed. The previous
line length is returned except when LEN is NIL. This special case
returns the current line length and does not cause it to be reset. An
error occurs if the requested line length is too large for the currently
selected output file or LEN is negative or zero.
***** LEN is an invalid line length"
  (if len
	  (if (or (not (integerp len)) (<= len 0))
		  (error "%s is an invalid line length" len)
		(prog1 esl--linelength (setq esl--linelength len)))
	esl--linelength))

(defun LPOSN ()
  "LPOSN():integer eval, spread
Returns the number of lines printed on the current page. At the top
of a page, 0 is returned."
  0)

(defun OPEN (file how)
  "OPEN(FILE:any, HOW:id):any eval, spread
Open the file with the system dependent name FILE for output if
HOW is EQ to OUTPUT, or input if HOW is EQ to INPUT. If the
file is opened successfully, a value which is internally associated with
the file is returned. This value must be saved for use by RDS and
WRS. An error occurs if HOW is something other than INPUT or
OUTPUT or the file can't be opened.
***** HOW is not option for OPEN
***** FILE could not be opened"
  (cond ((eq how 'INPUT)
		 ;; Read file into a buffer and return (buffer . 'INPUT).
		 (save-current-buffer
		   ;; Leading space means buffer hidden and no undo:
		   (set-buffer (get-buffer-create (concat esl--read-prefix file)))
		   ;; Allow re-opening a file and continuing to read it:
		   (if (zerop (buffer-size))
			   (insert-file-contents file))
		   (cons (current-buffer) 'INPUT)))
		((eq how 'OUTPUT)
		 ;; Create a new file buffer and return (buffer . 'OUTPUT).
		 (cons (get-buffer-create (concat esl--write-prefix file)) 'OUTPUT))
		(t (error "%s is not option for OPEN" how))))

(defun PAGELENGTH (_len)				; unused argument
  "PAGELENGTH(LEN:{integer, NIL}):integer eval, spread
Sets the vertical length (in lines) of an output page. Automatic page
EJECTs are executed by the print functions when this length is
reached. The initial vertical length is implementation specific. The
previous page length is returned. If LEN is 0, no automatic page
ejects will occur."
  nil)

(defvar esl--posn 0
  "Number of characters in the current line output by Standard LISP.
Accessed (read-only) via the function `POSN'.
It's value should be between 0 and `esl--linelength' inclusive.")

(defun POSN ()
  "POSN():integer eval, spread
Returns the number of characters in the output buffer. When the
buffer is empty, 0 is returned."
  esl--posn)

(defvar *LOWER t
  "If *LOWER is non-nil then all identifiers are output using
lower case.")

(defun esl--prin-string (s)
  "Print string S preceded by a newline if necessary.
Check and update `esl--posn' to keep it <= `esl--linelength'."
  (let ((len (length s)))
	(setq esl--posn (+ esl--posn len))
	(when (> esl--posn esl--linelength)
	  (setq esl--posn len)
	  (terpri))
	(princ s)))

(defsubst esl--downcase-string-maybe (s)
  "Down-case string S if *LOWER is non-nil."
  (if *LOWER (downcase s) s))

(defun PRINC (u)
  "PRINC(U:id):id eval, spread
U must be a single character id such as produced by EXPLODE or
read by READCH or the value of !$EOL!$. The effect is the character
U displayed upon the currently selected output device. The value of
!$EOL!$ causes termination of the current line like a call to TERPRI."
  ;; NB: This version does not handle !$EOL!$ correctly.
  (esl--prin-string (esl--downcase-string-maybe (symbol-name u))))

(defun PRINT (u)
  "PRINT(U:any):any eval, spread
Displays U in READ readable format and terminates the print line.
The value of U is returned.
EXPR PROCEDURE PRINT(U);
<< PRIN1 U; TERPRI(); U >>;"
  (PRIN1 u)
  (terpri)
  u)

(defun esl--prin1-id-to-string (u)
  "Convert identifier U to a string including appropriate `!' characters.
Down-case if *LOWER is non-nil."
  (setq u (esl--downcase-string-maybe (symbol-name u)))
  (if (string-prefix-p "!:" u)
	  (concat "!:" (esl--prin1-id-to-string--internal (substring u 2)))
	(esl--prin1-id-to-string--internal u)))

(defun esl--prin1-id-to-string--internal (u)
  "Include appropriate `!' characters in string U.
U does not begin with `!:'."
  (let (not-first)
	(mapconcat
	 (lambda (c)
	   (prog1
		   (if (or (and not-first (>= c ?0) (<= c ?9))
				   (and (>= c ?A) (<= c ?Z))
				   (and (>= c ?a) (<= c ?z))
				   (eq c ?_))
			   (string c)
			 (string ?! c))
		 (setq not-first t)))
	 u "")))

(defun PRIN1 (u)
  "PRIN1(U:any):any eval, spread
U is displayed in a READ readable form. The format of display is
the result of EXPLODE expansion; special characters are prefixed
with the escape character !, and strings are enclosed in \"...\". Lists
are displayed in list-notation and vectors in vector-notation."
  ;; NB: This version will not print a vector containing big integers
  ;; correctly, but the output should be readable!
  (cond ((symbolp u) (esl--prin-string (esl--prin1-id-to-string u)))
		((not (consp u)) (esl--prin-string (prin1-to-string u)))
		((esl-bigint-p u) (esl--prin-string (esl-bigint-to-string u)))
		(t (esl--prin-string "(")
		   (PRIN1 (car u))
		   (esl--prin1-cdr (cdr u))
		   (esl--prin-string ")")))
  u)

(defsubst esl--prin-space-maybe ()
  "Print a space unless at the end of a line."
  (if (< esl--posn (1- esl--linelength))
	  (esl--prin-string " ")
	(TERPRI)))

(defun esl--prin1-cdr (u)
  "If U is non-nil then print it or its elements spaced appropriately.
U is the cdr of a cons cell: nil, an atom or a cons cell."
  (cond ((null u))						; do nothing
		((atom u)
		 (esl--prin-space-maybe) (esl--prin-string ".")
		 (esl--prin-space-maybe) (PRIN1 u))
		(t (esl--prin-space-maybe)
		   (PRIN1 (car u))
		   (esl--prin1-cdr (cdr u)))))

(defun esl--prin2-id-to-string (u)
  "Convert identifier U to a string excluding inappropriate `!' characters.
Down-case if *LOWER is non-nil."
  (setq u (esl--downcase-string-maybe (symbol-name u)))
  (if (string-prefix-p "!:" u) (substring u 1) u))

(defun PRIN2 (u)
  "PRIN2(U:any):any eval, spread
U is displayed upon the currently selected print device but output is
not READ readable. The value of U is returned. Items are displayed
as described in the EXPLODE function with the exceptions that
the escape character does not prefix special characters and strings
are not enclosed in \"...\". Lists are displayed in list-notation and
vectors in vector-notation. The value of U is returned."
  ;; NB: This version will not print a vector containing big integers
  ;; correctly, but the output should be readable!
  (cond ((symbolp u) (esl--prin-string (esl--prin2-id-to-string u)))
		((not (consp u)) (esl--prin-string (prin1-to-string u t)))
		((esl-bigint-p u) (esl--prin-string (esl-bigint-to-string u)))
		(t (esl--prin-string "(")
		   (PRIN2 (car u))
		   (esl--prin2-cdr (cdr u))
		   (esl--prin-string ")")))
  u)

(defun esl--prin2-cdr (u)
  "If U is non-nil then print it or its elements spaced appropriately.
U is the cdr of a cons cell: nil, an atom or a cons cell."
  (cond ((null u))						; do nothing
		((atom u)
		 (esl--prin-space-maybe) (esl--prin-string ".")
		 (esl--prin-space-maybe) (PRIN2 u))
		(t (esl--prin-space-maybe)
		   (PRIN2 (car u))
		   (esl--prin2-cdr (cdr u)))))

(defun RDS (filehandle)
  "RDS(FILEHANDLE:any):any eval, spread
Input from the currently selected input file is suspended and
further input comes from the file named. FILEHANDLE is a system
dependent internal name which is a value returned by OPEN. If
FILEHANDLE is NIL the standard input device is selected. When end
of file is reached on a non-standard input device, the standard
input device is reselected. When end of file occurs on the
standard input device the Standard LISP reader terminates. RDS
returns the internal name of the previously selected input file.
***** FILEHANDLE could not be selected for input"
  (let (stream)
	(if filehandle
		(unless (and (consp filehandle)
					 (eq (cdr filehandle) 'INPUT)
					 (bufferp (setq stream (car filehandle))))
		  (error "%s could not be selected for input" filehandle)))
	(prog1
		(if esl--read-stream (cons esl--read-stream 'INPUT))
	  (setq esl--read-stream stream))))

(defun esl--read-and-echo ()
  "Read one Lisp expression as text from current `filehandle'.
Return as Lisp object.  Echo the input if `*ECHO' is non-nil."
  (let ((value
		 (let (standard-output
			   ;; to avoid minibuffer errors resetting this
			   (standard-input (or esl--read-stream t)))
		   (read))))
	(when (or (eq standard-input t) *ECHO) ; always echo minibuffer input
	  (if noninteractive
		  (progn (prin1 value) (terpri) (terpri))
		(with-current-buffer standard-output
		  (goto-char (point-max))  ; in case point moved interactively
		  (prin1 value) (terpri) (terpri))))
	value))

(defun READ ()
  "READ():any
The next expression from the file currently selected for
input. Valid input forms are: vector-notation, dot-notation,
list-notation, numbers, function-pointers, strings, and
identifiers with escape characters. Identifiers are interned on
the OBLIST (see the INTERN function in \"Identifiers\"). READ
returns the value of !$EOF!$ when the end of the currently
selected input file is reached.

This ESL implementation is incomplete and provided primarily to
support the REDUCE YESP function."
  (condition-case nil
	  (let ((value (esl--read-and-echo)))
		(if (symbolp value)
			(intern (upcase (symbol-name value)))
		  value))
	(end-of-file $EOF$)))

(defvar esl--marker (make-marker)
  "Marker from which the next input should be read.")

(defvar esl--readch-use-minibuffer nil
  "If non-nil then READCH reads from the minibuffer as terminal.
Otherwise, it reads from an interaction buffer as terminal.")

(defvar esl--readch-input-string nil
  "String used to store minibuffer input so that READCH can read
it character-by-character.")

(defvar esl--readch-input-string-index nil
  "Integer used to store the index of the next character for
READCH to return from `esl--readch-input-string'.")

(defvar esl--readch-input-string-length nil
  "Integer used to store the length of `esl--readch-input-string'.")

(defvar esl--readch-history nil
  "READCH minibuffer input history.")

(defvar esl--readch-prev-char nil
  "Previous character returned by READCH.")

(defun esl--readch-char-to-interned-id (c)
  "Convert ELisp character C to an interned SLisp identifier.
Up-case letters if !*RAISE is non-nil unless previous char was `!'."
  (intern
   (string
	(cond ((eq esl--readch-prev-char '!) c)
		  ((and *RAISE (>= c ?a) (<= c ?z)) (- c 32))
		  (t c)))))

(defun READCH ()
  "READCH():id
Returns the next interned character from the file currently selected
for input. Two special cases occur. If all the characters in an input
record have been read, the value of !$EOL!$ is returned. If the file
selected for input has all been read the value of !$EOF!$ is returned.
Comments delimited by % and end-of-line are not transparent to READCH.

In ESL, echo minibuffer input to `standard-output' and if *ECHO
is non-nil then echo file input."
  (setq
   esl--readch-prev-char
   (if esl--read-stream
	   ;; Read from a file:
	   (let ((result
			  (with-current-buffer esl--read-stream
				(cond ((eobp) $EOF$)
					  ((eolp) (if *ECHO (terpri))
					   (forward-line) $EOL$)
					  (t (let ((c (char-after)))
						   (if *ECHO (write-char c))
						   (forward-char)
						   (esl--readch-char-to-interned-id c)))))))
		 ;; When end of file is reached on a non-standard input device,
		 ;; the standard input device is reselected. But can't kill the
		 ;; buffer within `with-current-buffer'!
		 ;; OR MAYBE YOU CAN!!! But leave this version for now.
		 (if (eq result $EOF$)
			 (CLOSE (RDS nil)))
		 result)
	 ;; Read from terminal:
	 (if esl--readch-use-minibuffer
		 ;; Read from the minibuffer:
		 (progn
		   (when (null esl--readch-input-string)
			 ;; If the input string is null then this is a call for new
			 ;; input.  Read a new input string from the minibuffer,
			 ;; save it and return the first character.
			 (setq esl--readch-input-string
				   (if noninteractive
					   (read-from-minibuffer "")
					 (let (standard-output)
					   ;; to avoid minibuffer errors resetting this
					   (read-from-minibuffer "REDUCE: "
											 nil nil nil 'esl--readch-history)))
				   esl--readch-input-string-length
				   (length esl--readch-input-string)
				   esl--readch-input-string-index 0)
			 ;; (when *ECHO
			 ;; Echo the new input line unless in batch mode:
			 (unless noninteractive
			   (with-current-buffer standard-output
				 (goto-char (point-max)) ; in case point moved interactively
				 (princ esl--readch-input-string) (terpri))));)
		   ;; Then return the next character from the input string.
		   ;; When the last character has been returned, clear the
		   ;; string to trigger new input.
		   (if (or (equal esl--readch-input-string "")	; Empty input.
				   (= esl--readch-input-string-index	; Off end of
					  esl--readch-input-string-length))	; input line.
			   (progn
				 (setq esl--readch-input-string nil)
				 $EOL$)
			 ;; Return the next character and move the pointer along:
			 (let ((c (aref esl--readch-input-string
							esl--readch-input-string-index)))
			   (setq esl--readch-input-string-index
					 (1+ esl--readch-input-string-index))
			   ;; Might get \n in pasted text:
			   (if (eq c ?\n) $EOL$ (esl--readch-char-to-interned-id c)))))
	   ;; Read from interaction buffer:
	   (with-current-buffer "*Standard LISP*"
		 (goto-char esl--marker)
		 ;; When end of file occurs on the standard input device the
		 ;; Standard LISP reader terminates. [NOT YET IMPLEMENTED.]
		 (cond ((eobp) $EOF$)
			   ((eolp) (forward-line)
				(set-marker esl--marker (point)) $EOL$)
			   (t (let ((c (char-after esl--marker)))
					(set-marker esl--marker (1+ esl--marker))
					(esl--readch-char-to-interned-id c)))))))))

;; (advice-add 'READCH :filter-return
;; 			(lambda (x) (princ x #'external-debugging-output)))

;; (advice-add 'read-from-minibuffer :filter-return
;; 			(lambda (x) (princ x #'external-debugging-output)))

(defun TERPRI ()
  "TERPRI():NIL
The current print line is terminated."
  (setq esl--posn 0)
  (terpri)
  nil)

(defun WRS (filehandle)
  "WRS(FILEHANDLE:any):any eval, spread
Output to the currently active output file is suspended and further
output is directed to the file named. FILEHANDLE is an internal
name which is returned by OPEN. The file named must have been
opened for output. If FILEHANDLE is NIL the standard output
device is selected. WRS returns the internal name of the previously
selected output file.
***** FILEHANDLE could not be selected for output"
  (let (stream)
	(if filehandle
		(unless (and (consp filehandle)
					 (eq (cdr filehandle) 'OUTPUT)
					 (or (eq (setq stream (car filehandle)) t)
						 (bufferp stream)))
		  (error "%s could not be selected for output" filehandle))
	  ;; In batch mode, output to stdout:
	  (if noninteractive (setq stream t)))
	(prog1
		(if esl--write-stream (cons esl--write-stream 'OUTPUT))
	  (setq esl--write-stream stream
			standard-output (or stream esl--default-output-buffer)))))


;;; LISP Reader
;;; ===========

;; Interaction via Emacs based on the standard read-eval-print loop.

;; From the ELisp Manual:

;; `t' used as a stream means that the input is read from the
;; minibuffer.  In fact, the minibuffer is invoked once and the text
;; given by the user is made into a string that is then used as the
;; input stream.  If Emacs is running in batch mode, standard input is
;; used instead of the minibuffer.  For example,
;;      (message "%s" (read t))
;; will read a Lisp expression from standard input and print the
;; result to standard output.

;; Use the above approach to make READCH read from the minibuffer.

(define-derived-mode esl-standard-lisp-interaction-mode
  lisp-interaction-mode "SLISP Interaction"
  "Major mode for entering and evaluating Standard LISP forms.")

(defun STANDARD-LISP ()
  "Run Standard LISP with input via the minibuffer and output via a buffer."
  ;; EXPR PROCEDURE STANDARD!-LISP();
  ;; BEGIN SCALAR VALUE;
  ;;    RDS NIL; WRS NIL;
  ;;    PRIN2 \"Standard LISP\"; TERPRI();
  ;;    WHILE T DO
  ;;       << PRIN2 \"EVAL:\"; TERPRI();
  ;;     	 VALUE := ERRORSET(QUOTE EVAL READ(), T, T);
  ;; 	     IF NOT ATOM VALUE THEN PRINT CAR VALUE;
  ;; 	     TERPRI() >>;
  ;; END;
  (interactive)
  (switch-to-buffer
   (setq esl--default-output-buffer
		 (get-buffer-create esl--default-output-buffer-name)))
  (esl-standard-lisp-interaction-mode)
  (goto-char (point-max))  ; in case buffer already exists
  (let (value			   ; value of last sexp
		;; Output to the END of the current buffer:
		;; (standard-output (set-marker esl--marker (point-max)))
		;; The above is proving unreliable, so try this:
		(standard-output (or noninteractive	; in batch mode, output to stdout
							 (current-buffer)))
		;; Make (READCH) read from the minibuffer:
		(esl--readch-use-minibuffer t))
	(if (= (buffer-size) 0)
		(princ "Standard LISP"))
	(RDS nil) (WRS nil)
	(catch 'QUIT
	  (while t
		(terpri)
		(princ "Eval: ")
		(setq value (ERRORSET '(eval (esl--read-and-echo)) t t))
		(unless (ATOM value)
		  (terpri)
		  (princ "====> ") (princ (car value)) (terpri))))))

(defun QUIT ()
  "QUIT()
Causes termination of the LISP reader and control to be
transferred to the operating system."
  (throw 'QUIT nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Emacs Support Code
;;; ==================

(defvar esl-interaction-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\e\C-x" 'esl-read-eval-print)
    (define-key map "\C-j" 'esl-read-eval-print)
    map)
  "Keymap for Standard LISP interaction mode.
Most commands are inherited from `lisp-interaction-mode-map'.")

(define-derived-mode esl-interaction-mode
  lisp-interaction-mode "SLISP Interaction"
  "Major mode for entering and evaluating Standard LISP forms."
  (make-local-variable 'comment-start)
  (setq comment-start "%")
  ;; Always advance point in this buffer's window when text is inserted:
  (make-local-variable 'window-point-insertion-type)
  (setq window-point-insertion-type t)
  )

(defun esl-run (rlisp-mode)
  "Run Standard LISP with IO via a buffer."
  (interactive "P")
  (switch-to-buffer
   (setq esl--default-output-buffer
		 (get-buffer-create esl--default-output-buffer-name)))
  (esl-interaction-mode)
  (let ((standard-output (set-marker esl--marker 1)))
	(princ "Standard LISP") (terpri)
	(terpri) (princ "Eval: "))
  (when rlisp-mode
	(load-file "boot.elc")
	(insert "(BEGIN2)\n\n;end;")
	(forward-line -1)))

(defun esl-read-eval-print (rlisp-mode)
  "Read input after `esl--marker', eval it and print the result."
  (interactive "P")
  (let ((standard-input esl--marker)
		(standard-output esl--marker)
		value)
	(setq value (ERRORSET '(eval (read)) t t))
	(unless (ATOM value)
	  (terpri) (terpri) (princ "====> ") (princ (car value)))
	(terpri) (terpri) (princ "Eval: ")
	;; Output does not necessarily advance point, so...
	(goto-char esl--marker))
  (when rlisp-mode
	(insert "(BEGIN2)\n\n;end;")
	(forward-line -1)))

(defun esl-eval-print-last-sexp ()
  "Copy sexp before point to end of *Standard LISP* buffer.
Then evaluate it and print value into *Standard LISP* buffer."
  (interactive)
  (let ((sexp (buffer-substring-no-properties
			   (save-excursion (backward-sexp) (point))
			   (point))))
	(save-current-buffer
	  (set-buffer "*Standard LISP*")
	  (insert sexp)
	  (esl-read-eval-print nil)
	  )))

(global-set-key "\C-c\C-j" 'esl-eval-print-last-sexp)

(defun esl-pp-fn (symbol)
  "Pretty-print SYMBOL's function definition."
  (interactive)
  (null (pp (symbol-function symbol))))


;;; Additional Lisp functions expected by REDUCE
;;; ============================================

;;; These function are not defined in the Standard Lisp Report.

(defalias 'ID2STRING 'symbol-name)

(defalias 'CONCAT 'concat)

;; This function does not appear in the PSL manual either; I have no
;; idea where it is supposed to be defined!
(defalias 'RASSOC 'rassoc)

(defun EXPLODE2 (u)
  "(explode2 U:atom-vector): id-list expr
PRIN2-like version of EXPLODE without escapes or double quotes."
  ;; NB: This function may need more work.  It will not explode a
  ;; vector containing big integers correctly!
  (seq-map
   (lambda (c) (intern (string c)))
   (if (esl-bigint-p u)
	   (esl-bigint-to-string u)
	 (prin1-to-string u t))))

(defun INT2ID (i)
  "(int2id I:integer): id expr
Converts an integer to an id; this refers to the I'th id in the id space. Since
0 ... 255 correspond to ASCII characters, int2id with an argument in this
range converts an ASCII code to the corresponding single character id. The
id NIL is always found by (int2id 128)."
  ;; I'm guessing that the id should be interned! If not, use make-symbol.
  (intern (string i)))

(defun STRING-DOWNCASE (u)
  "Convert identifier or string U to a lower-case string."
  (downcase (if (symbolp u) (symbol-name u) u)))

(defvar esl-load-message nil			 ; cf. the PSL VERBOSELOAD switch
  "If non-nil print message before and after loading a Lisp library.")

(defun LOAD-MODULE (module)
  "Load the compiled REDUCE module file \"fasl/MODULE.elc\".
If `esl-load-message' is non-nil then output loading messages."
  ;; Not currently used in the REDUCE distribution.
  (load (concat "fasl/" (STRING-DOWNCASE module) ".elc")
		nil (not esl-load-message) t))

(defun EVLOAD (l)
  "Load each compiled REDUCE module in the list of identifiers L."
  ;; symbolic procedure evload l;
  ;;    for each m in l do load!-module m;
  (mapc #'LOAD-MODULE l))

(defmacro LOAD (&rest files)			; not sure about this!
  ;; From the PSL manual:
  "(load [FILE:fstring, idg]): nil macro
For each argument FILE, an attempt is made to locate a
corresponding file.  If a file is found then it will be loaded by
a call on an appropriate function.  A full file name is
constructed by using the directory specifications in
loaddirectories* and the extensions in loadextensions*. The
strings from each list are used in a left to right order, for a
given string from loaddirectories* each extension from
loadextensions* is used.

In addition, the name FILE is added to the list referenced by
options*.  If FILE is found to be in options* then the attempt to
load FILE will be ignored.
*** FILE already loaded
Note that memq is used to determine if FILE is in
options*. Therefore when you use string arguments for loading
files, although identical names for ids refer to the same object,
identical names for strings refer to different objects."
  `(progn
	 (mapc
	  (lambda (x)
		(let ((filename (concat "fasl/" (STRING-DOWNCASE x) ".elc")))
		  (unless (and (symbolp x)
					   (assoc (expand-file-name filename) load-history))
			(load filename t (not esl-load-message) t))))
	  ',files)
	 nil))

(defun TIME ()
  "(time): integer expr
Elapsed time from some arbitrary initial point in milliseconds."
  (round (* (float-time) 1000)))

(defun GCTIME ()
  "(gctime): integer expr
Accumulated time elapsed in garbage collections in milliseconds."
  (round (* gc-elapsed 1000)))

(defun DATE ()
  "(date): string expr
The date in the form \"day-month-year\"
1 lisp> (date)
\"21-Jan-1997\""
  (format-time-string "%d-%b-%Y"))

(defalias 'GETENV 'getenv)
;; GETENV is used by REDUCE module tmprint and probably others.  I'm
;; guessing how it is defined since I can't find any documentation!

;; The following 3 functions are defined in the PSL manual and will
;; probably be required or at least useful:

(defun SYSTEM (command)
  "(system COMMAND:string):undefined expr
starts a (system specific) command interpreter and passes the
command to the interpreter.  E.g. under the UNIX operating system
a Bourne shell is started and COMMAND is interpreted following
the conventions of this shell.  Of course it is possible to use
e.g. (system \"bash\")"
  ;; Output to current buffer.
  (call-process-shell-command command nil t))

(defun PWD ()
  "(pwd):STRING expr
returns the current working directory in system specific format."
  default-directory)

(defalias 'CD 'cd)		  ; This may not be quite compatible with PSL.
;; (cd DIR:string):BOOLEAN expr
;; sets the current working directory to DIR after expanding the
;; filename according to the rules of the operating system.  If this
;; operation is not sucessful, the value Nil is returned.

(defun COPY (u)							; From the PSL manual
  "(copy U:any): any expr
This function returns a copy of U.  While each pair is copied,
atomic elements (for example ids, strings, and vectors) are not.
See totalcopy in section 7.5.  Note that copy is recursive and
will not terminate if its argument is a circular list."
  (if (consp u)
	  (cons (COPY (car u)) (COPY (cdr u)))
	u))

(defalias 'COMPILETIME 'eval-when-compile ; From the PSL manual
  "(compiletime U:form): nil expr
Evaluate the expression U at compile time only.")

(defun BLDMSG (fmt &rest args)			; From the PSL manual
  "(bldmsg FORMAT:string, [ARGS:any]): string expr
Printf to string."
  ;; This is a quick and dirty hack!
  ;; See "support/csl.red" for a better version.
  ;; The format argument is not well documented, so I can only guess
  ;; at what format specifiers might be accepted!  Those actually used
  ;; in REDUCE appear to be %w (use prin2), %d (integer) and %s (???).
  (apply #'format
		 (replace-regexp-in-string "%[^s%]" "%s" fmt)
		 args))


;;; Debugging support
;;; =================

;; In (esl)rend.red, the functions tr, trst, untr, untrst are flagged
;; noform and given the stat property rlis.  cslrend.red defines them
;; all as macros, much as I do below.

;; These functions are modelled on those provided by PSL and use the
;; Elisp trace package.  (But unfortunately there doesn't seem to be
;; any Elisp facility for assignment tracing!)

(defmacro TR (&rest idlist)
  "Trace the functions in IDLIST."
  ;; mapc returns its second argument, SEQUENCE.
  `(mapc #'trace-function-foreground ',idlist))

(defmacro UNTR (&rest idlist)
  "Untrace the functions in IDLIST."
  `(progn (mapc #'untrace-function ',idlist) nil))


(defalias 'PROP 'symbol-plist
  "Return an identifier's property list as in PSL.")

(defalias 'PLIST 'symbol-plist
  "Return an identifier's property list as in CSL.")


;;; Fast loading (FASL) support
;;; ===========================

;; This code is modelled loosely on "mkfasl.red" and CSL/PSL
;; behaviour.  It is intended only to be run in REDUCE and requires
;; RLISP, i.e. "rlisp.red" and "eslrend.red".

;; THERE IS SOME CODE DUPLICATION HERE THAT SHOULD PERHAPS BE REMOVED!

;; (defun MKFASL (name)
;;   "Produce an ESL FASL (.elc) file for the module NAME.
;; NAME should be an identifier or string."
;;   (if (fboundp 'BEGIN1)
;; 	  (let* (*INT *ECHO faslout-filehandle faslout-stream ichan oldichan
;; 			 name.el esl--saved-plist-alist
;; 			 (*DEFN t)
;; 			 ;; Don't need prettyprinted Lisp output; print
;; 			 ;; output should suffice:
;; 			 (defn-print (lambda (x) (print x faslout-stream)))
;; 			 ;; Functions are often used before they are defined and several
;; 			 ;; modules refer to undefined free variables, so...
;; 			 (byte-compile-warnings '(not free-vars unresolved)))
;; 		(setq name (STRING-DOWNCASE name))
;; 		(princ (format "*** Compiling %s ..." name))
;; 		;; Output the Emacs Lisp version of the file:
;; 		(setq faslout-filehandle
;; 			  (OPEN (setq name.el (concat name ".el")) 'OUTPUT))
;; 		(setq faslout-stream (car faslout-filehandle))
;; 		(setq ichan (OPEN (concat name ".red") 'INPUT))
;; 		(setq oldichan (RDS ichan))
;; 		(advice-add 'PRETTYPRINT :override defn-print)
;; 		(unwind-protect
;; 			(BEGIN1)
;; 		  (advice-remove 'PRETTYPRINT defn-print)
;; 		  (CLOSE ichan) (RDS oldichan)
;; 		  (CLOSE faslout-filehandle)
;; 		  (esl-reinstate-plists))
;; 		;; Compile and then delete the Emacs Lisp version of the file:
;; 		(if (byte-compile-file name.el)
;; 			(progn
;; 			  (delete-file name.el)
;; 			  (princ " succeeded\n")
;; 			  nil)
;; 		  (error "Error during mkfasl of %s" name)))))

;; (FLAG '(MKFASL) 'OPFN)					; make it a symbolic operator
;; (FLAG '(MKFASL) 'NOVAL)					; just return Lisp value

;; (defun FASLOUT (name)
;;   "Compile subsequent input into ESL FASL file \"NAME.elc\".
;; NAME should be an identifier or string."
;;   ;; Output subsequent code as Lisp to a temporary file until FASLEND
;;   ;; evaluated.
;;   (if (fboundp 'BEGIN1)
;; 	  (let* (faslout-filehandle faslout-stream name.el
;; 			 (*DEFN t)
;; 			 ;; Don't need prettyprinted Lisp output; print
;; 			 ;; output should suffice:
;; 			 (defn-print (lambda (x) (print x faslout-stream)))
;; 			 ;; Functions are often used before they are defined, so...
;; 			 (byte-compile-warnings '(unresolved)))
;; 		(setq name (STRING-DOWNCASE name))
;; 		(princ (format "FASLOUT %s: IN files; or type in expressions.
;; When all done, execute FASLEND;\n\n" name))
;; 		;; Output the Emacs Lisp version of the file:
;; 		(setq faslout-filehandle (OPEN (setq name.el (concat name ".el")) 'OUTPUT))
;; 		(setq faslout-stream (car faslout-filehandle))
;; 		(advice-add 'PRETTYPRINT :override defn-print)
;; 		(catch 'faslend
;; 		  (unwind-protect
;; 			  (BEGIN1)
;; 			(advice-remove 'PRETTYPRINT defn-print)
;; 			(CLOSE faslout-filehandle)))
;; 		;; Compile and then delete the Emacs Lisp version of the file:
;; 		(princ (format "*** Compiling %s ..." name))
;; 		(if (byte-compile-file name.el)
;; 			(progn
;; 			  (delete-file name.el)
;; 			  (princ " succeeded\n")
;; 			  nil)
;; 		  (error "Error during compilation of %s" name)))))

;; (FLAG '(FASLOUT) 'OPFN)
;; (FLAG '(FASLOUT) 'NOVAL)

;; (defun FASLEND ()
;;   "Terminate a previous FASLOUT and generate the .elc file."
;;   ;; Only allowed after a previous FASLOUT.
;;   ;; Close the temporary Lisp output file and then compile it.
;;   (throw 'faslend nil))

;; (PUT 'FASLEND 'STAT 'ENDSTAT)
;; (FLAG '(FASLEND) 'EVAL)				 ; must be evaluated in this model

(defvar *INT)
(defvar *WRITINGFASLFILE nil
  "REDUCE variable set to t by FASLOUT and reset to nil by FASLEND.")

(defvar esl--faslout-filehandle)
(defvar esl--faslout-name.el)
(defvar esl--faslout-stream)
(defvar esl--faslout-old-lower)

(declare-function SUPERPRINM "eslpretty" (X LMAR))

(defun esl--faslout-prettyprint-override (x)
  "Print X with output to the faslout stream.
For readable output, this function prettyprints each form
followed by a blank line.  But if the Lisp source code will be
deleted then `print' would suffice!"
  (unless (equal x '(FASLEND))			; better way?
	(let ((standard-output esl--faslout-stream)
		  (esl--linelength 120))	   ; default of 80 seems too short
	  (advice-add 'EXPLODE :override #'esl--faslout-explode-override)
	  (SUPERPRINM x 0)
	  (advice-remove 'EXPLODE #'esl--faslout-explode-override)
	  (terpri) nil)))

(defun esl--faslout-explode-override (u)
  "As (EXPLODE U) but using Emacs Lisp syntax.
Used for faslout Lisp generation, which must be Emacs Lisp,
not Standard LISP, since it will be compiled by Emacs."
  (seq-map
   (lambda (c) (intern (string c)))
   (prin1-to-string u)))

(defun FASLOUT (name)
  "Compile subsequent input into ESL FASL file \"NAME.elc\".
NAME should be an identifier or string."
  ;; Output subsequent code as Lisp to a temporary file until FASLEND
  ;; evaluated.
  (setq name (STRING-DOWNCASE name))
  (setq esl--faslout-old-lower *LOWER)
  (setq *WRITINGFASLFILE t
		*DEFN t
		*LOWER nil)
  (if *INT
	  (princ (format "FASLOUT %s: IN files; or type in expressions.
When all done, execute FASLEND;\n\n" name)))
  ;; Output the Emacs Lisp version of the file:
  (setq esl--faslout-filehandle
		(OPEN (setq esl--faslout-name.el (concat name ".el")) 'OUTPUT))
  (setq esl--faslout-stream (car esl--faslout-filehandle))
  ;; Must have a definition of PRETTYPRINT to advise, so...
  (require 'eslpretty)
  (advice-add 'PRETTYPRINT :override #'esl--faslout-prettyprint-override))

(FLAG '(FASLOUT) 'OPFN)
(FLAG '(FASLOUT) 'NOVAL)

(defun FASLEND ()
  "Terminate a previous FASLOUT and generate the .elc file."
  ;; Only allowed after a previous FASLOUT.
  ;; First, tidy up after the call of FASLOUT:
  (advice-remove 'PRETTYPRINT #'esl--faslout-prettyprint-override)
  (setq *WRITINGFASLFILE nil
		*DEFN nil
		*LOWER esl--faslout-old-lower)
  ;; Now process the Lisp output generated by FASLOUT:
  (let ((buf (car esl--faslout-filehandle))
		;; Functions are often used before they are defined and
		;; several modules refer to undefined free variables, so...
		(byte-compile-warnings '(not free-vars unresolved cl-functions))
		*COMP)			 ; OFF COMP -- don't re-compile compiled code!
	(if (zerop (buffer-size buf))
		(progn
		  (lwarn '(esl fasl) :error
				 "No output generated for fasl file %s" esl--faslout-name.el)
		  ;; Do not output an empty file, just kill the empty buffer:
		  (kill-buffer buf))
	  (esl-reinstate-plists)
	  ;; Hack (until I think of a better solution) to remove the "%+"
	  ;; continuation marker added by the prettyprinter to long atoms,
	  ;; such as big integers, that prevents the content being read by
	  ;; Emacs Lisp.  This matters for "specfn/spfdata".
	  (with-current-buffer buf
		(goto-char 0)
		(while (search-forward "%+\n" nil t) (replace-match "")))
	  ;; Close the temporary Lisp output file and then compile it.
	  (CLOSE esl--faslout-filehandle)
	  ;; Check that an Emacs Lisp file has been written:
	  (let ((attribs (file-attributes esl--faslout-name.el)))
		(unless (and attribs (> (file-attribute-size attribs) 0))
		  (error "Error writing %s" esl--faslout-name.el))
		;; Compile the Emacs Lisp version of the file:
		(message "Compiling %s..." esl--faslout-name.el)
		(if (byte-compile-file esl--faslout-name.el)
			;; (progn
			;; (delete-file esl--faslout-name.el) ; keep to aid debugging
			(message "Compiling %s...done" esl--faslout-name.el)
		  ;; nil)
		  (error "Error compiling %s" esl--faslout-name.el))))))

(PUT 'FASLEND 'STAT 'ENDSTAT)
(FLAG '(FASLEND) 'EVAL)				 ; must be evaluated in this model


;;; Miscellaneous
;;; =============

;; This procedure should be defined in rend.red, but I need to use
;; Emacs Lisp and hence lower case, so it's easier to define it here.

;; symbolic procedure orderp(u,v);
;;    % Returns true if U has same or higher order than id V by some
;;    % consistent convention (eg unique position in memory).
;;    wleq(inf u,inf v);       % PSL 3.4 form.
;; %  id2int u <= id2int v;    % PSL 3.2 form.

(defun ORDERP (u v)
  "Returns true if id U has same or higher order than id V by
some consistent convention (eg unique position in memory)."
  ;; Ignore case by down-casing the strings.
  (not (string< (downcase (symbol-name v))
				(downcase (symbol-name u)))))

;; To run Edebug on a FUNCTION defined in RLISP, use esl-pp-fn in
;; *scratch* to get an Emacs Lisp version of FUNCTION, change the
;; header from `lambda' to `defun FUNCTION', and then instrument this
;; definition for debugging.

;; Support for running Edebug on the BLOCK macro, which is defined in
;; rlisp.red essentially as if it were written in Emacs Lisp like
;; this:
;;
;; (defmacro BLOCK (&rest U)
;;   (setq U (cons 'BLOCK U))
;;   (CONS 'PROG (CONS
;; 			   (MAPCAR (CADR U) (FUNCTION CAR))
;; 			   (CDDR U))))

(def-edebug-spec BLOCK (sexp body))

;; This code is useful for bootstrapping: (DSKIN "dbuild.el")

(defvar OLDCHAN*)

(defun DSKIN (name)
  "(dskin NAME:string): nil, abort expr
The contents of the file NAME are processed as if they were typed in.
Once the input stream has been bound to the channel which
represents the open file, each form is processed."
  (RDS (setq OLDCHAN* (OPEN name 'INPUT))))

(provide 'esl)

;;; esl.el ends here