1;;; esl.el --- ESL (Emacs Standard LISP) -*- lexical-binding:t -*- 2 3;; Copyright (C) 2017-2018 Francis J. Wright 4 5;; Author: Francis J. Wright <https://sourceforge.net/u/fjwright> 6;; Created: 17 Nov 2017 7;; Version: $Id: esl.el 4800 2018-10-11 17:45:34Z fjwright $ 8;; Keywords: languages 9;; Homepage: https://sourceforge.net/p/reduce-algebra/code/HEAD/tree/trunk/generic/emacs/REDUCE/ 10;; Package-Version: 0.1 11;; Package-Requires: ((emacs "25") cl-lib) 12 13;; This file is not part of GNU Emacs. 14 15;; This program is free software: you can redistribute it and/or 16;; modify it under the terms of the GNU General Public License as 17;; published by the Free Software Foundation, either version 3 of 18;; the License, or (at your option) any later version. 19 20;; This program is distributed in the hope that it will be useful, 21;; but WITHOUT ANY WARRANTY; without even the implied warranty of 22;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 23;; GNU General Public License for more details. 24 25;; You should have received a copy of the GNU General Public License 26;; along with this program. If not, see <https://www.gnu.org/licenses/>. 27 28;;; Commentary: 29 30;; This file aims to provide an emulation of most of Standard LISP 31;; (enough to run REDUCE) as an upper-case LISP (to keep it distinct 32;; from the underlying Emacs Lisp). However, lambda must be kept lower 33;; case. READ and FEXPRs are not implemented, and the only way to 34;; input Standard LISP is to use the Emacs Lisp reader with Emacs Lisp 35;; syntax. 36 37;; Some functions that correspond to Emacs Lisp special forms or subrs 38;; (built-in functions) must be defined as macros rather than aliases, 39;; either to run correctly or so that REDUCE files can be compiled. 40 41;;; Primitive Data Types 42;;; ==================== 43 44;; integer -- Elisp integers are of fixed size (61 bits) but Slisp 45;; integers are of arbitrary size, which I currently provide by 46;; calling functions in the GNU Emacs Calculator ("Calc") package by 47;; Dave Gillespie. 48 49;; floating -- 1. is an integer in Elisp but a float in 50;; Slisp. Otherwise probably OK. 51 52;; id -- symbol in Elisp. The Slisp escape chacacter is ! but the 53;; Elisp escape character is \. This difference is handled by EXPLODE 54;; and COMPRESS, and would need to be handled by READ if implemented. 55;; In Slisp, lower case letters are automatically converted to upper 56;; case when the !*RAISE flag is T. But upper case letters are 57;; automatically output as lower case when the !*LOWER flag is T. 58 59;; string -- To include a double quote character in a string in Slisp 60;; double it, but in Elisp escaped it with \. This difference would 61;; need to be handled by READ if implemented. 62 63;; dotted-pair, vector, function-pointer -- probably OK. 64 65;; T and NIL -- Elisp only recognises t and nil, so T and NIL are 66;; implemented as constants set to t and nil. They are also converted 67;; to lower case by COMPRESS. 68 69;; ftype -- in Slisp, the set of ids {EXPR, FEXPR, MACRO} represents 70;; the class of definable function types. FEXPRs are not implemented. 71 72;; comments -- in Slisp these begin with % but in Elisp they begin 73;; with ;. This difference would need to be handled by READ if 74;; implemented. 75 76;; REMARK -- very little of REDUCE is written in Lisp notation and 77;; RLISP uses its own reader. I only need to be able to read the Lisp 78;; bootstrap code, boot.sl, that defines RLISP, so I have edited 79;; boot.sl as boot.el to use upper case and Emacs Lisp read syntax. 80;; (Syntax tables are not used by the Emacs Lisp reader, which has its 81;; own built-in syntactic rules which cannot be changed!) 82 83;;; Code: 84 85;; I use the GNU Emacs Common Lisp Emulation library mainly to support 86;; the Standard LISP `PROG' form, but I also need it in Emacs 25 for 87;; `GENSYM'. Also, Emacs 26 provides the `cxxxxr' family of functions 88;; but Emacs 25 only provides `cxxr', so I use the Standard LISP 89;; `CXXXXR' functions, which I have defined exactly as in Emacs 26. 90 91(require 'cl-lib) 92(require 'seq) ; necessary in batch mode -- no idea why! 93 94;; I also use the GNU Emacs Calc library for arbitrary length integers. 95 96(require 'calc) 97(require 'calc-ext) 98 99;;; System GLOBAL Variables 100;;; ======================= 101 102;; Defined early to keep the Emacs Lisp compiler happy. (This file 103;; should be compiled.) 104 105(defvar *COMP nil 106 "*COMP = NIL global 107The value of !*COMP controls whether or not PUTD compiles the 108function defined in its arguments before defining it. If !*COMP is 109NIL the function is defined as an EXPR. If !*COMP is something 110else the function is first compiled. Compilation will produce certain 111changes in the semantics of functions particularly FLUID type access.") 112 113(put '*COMP 'GLOBAL t) 114 115(defvar EMSG* nil 116 "EMSG* = NIL global 117Will contain the MESSAGE generated by the last ERROR call.") 118 119(put 'EMSG* 'GLOBAL t) 120 121(defconst $EOF$ :$EOF$ 122 "$EOF$ = <an uninterned identifier> global 123The value of !$EOF!$ is returned by all input functions when the end 124of the currently selected input file is reached.") 125 126(put '$EOF$ 'GLOBAL t) 127 128(defconst $EOL$ :$EOL$ 129 "$EOL$ = <an uninterned identifier> global 130The value of !$EOL!$ is returned by READCH when it reaches the 131end of a logical input record. Likewise PRINC will terminate its 132current line (like a call to TERPRI) when !$EOL!$ is its argument.") 133 134(put '$EOL$ 'GLOBAL t) 135 136(defvar *GC nil ; currently ignored! 137 "*GC = NIL global 138!*GC controls the printing of garbage collector messages. If NIL 139no indication of garbage collection may occur. If non-NIL various 140system dependent messages may be displayed.") 141 142(put '*GC 'GLOBAL t) 143 144(with-no-warnings ; suppress warning about lack of prefix 145 (defconst NIL nil 146 "NIL = NIL global 147NIL is a special global variable. It is protected from being 148modified by SET or SETQ.")) 149 150(put 'NIL 'GLOBAL t) 151 152(defvar *RAISE t ; ESL uses upper case internally 153 "*RAISE = NIL global 154If !*RAISE is non-NIL all characters input through Standard LISP 155input/output functions will be raised to upper case. If !*RAISE is 156NIL characters will be input as is.") 157 158(put '*RAISE 'GLOBAL t) 159 160(with-no-warnings ; suppress warning about lack of prefix 161 (defconst T t 162 "T = T global 163T is a special global variable. It is protected from being 164modified by SET or SETQ.")) 165 166(put 'T 'GLOBAL t) 167 168;; Not Standard LISP but PSL and assumed by REDUCE: 169(defvar *ECHO nil 170 "*echo = [Initially: nil] switch 171The switch echo is used to control the echoing of input. When (on echo) 172is placed in an input file, the contents of the file are echoed on the standard 173output device. Dskin does not change the value of *echo, so one may say 174(on echo) before calling dskin, and the input will be echoed.") 175 176(defvar *REDEFMSG t 177 "*redefmsg = [Initially: t] switch 178If *redefmsg is not nil, the message 179*** Function `FOO' has been redefined 180is printed whenever a function is redefined by PUTD.") 181;; Should this also apply to DE & DM? 182 183;;; FUNCTIONS 184;;; ========= 185 186 187;;; Elementary Predicates 188;;; ===================== 189 190;; (defmacro ATOM (u) ; boot.el does not compile if alias 191;; "ATOM(U:any):boolean eval, spread 192;; Returns T if U is not a pair. 193;; EXPR PROCEDURE ATOM(U); 194;; NULL PAIRP U;" 195;; (declare (debug t)) 196;; `(or (atom ,u) (math-integerp ,u))) 197 198;; Above macro doesn't work, I think because `u' gets evaluated twice. 199 200(defun ATOM (u) 201 "ATOM(U:any):boolean eval, spread 202Returns T if U is not a pair. 203EXPR PROCEDURE ATOM(U); 204 NULL PAIRP U;" 205 (or (atom u) (math-integerp u))) 206 207(defalias 'CODEP 'functionp 208 "CODEP(U:any):boolean eval, spread 209Returns T if U is a function-pointer.") 210 211(defun CONSTANTP (u) 212 "CONSTANTP(U:any):boolean eval, spread 213Returns T if U is a constant (a number, string, function-pointer, or vector). 214EXPR PROCEDURE CONSTANTP(U); 215 NULL OR(PAIRP U, IDP U);" 216 (null (or (symbolp u) (PAIRP u)))) 217 218(defalias 'EQ 'eq 219 "EQ(U:any, V:any):boolean eval, spread 220Returns T if U points to the same object as V. EQ is not a reliable 221comparison between numeric arguments.") 222 223(defun EQN (u v) 224 "EQN(U:any, V:any):boolean eval, spread 225Returns T if U and V are EQ or if U and V are numbers and have 226the same value and type." 227 (or (eql u v) (math-equal u v))) 228 229(defalias 'EQUAL 'equal 230 "EQUAL(U:any, V:any):boolean eval, spread 231Returns T if U and V are the same. Dotted-pairs are compared 232recursively to the bottom levels of their trees. Vectors must 233have identical dimensions and EQUAL values in all 234positions. Strings must have identical characters. Function 235pointers must have EQ values. Other atoms must be EQN equal.") 236 237(defalias 'FIXP 'math-integerp 238 "FIXP(U:any):boolean eval, spread 239Returns T if U is an integer (a fixed number).") 240 241(defalias 'FLOATP 'floatp 242 "FLOATP(U:any):boolean eval, spread 243Returns T if U is a floating point number.") 244 245(defalias 'IDP 'symbolp 246 "IDP(U:any):boolean eval, spread 247Returns T if U is an id.") 248 249(defun MINUSP (u) 250 "MINUSP(U:any):boolean eval, spread 251Returns T if U is a number and less than 0. If U is not a number 252or is a positive number, NIL is returned. 253EXPR PROCEDURE MINUSP(U); 254 IF NUMBERP U THEN LESSP(U, 0) ELSE NIL;" 255 (cond ((numberp u) (< u 0)) 256 ((math-integerp u) (math-negp u)))) 257 258(defalias 'NULL 'null 259 "NULL(U:any):boolean eval, spread 260Returns T if U is NIL. 261EXPR PROCEDURE NULL(U); 262 U EQ NIL;") 263 264(defun NUMBERP (u) 265 "NUMBERP(U:any):boolean eval, spread 266Returns T if U is a number (integer or floating). 267EXPR PROCEDURE NUMBERP(U); 268 IF OR(FIXP U, FLOATP U) THEN T ELSE NIL;" 269 (or (numberp u) (math-integerp u))) 270 271(defun ONEP (u) 272 "ONEP(U:any):boolean eval, spread. 273Returns T if U is a number and has the value 1 or 1.0. Returns NIL 274otherwise. 275EXPR PROCEDURE ONEP(U); 276 OR(EQN(U, 1), EQN(U, 1.0));" 277 (if (math-integerp u) 278 (math-equal u 1) 279 (eql u 1.0))) 280 281(defun PAIRP (u) 282 "PAIRP(U:any):boolean eval, spread 283Returns T if U is a dotted-pair." 284 (and (consp u) (not (math-integerp u)))) 285 286(defalias 'STRINGP 'stringp 287 "STRINGP(U:any):boolean eval, spread 288Returns T if U is a string.") 289 290(defalias 'VECTORP 'vectorp 291 "VECTORP(U:any):boolean eval, spread 292Returns T if U is a vector.") 293 294(defun ZEROP (u) 295 "ZEROP(U:any):boolean eval, spread 296Returns T if U is a number and has the value 0 or 0.0. Returns 297NIL otherwise. 298EXPR PROCEDURE ZEROP(U); 299 OR(EQN(U, 0), EQN(U, 0.0));" 300 (cond ((numberp u) (zerop u)) 301 ((math-integerp u) (math-zerop u)))) 302 303 304;;; Functions on Dotted-Pairs 305;;; ========================= 306 307(defalias 'CAR 'car 308 "CAR(U:dotted-pair ):any eval, spread 309CAR(CONS(a, b)) --> a. The left part of U is returned. The type 310mismatch error occurs if U is not a dotted-pair.") 311 312(defalias 'CDR 'cdr 313 "CDR(U:dotted-pair ):any eval, spread 314CDR(CONS(a, b)) --> b. The right part of U is returned. The type 315mismatch error occurs if U is not a dotted-pair.") 316 317;; The composites of CAR and CDR are supported up to 4 levels. The 318;; following code is copied from "subr.el" with minor modifications. 319 320(eval-and-compile ; needed to compile calls of CX..XR in this file. 321(defun esl--compiler-macro-CXXR (form x) 322 (let* ((head (car form)) 323 (n (downcase (symbol-name head))) 324 (head (intern-soft n)) 325 (i (- (length n) 2))) 326 (if (not (string-match "c[ad]+r\\'" n)) 327 (if (and (fboundp head) (symbolp (symbol-function head))) 328 (esl--compiler-macro-CXXR (cons (symbol-function head) (cdr form)) 329 x) 330 (error "Compiler macro for CXXR applied to non-CXXR form")) 331 (while (> i (match-beginning 0)) 332 (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x)) 333 (setq i (1- i))) 334 x)))) 335 336(defun CAAR (x) 337 "Return the car of the car of X." 338 (declare (compiler-macro esl--compiler-macro-CXXR)) 339 (car (car x))) 340 341(defun CADR (x) 342 "Return the car of the cdr of X." 343 (declare (compiler-macro esl--compiler-macro-CXXR)) 344 (car (cdr x))) 345 346(defun CDAR (x) 347 "Return the cdr of the car of X." 348 (declare (compiler-macro esl--compiler-macro-CXXR)) 349 (cdr (car x))) 350 351(defun CDDR (x) 352 "Return the cdr of the cdr of X." 353 (declare (compiler-macro esl--compiler-macro-CXXR)) 354 (cdr (cdr x))) 355 356(defun CAAAR (x) 357 "Return the `car' of the `car' of the `car' of X." 358 (declare (compiler-macro esl--compiler-macro-CXXR)) 359 (car (car (car x)))) 360 361(defun CAADR (x) 362 "Return the `car' of the `car' of the `cdr' of X." 363 (declare (compiler-macro esl--compiler-macro-CXXR)) 364 (car (car (cdr x)))) 365 366(defun CADAR (x) 367 "Return the `car' of the `cdr' of the `car' of X." 368 (declare (compiler-macro esl--compiler-macro-CXXR)) 369 (car (cdr (car x)))) 370 371(defun CADDR (x) 372 "Return the `car' of the `cdr' of the `cdr' of X." 373 (declare (compiler-macro esl--compiler-macro-CXXR)) 374 (car (cdr (cdr x)))) 375 376(defun CDAAR (x) 377 "Return the `cdr' of the `car' of the `car' of X." 378 (declare (compiler-macro esl--compiler-macro-CXXR)) 379 (cdr (car (car x)))) 380 381(defun CDADR (x) 382 "Return the `cdr' of the `car' of the `cdr' of X." 383 (declare (compiler-macro esl--compiler-macro-CXXR)) 384 (cdr (car (cdr x)))) 385 386(defun CDDAR (x) 387 "Return the `cdr' of the `cdr' of the `car' of X." 388 (declare (compiler-macro esl--compiler-macro-CXXR)) 389 (cdr (cdr (car x)))) 390 391(defun CDDDR (x) 392 "Return the `cdr' of the `cdr' of the `cdr' of X." 393 (declare (compiler-macro esl--compiler-macro-CXXR)) 394 (cdr (cdr (cdr x)))) 395 396(defun CAAAAR (x) 397 "Return the `car' of the `car' of the `car' of the `car' of X." 398 (declare (compiler-macro esl--compiler-macro-CXXR)) 399 (car (car (car (car x))))) 400 401(defun CAAADR (x) 402 "Return the `car' of the `car' of the `car' of the `cdr' of X." 403 (declare (compiler-macro esl--compiler-macro-CXXR)) 404 (car (car (car (cdr x))))) 405 406(defun CAADAR (x) 407 "Return the `car' of the `car' of the `cdr' of the `car' of X." 408 (declare (compiler-macro esl--compiler-macro-CXXR)) 409 (car (car (cdr (car x))))) 410 411(defun CAADDR (x) 412 "Return the `car' of the `car' of the `cdr' of the `cdr' of X." 413 (declare (compiler-macro esl--compiler-macro-CXXR)) 414 (car (car (cdr (cdr x))))) 415 416(defun CADAAR (x) 417 "Return the `car' of the `cdr' of the `car' of the `car' of X." 418 (declare (compiler-macro esl--compiler-macro-CXXR)) 419 (car (cdr (car (car x))))) 420 421(defun CADADR (x) 422 "Return the `car' of the `cdr' of the `car' of the `cdr' of X." 423 (declare (compiler-macro esl--compiler-macro-CXXR)) 424 (car (cdr (car (cdr x))))) 425 426(defun CADDAR (x) 427 "Return the `car' of the `cdr' of the `cdr' of the `car' of X." 428 (declare (compiler-macro esl--compiler-macro-CXXR)) 429 (car (cdr (cdr (car x))))) 430 431(defun CADDDR (x) 432 "Return the `car' of the `cdr' of the `cdr' of the `cdr' of X." 433 (declare (compiler-macro esl--compiler-macro-CXXR)) 434 (car (cdr (cdr (cdr x))))) 435 436(defun CDAAAR (x) 437 "Return the `cdr' of the `car' of the `car' of the `car' of X." 438 (declare (compiler-macro esl--compiler-macro-CXXR)) 439 (cdr (car (car (car x))))) 440 441(defun CDAADR (x) 442 "Return the `cdr' of the `car' of the `car' of the `cdr' of X." 443 (declare (compiler-macro esl--compiler-macro-CXXR)) 444 (cdr (car (car (cdr x))))) 445 446(defun CDADAR (x) 447 "Return the `cdr' of the `car' of the `cdr' of the `car' of X." 448 (declare (compiler-macro esl--compiler-macro-CXXR)) 449 (cdr (car (cdr (car x))))) 450 451(defun CDADDR (x) 452 "Return the `cdr' of the `car' of the `cdr' of the `cdr' of X." 453 (declare (compiler-macro esl--compiler-macro-CXXR)) 454 (cdr (car (cdr (cdr x))))) 455 456(defun CDDAAR (x) 457 "Return the `cdr' of the `cdr' of the `car' of the `car' of X." 458 (declare (compiler-macro esl--compiler-macro-CXXR)) 459 (cdr (cdr (car (car x))))) 460 461(defun CDDADR (x) 462 "Return the `cdr' of the `cdr' of the `car' of the `cdr' of X." 463 (declare (compiler-macro esl--compiler-macro-CXXR)) 464 (cdr (cdr (car (cdr x))))) 465 466(defun CDDDAR (x) 467 "Return the `cdr' of the `cdr' of the `cdr' of the `car' of X." 468 (declare (compiler-macro esl--compiler-macro-CXXR)) 469 (cdr (cdr (cdr (car x))))) 470 471(defun CDDDDR (x) 472 "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." 473 (declare (compiler-macro esl--compiler-macro-CXXR)) 474 (cdr (cdr (cdr (cdr x))))) 475 476(defalias 'CONS 'cons 477 "CONS(U:any, V:any):dotted-pair eval, spread 478Returns a dotted-pair which is not EQ to anything and has U as its 479CAR part and V as its CDR part.") 480 481(defalias 'LIST 'list 482 "LIST([U:any]):list noeval, nospread, or macro 483A list of the evaluation of each element of U is returned. The order of 484evaluation need not be first to last as the following definition implies. 485FEXPR PROCEDURE LIST(U); 486 EVLIS U;") 487 488(defun RPLACA (u v) 489 "RPLACA(U:pair, V:any):pair eval, spread 490The car of the pair U is replaced by V and the modified pair U is 491returned. A type mismatch error occurs if U is not a pair." 492 (setcar u v) 493 u) 494 495(defun RPLACD (u v) 496 "RPLACD(U:pair, V:any):pair eval, spread 497The cdr of the pair U is replaced by V and the modified pair U is 498returned. A type mismatch error occurs if U is not a pair." 499 (setcdr u v) 500 u) 501 502;; PSL functions 503 504(defalias 'FIRST 'car 505 "A PSL alternative function name used occasionally in REDUCE.") 506(defsubst SECOND (x) 507 "A PSL alternative function name used occasionally in REDUCE." 508 (CADR x)) 509(defsubst THIRD (x) 510 "A PSL alternative function name used occasionally in REDUCE." 511 (CADDR x)) 512(defsubst FOURTH (x) 513 "A PSL alternative function name used occasionally in REDUCE." 514 (CADDDR x)) 515(defalias 'REST 'cdr 516 "A PSL alternative function name used occasionally in REDUCE.") 517 518(defalias 'LASTPAIR 'last 519 "(lastpair L:pair): any expr 520Returns the last pair of a L. It is often useful to think of this 521as a pointer to the last element for use with destructive 522functions such as rplaca. If L is not a pair then a type mismatch 523error occurs. 524(de lastpair (l) 525 (if (or (atom l) (atom (cdr l))) 526 l 527 (lastpair (cdr l))))") 528 529(defsubst LASTCAR (l) 530 "(lastcar L:pair): any expr 531Returns the last element of the pair L. A type mismatch error 532results if L is not a pair." 533 (if (atom l) l (car (last l)))) 534 535(defsubst NTH (l n) 536 "(nth L:pair N:integer): any expr 537Returns the Nth element of the list L. If L is atomic or contains 538fewer than N elements, an out of range error occurs. 539(de nth (l n) 540 (cond ((null l) (range-error)) 541 ((onep n) (first l)) 542 (t (nth (rest l) (sub1 n))))) 543Note that this definition is not compatible with Common LISP. The 544Common LISP definition reverses the arguments and defines the car 545of a list to be the \"zeroth\" element." 546 (nth (1- n) l)) 547 548(defsubst PNTH (l n) 549 "(pnth L:list N:integer): any expr 550Returns a list starting with the nth element of the list L. Note 551that the result is a pointer to the nth element of L, a 552destructive function like rplaca can be used to modify the 553structure of L. If L is atomic or contains fewer than N elements, 554an out of range error occurs. 555(de pnth (l n) 556 (cond ((onep n) l) 557 ((not (pairp l)) (range-error)) 558 (t (pnth (rest l) (sub1 n)))))" 559 (nthcdr (1- n) l)) 560 561 562;;; Identifiers 563;;; =========== 564 565(defun esl-string-to-bigint (s) 566 "Convert string S to a bigint." 567 (math-read-number s)) 568 569(defun COMPRESS (u) 570 "COMPRESS(U:id-list):{atom-vector} eval, spread 571U is a list of single character identifiers which is built into a Standard 572LISP entity and returned. Recognized are numbers, strings, and 573identifiers with the escape character prefixing special characters. The 574formats of these items appear in \"Primitive Data Types\" section 2.1 575on page 3. Identifiers are not interned on the OBLIST. Function 576pointers may be compressed but this is an undefined use. If an entity 577cannot be parsed out of U or characters are left over after parsing 578an error occurs: 579***** Poorly formed atom in COMPRESS 580 581In ESL: Down-case LAMBDA, NIL, QUOTE and T (but not !T). 582Retain ! preceding an identifier beginning with : to prevent it 583becoming a keyword, avoiding mangling `:', `:=' and the prompt. 584Also, remove ! preceding an identifier and downcase the 585identifier to facilitate direct access to Emacs Lisp symbols." 586 ;; Concatenate the characters into a string and then handle any ! 587 ;; characters as follows: 588 ;; A string begins with " and should retain any ! characters without 589 ;; change. 590 ;; A number begins with - or a digit and should not contain any ! 591 ;; characters. 592 ;; Otherwise, assume an identifier. Any ! characters should be 593 ;; deleted, except that !! should be replaced by !. 594 ;; However, retain a leading !: (except in special cases) to prevent 595 ;; a Standard LISP identifier being an Elisp keyword. This should 596 ;; perhaps be handled in a more consistent way! 597 (if (equal u '(T)) 't 598 (let* ((s (mapconcat #'symbol-name u "")) 599 (s0 (aref s 0))) 600 (cond ((eq s0 ?\") ; STRING 601 ;; In Standard Lisp, "" in a string represents ": 602 (replace-regexp-in-string "\"\"" "\"" (substring s 1 -1))) 603 ((or (eq s0 ?-) 604 (and (>= s0 ?0) (<= s0 ?9))) ; NUMBER 605 (if (string-match "\\." s) 606 ;; Number is a float. (Emacs does not accept .E as in 607 ;; 123.E-2 so delete such a ".".) 608 (string-to-number (replace-regexp-in-string "\\.E" "E" s)) 609 ;; Number is a (possibly big) integer. 610 (esl-string-to-bigint s))) 611 (t ; IDENTIFIER 612 (let ((l (length s)) (i 0) (ss nil) e) 613 ;; Retain leading !: in "!:..." but not in "!:", "!:!=" 614 ;; or "!:! ", which is used in the REDUCE prompt: 615 (if (and (eq s0 ?!) (eq (aref s 1) ?:) (> l 2) 616 (not (equal s "!:! ")) (not (equal s "!:!="))) 617 (setq i 2 ss '(?: ?!))) 618 (while (< i l) ; delete ! but !! --> ! 619 (if (eq (setq e (aref s i)) ?!) 620 (when (eq (aref s (1+ i)) ?!) 621 (push ?! ss) 622 (setq i (1+ i))) 623 (push e ss)) 624 (setq i (1+ i))) 625 (setq ss (apply #'string (reverse ss))) 626 (if (member ss '("LAMBDA" "NIL" "QUOTE")) 627 (setq ss (downcase ss)) 628 (if (and (eq (aref ss 0) ?) (> (length ss) 1)) 629 (setq ss (downcase (substring ss 1))))) 630 (make-symbol ss))))))) ; uninterned symbol 631 632(defun esl-bigint-p (b) 633 "Return t if B is a bigint." 634 (math-integerp b)) 635 636(defun esl-bigint-to-string (b) 637 "Convert bigint B to a string." 638 (math-format-number b)) 639 640(defun EXPLODE (u) 641 "EXPLODE(U:{atom}-{vector}):id-list eval, spread 642Returned is a list of interned characters representing the characters to 643print of the value of U. The primitive data types have these formats: 644integer -- Leading zeroes are suppressed and a minus sign prefixes the 645 digits if the integer is negative. 646floating -- The value appears in the format [-]0.nn...nnE[-]mm if the 647 magnitude of the number is too large or small to display in 648 [-]nnnn.nnnn format. The crossover point is determined by the 649 implementation. 650id -- The characters of the print name of the identifier are produced 651 with special characters prefixed with the escape character. 652string -- The characters of the string are produced surrounded by 653 double quotes \"...\". 654function-pointer -- The value of the function-pointer is created as a 655 list of characters conforming to the conventions of the system site. 656The type mismatch error occurs if U is not a number, identifier, 657string, or function-pointer." 658 (seq-map 659 (lambda (c) (intern (string c))) 660 (cond ((or (stringp u) (numberp u)) (prin1-to-string u)) 661 ((esl-bigint-p u) (esl-bigint-to-string u)) 662 ;; Assume identifier -- must insert ! before a leading digit and 663 ;; before any special characters in string without \ escapes: 664 (t (let* ((s (prin1-to-string u t)) (l (length s)) 665 (i 0) (ss nil) e) 666 (while (< i l) 667 (setq e (aref s i)) 668 (if (not (or (and (not (eq i 0)) (>= e ?0) (<= e ?9)) 669 (and (>= e ?A) (<= e ?Z)) 670 (and (>= e ?a) (<= e ?z)))) ; unnecessary as ids UC? 671 (push ?! ss)) 672 (push e ss) 673 (setq i (1+ i))) 674 (reverse ss)))))) 675 676(defalias 'GENSYM (if (fboundp 'gensym) 'gensym 'cl-gensym) 677 ;; gensym was not defined before Emacs 26 678 "GENSYM():identifier eval, spread 679Creates an identifier which is not interned on the OBLIST and 680consequently not EQ to anything else.") 681 682(defun INTERN (u) 683 "INTERN(U:{id,string}):id eval, spread 684INTERN searches the OBLIST for an identifier with the same print 685name as U and returns the identifier on the OBLIST if a match is 686found. Any properties and global values associated with U may be 687lost. If U does not match any entry, a new one is created and 688returned. If U has more than the maximum number of characters 689permitted by the implementation (the minimum number is 24) an 690error occurs: 691***** Too many characters to INTERN" 692 (intern (if (symbolp u) (symbol-name u) u))) 693 694(defun REMOB (u) 695 "REMOB(U:id):id eval, spread 696If U is present on the OBLIST it is removed. This does not affect U 697having properties, flags, functions and the like. U is returned." 698 (unintern u nil) 699 u) 700 701 702;;; Property List Functions 703;;; ======================= 704 705;; In file "rlisp/superv.red" is the statement 706;; 707;; FLAG('(DEFLIST FLAG FLUID GLOBAL REMFLAG REMPROP UNFLUID),'EVAL); 708;; 709;; which (I think) means that the functions listed are evaluated even 710;; after `ON DEFN', which is necessary to ensure that some source code 711;; reads correctly. However, `REMPROP' is usually followed by `PUT' 712;; to reinstate whatever property was removed, but `PUT' is not 713;; flagged `EVAL', so this reinstatement doesn't happen because 714;; evaluating `PUT' at the wrong time can cause similar problems, 715;; e.g. with `rlisp88'. Hence, viewing code with `ON DEFN' can break 716;; subsequent code. For example, inputting "rlisp/module.red" with 717;; `ON DEFN' removes the `STAT' property from `LOAD_PACKAGE', which 718;; then no longer works correctly. This is a major problem for the 719;; way I generate fasl files! 720;; 721;; I therefore provide a workaround to make the functions DEFLIST, 722;; FLAG, REMFLAG and REMPROP save the property list of any identifier 723;; before modifying it if it has not already been saved, and provide a 724;; function to reinstate the saved property list. I use this facility 725;; when generating fasl files and in `OFF DEFN' (see "eslrend.red"), 726;; so that ESL REDUCE should be immune to this `ON DEFN' side-effect. 727;; 728;; However, this facility only applies to reading REDUCE code and must 729;; be disabled when loading a Lisp file, i.e. when the variable 730;; `load-in-progress' is non-nil. This is particularly important when 731;; building REDUCE. 732 733(defvar *DEFN nil) 734 735(defvar esl--saved-plist-alist nil 736 "Association list of symbols and their saved property lists. 737Its value should normally be nil, except while ON DEFN.") 738 739(defun esl--save-plist (symbol) 740 "Save property list of symbol SYMBOL if not already saved. 741Do not do this if Lisp file load in progress." 742 (or load-in-progress 743 (assq symbol esl--saved-plist-alist) 744 (push (cons symbol (copy-tree (symbol-plist symbol))) 745 esl--saved-plist-alist))) 746 747(defun esl-reinstate-plists () 748 "Reinstate all saved property lists. 749Do not do this if Lisp file load in progress." 750 (unless load-in-progress 751 (mapc (lambda (s) (setplist (car s) (cdr s))) 752 esl--saved-plist-alist) 753 (setq esl--saved-plist-alist nil))) 754 755 756(defun FLAG (u v) 757 "FLAG(U:id-list, V:id):NIL eval, spread 758U is a list of ids which are flagged with V. The effect of FLAG is 759that FLAGP will have the value T for those ids of U which were 760flagged. Both V and all the elements of U must be identifiers or the 761type mismatch error occurs." 762 (if *DEFN (mapc #'esl--save-plist u)) 763 (mapc (lambda (x) (put x v t)) u) 764 nil) 765 766(defun FLAGP (u v) 767 "FLAGP(U:any, V:any):boolean eval, spread 768Returns T if U has been previously flagged with V, else NIL. Returns 769NIL if either U or V is not an id." 770 (if (and (symbolp u) (symbolp v)) (get u v))) 771 772(defun GET (u ind) 773 "GET(U:any, IND:id):any eval, spread 774Returns the property associated with indicator IND from the 775property list of U. If U does not have indicator IND, NIL is 776returned. GET cannot be used to access functions (use GETD 777instead)." 778 ;; MUST return nil if u is not a symbol. 779 (if (symbolp u) (get u ind))) 780 781(defmacro PUT (u ind prop) 782 "PUT(U:id, IND:id, PROP:any):any eval, spread 783The indicator IND with the property PROP is placed on the 784property list of the id U. If the action of PUT occurs, the value 785of PROP is returned. If either of U and IND are not ids the type 786mismatch error will occur and no property will be placed. PUT 787cannot be used to define functions (use PUTD instead)." 788 `(put ,u ,ind ,prop)) 789 790(defun REMFLAG (u v) 791 "REMFLAG(U:any-list, V:id):NIL eval, spread 792Removes the flag V from the property list of each member of the 793list U. Both V and all the elements of U must be ids or the type 794mismatch error will occur." 795 (if *DEFN (mapc #'esl--save-plist u)) 796 (mapc (lambda (x) (cl-remprop x v)) u) 797 nil) 798 799(defun REMPROP (u ind) 800 "REMPROP(U:any, IND:any):any eval, spread 801Removes the property with indicator IND from the property list of U. 802Returns the removed property or NIL if there was no such indicator." 803 (prog1 804 (get u ind) 805 (if *DEFN (esl--save-plist u)) 806 (cl-remprop u ind))) 807 808 809;;; Function Definition 810;;; =================== 811 812;; NOTE that Standard Lisp macros are nospread and therefore take a 813;; single parameter that gets the list of actual arguments, so `DM' 814;; and `PUTD' must convert the macro parameter into an &rest 815;; parameter. Also, when a Standard Lisp macro is called it receives 816;; its name as its first argument, i.e. the single parameter evaluates 817;; to the COMPLETE function call, so `DM' and `PUTD' must modify the 818;; macro argument list within the body lambda expression. 819 820;; Ref. Standard LISP Report, page 9: "When a macro invocation is 821;; encountered, the body of the macro, a lambda expression, is invoked 822;; as a NOEVAL, NOSPREAD function with the macro's invocation bound as 823;; a list to the macros single formal parameter." 824 825;; REDUCE handles macros specially, assuming they are Standard LISP 826;; macros, whereas ESL functions that are actually defined as Emacs 827;; Lisp macros need to be handled by REDUCE as if they were 828;; EXPRs. Therefore, it is important that the function type defaults 829;; to EXPR, so only macros defined using DM or PUTD are given the 830;; property ESL--FTYPE with value MACRO. The ESL--FTYPE property is 831;; required so that macros defined in REDUCE can be distinguished from 832;; Emacs Lisp macros. Normal functions defined using DE or PUTD are 833;; given the property ESL--FTYPE with value EXPR just for symmetry, 834;; but this property value is not actually used by GETD. 835 836(defmacro DE (fname params fn) 837 "DE(FNAME:id, PARAMS:id-list, FN:any):id noeval, nospread 838The function FN with the formal parameter list PARAMS is added to 839the set of defined functions with the name FNAME. Any previous 840definitions of the function are lost. The function created is of 841type EXPR. If the !*COMP variable is non-NIL, the EXPR is first 842compiled. The name of the defined function is returned. 843FEXPR PROCEDURE DE(U); 844 PUTD(CAR U, 'EXPR, LIST('LAMBDA, CADR U, CADDR U));" 845 (declare (debug (&define name lambda-list def-body))) 846 `(progn 847 (put ',fname 'ESL--FTYPE 'EXPR) 848 (defun ,fname ,params ,fn) 849 ,@(if *COMP ; splice in list of content or nil. 850 ;; It makes no sense to include code to compile this 851 ;; function when the function definition is being compiled 852 ;; into a fasl file, so examine *COMP when the macro is 853 ;; expanded/compiled and ensure that *COMP is nil when fasl 854 ;; files are being generated. 855 `((let ((byte-compile-warnings '(not free-vars unresolved))) 856 (byte-compile ',fname)))) 857 ',fname)) 858 859;; *** I'm hoping df is not actually required! *** 860;; DF(FNAME:id, PARAM:id-list, FN:any):id noeval, nospread 861;; The function FN with formal parameter PARAM is added to the set 862;; of defined functions with the name FNAME. Any previous definitions 863;; of the function are lost. The function created is of type FEXPR. If 864;; the !*COMP variable is T the FEXPR is first compiled. The name 865;; of the defined function is returned. 866;; FEXPR PROCEDURE DF(U); 867;; PUTD(CAR U, 'FEXPR, LIST('LAMBDA, CADR U, CADDR U)); 868 869(defmacro DM (mname param fn) 870 "DM(MNAME:id, PARAM:id-list, FN:any):id noeval, nospread 871The macro FN with the formal parameter PARAM is added to the set 872of defined functions with the name MNAME. Any previous 873definitions of the function are overwritten. The function created 874is of type MACRO. The name of the macro is returned. 875FEXPR PROCEDURE DM(U); 876 PUTD(CAR U, 'MACRO, LIST('LAMBDA, CADR U, CADDR U));" 877 (declare (debug (&define name lambda-list def-body))) 878 `(progn 879 (put ',mname 'ESL--FTYPE 'MACRO) 880 ;; Save the (uncompiled) SL macro form: 881 (put ',mname 'ESL--MACRO '(MACRO lambda ,param ,fn)) 882 ;; param must be a list containing a single identifier, which 883 ;; must therefore be spliced into the macro definition. 884 (defmacro ,mname (&rest ,@param) ; spread the arguments 885 ;; Include macro name as first arg: 886 (setq ,@param (cons ',mname ,@param)) 887 ,fn) 888 ,@(if *COMP ; see DE 889 `((let ((byte-compile-warnings '(not free-vars unresolved))) 890 (byte-compile ',mname)))) 891 ',mname)) 892 893(defun GETD (fname) 894 ;; BEWARE that this definition may not work properly for functions 895 ;; defined in Emacs Lisp, which will generally contain a 896 ;; documentation string and then multiple body forms! 897 "GETD(FNAME:any):{NIL, dotted-pair} eval, spread 898If FNAME is not the name of a defined function, NIL is returned. If 899FNAME is a defined function then the dotted-pair 900\(TYPE:ftype . DEF:{function-pointer, lambda}) 901is returned." 902 (and (symbolp fname) 903 (let ((def (symbol-function fname))) 904 (if def 905 (if (eq (get fname 'ESL--FTYPE) 'MACRO) 906 ;; Return the (uncompiled) SL macro form: 907 (get fname 'ESL--MACRO) 908 (cons 'EXPR def)))))) 909 910(defun PUTD (fname type body) 911 "PUTD(FNAME:id, TYPE:ftype, BODY:function):id eval, spread 912Creates a function with name FNAME and definition BODY of type 913TYPE. If PUTD succeeds the name of the defined function is 914returned. The effect of PUTD is that GETD will return a 915dotted-pair with the functions type and definition. Likewise the 916GLOBALP predicate will return T when queried with the function 917name. If the function FNAME has already been declared as a 918GLOBAL or FLUID variable the error: 919***** FNAME is a non-local variable 920occurs and the function will not be defined. If function FNAME 921already exists a warning message will appear: 922*** FNAME redefined 923The function defined by PUTD will be compiled before definition if 924the !*COMP global variable is non-NIL." 925 (if (or (get fname 'GLOBAL) ; only if explicitly declared 926 (FLUIDP fname)) 927 (error "%s is a non-local variable" fname)) 928 (if (and *REDEFMSG (symbol-function fname)) 929 (message "*** %s redefined" fname)) 930 ;; body = (lambda (u) body-form) or function object 931 (fset fname (if (eq type 'MACRO) 932 (let ((u (CAADR body))) ; must be a symbol! 933 ;; Save the (uncompiled) SL macro form: 934 (put fname 'ESL--MACRO (cons 'MACRO body)) 935 `(macro 936 lambda (&rest ,u) ; spread the arguments 937 ;; Include macro name as first arg: 938 (setq ,u (cons ',fname ,u)) 939 ;; Splice in body-form: 940 ,@(cddr body))) 941 body)) 942 (put fname 'ESL--FTYPE type) 943 (if *COMP 944 (let ((byte-compile-warnings '(not free-vars unresolved))) 945 (byte-compile fname))) 946 fname) 947 948(defun REMD (fname) 949 "REMD(FNAME:id):{NIL, dotted-pair} eval, spread 950Removes the function named FNAME from the set of defined 951functions. Returns the (ftype . function) dotted-pair or NIL as 952does GETD. The global/function attribute of FNAME is removed and 953the name may be used subsequently as a variable." 954 (let ((def (GETD fname))) 955 (when def 956 (fmakunbound fname) 957 (cl-remprop fname 'ESL--FTYPE)) 958 def)) 959 960 961;;; Variables and Bindings 962;;; ====================== 963 964(defun esl--fluid (x) 965 "If id X is already GLOBAL then display a warning; otherwise flag X as FLUID." 966 (if (GLOBALP x) 967 (lwarn '(esl fluid) :error 968 "GLOBAL %s cannot be changed to FLUID" x) 969 (put x 'FLUID t))) 970 971(defmacro FLUID (idlist) 972 "FLUID(IDLIST:id-list):NIL eval, spread 973The ids in IDLIST are declared as FLUID type variables (ids not 974previously declared are initialized to NIL). Variables in IDLIST 975already declared FLUID are ignored. Changing a variable's type 976from GLOBAL to FLUID is not permissible and results in the error: 977***** ID cannot be changed to FLUID" 978 ;; A warning, as for PSL, is more convenient than an error! 979 (if (memq (car idlist) '(quote QUOTE)) ; QUOTE (UC) should now be redundant 980 ;; Assume a top-level call that needs to output `defvar' forms 981 ;; at compile time. 982 (cons 'prog1 983 (cons nil 984 (mapcan 985 (lambda (x) 986 `((with-no-warnings ; suppress warning about lack of prefix 987 (defvar ,x nil "Standard LISP fluid variable.")) 988 (unless (FLUIDP ',x) 989 (esl--fluid ',x)))) 990 (eval idlist)))) 991 ;; Assume a run-time call that need not output `defvar' forms. 992 `(prog1 nil 993 (mapc 994 (lambda (x) 995 (unless (FLUIDP x) 996 (esl--fluid x) 997 (set x nil))) 998 ,idlist)))) 999 1000(defun FLUIDP (u) 1001 "FLUIDP(U:any):boolean eval, spread 1002If U has been declared FLUID (by declaration only) T is returned, 1003otherwise NIL is returned." 1004 (get u 'FLUID)) 1005 1006(defun esl--global (x) 1007 "If id X is already FLUID then display a warning; otherwise flag X as GLOBAL." 1008 (if (FLUIDP x) 1009 (lwarn '(esl global) :error 1010 "FLUID %s cannot be changed to GLOBAL" x) 1011 (put x 'GLOBAL t))) 1012 1013(defmacro GLOBAL (idlist) 1014 "GLOBAL(IDLIST:id-list):NIL eval, spread 1015The ids of IDLIST are declared GLOBAL type variables. If an id 1016has not been declared previously it is initialized to 1017NIL. Variables already declared GLOBAL are ignored. Changing a 1018variables type from FLUID to GLOBAL is not permissible and 1019results in the error: 1020***** ID cannot be changed to GLOBAL" 1021 ;; A warning, as for PSL, is more convenient than an error! 1022 (if (memq (car idlist) '(quote QUOTE)) ; QUOTE (UC) should now be redundant 1023 ;; Assume a top-level call that needs to output `defvar' forms 1024 ;; at compile time. 1025 (cons 'prog1 1026 (cons nil 1027 (mapcan 1028 (lambda (x) 1029 `((with-no-warnings ; suppress warning about lack of prefix 1030 (defvar ,x nil "Standard LISP global variable.")) 1031 (unless (GLOBALP ',x) 1032 (esl--global ',x)))) 1033 (eval idlist)))) 1034 ;; Assume a run-time call that need not output `defvar' forms. 1035 `(prog1 nil 1036 (mapc 1037 (lambda (x) 1038 (unless (GLOBALP x) 1039 (esl--global x) 1040 (set x nil))) 1041 ,idlist)))) 1042 1043(defun GLOBALP (u) 1044 "GLOBALP(U:any):boolean eval, spread 1045If U has been declared GLOBAL or is the name of a defined function, 1046T is returned, else NIL is returned." 1047 (or (get u 'GLOBAL) (symbol-function u))) 1048 1049;; (defalias 'SET 'set 1050;; ;; Auto fluid not implemented! 1051;; "SET(EXP:id, VALUE:any):any eval, spread 1052;; EXP must be an identifier or a type mismatch error occurs. The 1053;; effect of SET is replacement of the item bound to the identifier 1054;; by VALUE. If the identifier is not a local variable or has not 1055;; been declared GLOBAL it is automatically declared FLUID with the 1056;; resulting warning message: 1057;; *** EXP declared FLUID 1058;; EXP must not evaluate to T or NIL or an error occurs: 1059;; ***** Cannot change T or NIL") 1060 1061(defmacro SET (exp value) ; EXPERIMENTAL! 1062 ;; Auto fluid not implemented! 1063 "SET(EXP:id, VALUE:any):any eval, spread 1064EXP must be an identifier or a type mismatch error occurs. The 1065effect of SET is replacement of the item bound to the identifier 1066by VALUE. If the identifier is not a local variable or has not 1067been declared GLOBAL it is automatically declared FLUID with the 1068resulting warning message: 1069*** EXP declared FLUID 1070EXP must not evaluate to T or NIL or an error occurs: 1071***** Cannot change T or NIL" 1072 (declare (debug set)) 1073 `(set ,exp ,value)) 1074 1075(defmacro SETQ (variable value) ; boot.el does not compile if alias 1076 ;; Auto fluid not implemented! 1077 "SETQ(VARIABLE:id, VALUE:any):any noeval, nospread 1078If VARIABLE is not local or GLOBAL it is by default declared 1079FLUID and the warning message: 1080*** VARIABLE declared FLUID 1081appears. The value of the current binding of VARIABLE is replaced 1082by the value of VALUE. VARIABLE must not be T or NIL or an 1083error occurs: 1084***** Cannot change T or NIL 1085MACRO PROCEDURE SETQ(X); 1086 LIST('SET, LIST('QUOTE, CADR X), CADDR X);" 1087 (declare (debug setq)) 1088 `(setq ,variable ,value)) 1089 1090(defun UNFLUID (idlist) 1091 "UNFLUID(IDLIST:id-list):NIL eval, spread 1092The variables in IDLIST that have been declared as FLUID 1093variables are no longer considered as fluid variables. Others are 1094ignored. This affects only compiled functions as free variables 1095in interpreted functions are automatically considered fluid." 1096 (mapc (lambda (x) 1097 (if (FLUIDP x) (cl-remprop x 'FLUID))) 1098 idlist) 1099 nil) 1100 1101 1102;;; Program Feature Functions 1103;;; ========================= 1104 1105(defalias 'GO 'go 1106 "GO(LABEL:id) noeval, nospread -- OK in cl-tagbody 1107GO alters the normal flow of control within a PROG function. The 1108next statement of a PROG function to be evaluated is immediately 1109preceded by LABEL. A GO may only appear in the following situations: 11101. At the top level of a PROG referencing a label which also 1111 appears at the top level of the same PROG. 11122. As the consequent of a COND item of a COND appearing on the 1113 top level of a PROG. 11143. As the consequent of a COND item which appears as the 1115 consequent of a COND item to any level. 11164. As the last statement of a PROGN which appears at the top 1117 level of a PROG or in a PROGN appearing in the consequent of a 1118 COND to any level subject to the restrictions of 2 and 3. 11195. As the last statement of a PROGN within a PROGN or as the 1120 consequent of a COND in a PROGN to any level subject to the 1121 restrictions of 2, 3 and 4. 1122If LABEL does not appear at the top level of the PROG in which 1123the GO appears, an error occurs: 1124***** LABEL is not a known label 1125If the GO has been placed in a position not defined by rules 1-5, 1126another error is detected: 1127***** Illegal use of GO to LABEL") 1128 1129(def-edebug-spec GO 0) 1130 1131(defmacro PROG (vars &rest program) 1132 "PROG(VARS:id-list, [PROGRAM:{id, any}]):any noeval, nospread 1133VARS is a list of ids which are considered fluid when the PROG is 1134interpreted and local when compiled. The PROGs variables are 1135allocated space when the PROG form is invoked and are deallocated 1136when the PROG is exited. PROG variables are initialized to 1137NIL. The PROGRAM is a set of expressions to be evaluated in order 1138of their appearance in the PROG function. Identifiers appearing 1139in the top level of the PROGRAM are labels which can be 1140referenced by GO. The value returned by the PROG function is 1141determined by a RETURN function or NIL if the PROG \"falls 1142through\"." 1143 (declare (debug ((&rest symbolp) &rest &or symbolp form))) 1144 ;; This is essentially how `cl-prog' is defined in `cl-macs.el'. 1145 1146 ;; But cl-tagbody does not like nil sexps in its body, which REDUCE 1147 ;; may generate, so delete them. 1148 `(cl-block nil 1149 (let ,vars 1150 (cl-tagbody . ,(delq nil program))))) 1151 1152(defmacro PROGN (&rest u) ; does not work as alias 1153 "PROGN([U:any]):any noeval, nospread 1154U is a set of expressions which are executed sequentially. The 1155value returned is the value of the last expression." 1156 (declare (debug (body))) ; no spec for progn! 1157 `(progn ,@u)) 1158 1159(defalias 'PROG2 'prog2 1160 "PROG2(A:any, B:any)any eval, spread 1161Returns the value of B. 1162EXPR PROCEDURE PROG2(A, B); 1163 B;") 1164 1165;; (defalias 'RETURN 'cl-return 1166;; "RETURN(U:any) eval, spread 1167;; Within a PROG, RETURN terminates the evaluation of a PROG 1168;; and returns U as the value of the PROG. The restrictions on the 1169;; placement of RETURN are exactly those of GO. Improper placement 1170;; of RETURN results in the error: 1171;; ***** Illegal use of RETURN") 1172 1173;; (def-edebug-spec RETURN t) 1174 1175(defmacro RETURN (u) ; EXPERIMENTAL! 1176 "RETURN(U:any) eval, spread 1177Within a PROG, RETURN terminates the evaluation of a PROG 1178and returns U as the value of the PROG. The restrictions on the 1179placement of RETURN are exactly those of GO. Improper placement 1180of RETURN results in the error: 1181***** Illegal use of RETURN" 1182 (declare (debug t)) 1183 `(cl-return ,u)) 1184 1185 1186;;; Error Handling 1187;;; ============== 1188 1189(defun ERROR (number message) 1190 "ERROR(NUMBER:integer, MESSAGE:any) eval, spread 1191NUMBER and MESSAGE are passed back to a surrounding ERRORSET (the 1192Standard LISP reader has an ERRORSET). MESSAGE is placed in the 1193global variable EMSG!* and the error number becomes the value of 1194the surrounding ERRORSET. FLUID variables and local bindings are 1195unbound to return to the environment of the ERRORSET. Global 1196variables are not affected by the process." 1197 (setq EMSG* message) 1198 (signal 'user-error (list number message))) 1199 1200(define-error 'user-error-no-message "" 'user-error) 1201 1202(defun ERROR1 () 1203 "This is the simplest error return, without a message printed. 1204It can be defined as ERROR(99,NIL) if necessary. 1205In PSL it is throw('!$error!$,99)." 1206 (signal 'user-error-no-message nil)) 1207 1208(defun ERRORSET (u msgp tr) 1209 "ERRORSET(U:any, MSGP:boolean, TR:boolean):any eval, spread 1210If an error occurs during the evaluation of U, the value of 1211NUMBER from the ERROR call is returned as the value of 1212ERRORSET. In addition, if the value of MSGP is non-NIL, the 1213MESSAGE from the ERROR call is displayed upon both the standard 1214output device and the currently selected output device unless the 1215standard output device is not open. The message appears prefixed 1216with 5 asterisks. The MESSAGE list is displayed without top level 1217parentheses. The MESSAGE from the ERROR call will be available in 1218the global variable EMSG!*. The exact format of error messages 1219generated by Standard LISP functions described in this document 1220are not fixed and should not be relied upon to be in any 1221particular form. Likewise, error numbers generated by Standard 1222LISP functions are implementation dependent. 1223If no error occurs during the evaluation of U, the value of 1224 (LIST (EVAL U)) is returned. 1225If an error has been signaled and the value of TR is non-NIL a 1226trace-back sequence will be initiated on the selected output 1227device. The traceback will display information such as unbindings 1228of FLUID variables, argument lists and so on in an implementation 1229dependent format." 1230 (let ((debug-on-error (or debug-on-error tr))) 1231 (condition-case err ; error description variable 1232 (list (eval u)) ; protected form 1233 (user-error-no-message nil) ; error1 called -- no message or debugging 1234 ((user-error debug) ; Standard LISP error 1235 (if msgp 1236 (let ((msg (cddr err))) 1237 (message "***** %s" 1238 (if (listp msg) 1239 ;; (mapconcat 'identity msg " ") 1240 ;; msg may contain objects other than 1241 ;; strings, but this formatting may not be optimal: 1242 (mapconcat (lambda (x) (prin1-to-string x t)) msg " ") 1243 msg)))) 1244 (cadr err)) 1245 ((error debug) ; Emacs Lisp error 1246 (let ((msg (error-message-string err))) 1247 (if msgp (message "***** %s" msg)) 1248 ;; Should return the error number, but internal elisp errors 1249 ;; will not have one, so return the error message string 1250 ;; instead. What matters is that an atom is returned. 1251 msg))))) 1252 1253 1254;;; Vectors 1255;;; ======= 1256 1257(defun GETV (v index) 1258 "GETV(V:vector, INDEX:integer):any eval, spread 1259Returns the value stored at position INDEX of the vector V. The 1260type mismatch error may occur. An error occurs if the INDEX does 1261not lie within 0...UPBV(V) inclusive: 1262***** INDEX subscript is out of range" 1263 (aref v index)) 1264 1265(defalias 'IGETV 'GETV) 1266 1267(defun MKVECT (uplim) 1268 "MKVECT(UPLIM:integer):vector eval, spread 1269Defines and allocates space for a vector with UPLIM+1 elements 1270accessed as 0...UPLIM. Each element is initialized to NIL. An error 1271will occur if UPLIM is < 0 or there is not enough space for a vector 1272of this size: 1273***** A vector of size UPLIM cannot be allocated" 1274 (make-vector (1+ uplim) nil)) 1275 1276(defun PUTV (v index value) 1277 "PUTV(V:vector, INDEX:integer, VALUE:any):any eval, spread 1278Stores VALUE into the vector V at position INDEX. VALUE is 1279returned. The type mismatch error may occur. If INDEX does not 1280lie in 0...UPBV(V) an error occurs: 1281***** INDEX subscript is out of range" 1282 (aset v index value)) 1283 1284(defalias 'IPUTV 'PUTV) 1285 1286(defun UPBV (u) 1287 "UPBV(U:any):NIL,integer eval, spread 1288Returns the upper limit of U if U is a vector, or NIL if it is not." 1289 (if (vectorp u) (1- (length u)))) 1290 1291 1292;;; Boolean Functions and Conditionals 1293;;; ================================== 1294 1295(defmacro AND (&rest u) ; boot.el does not compile if alias 1296 "AND([U:any]):extra-boolean noeval, nospread 1297AND evaluates each U until a value of NIL is found or the end of the 1298list is encountered. If a non-NIL value is the last value it is returned, 1299or NIL is returned. 1300FEXPR PROCEDURE AND(U); 1301BEGIN 1302 IF NULL U THEN RETURN NIL; 1303LOOP: IF NULL CDR U THEN RETURN EVAL CAR U 1304 ELSE IF NULL EVAL CAR U THEN RETURN NIL; 1305 U := CDR U; 1306 GO LOOP 1307END;" 1308 (declare (debug t)) 1309 `(and ,@u)) 1310 1311(defmacro COND (&rest u) ; does not work as alias 1312 "COND([U:cond-form]):any noeval, nospread 1313The antecedents of all U's are evaluated in order of their 1314appearance until a non-NIL value is encountered. The consequent 1315of the selected U is evaluated and becomes the value of the 1316COND. The consequent may also contain the special functions GO 1317and RETURN subject to the restraints given for these functions in 1318\"Program Feature Functions\", section 3.7 on page 22. In these 1319cases COND does not have a defined value, but rather an 1320effect. If no antecedent is non-NIL the value of COND is NIL. An 1321error is detected if a U is improperly formed: 1322***** Improper cond-form as argument of COND" 1323 (declare (debug cond)) 1324 `(cond ,@u)) 1325 1326(defalias 'NOT 'null ; not is defined this way in Emacs Lisp 1327 "NOT(U:any):boolean eval, spread 1328If U is NIL, return T else return NIL (same as function NULL). 1329EXPR PROCEDURE NOT(U); 1330 U EQ NIL;") 1331 1332(defmacro OR (&rest u) ; boot.el does not compile if alias 1333 "OR([U:any]):extra-boolean noeval, nospread 1334U is any number of expressions which are evaluated in order of their 1335appearance. When one is found to be non-NIL it is returned as the 1336value of OR. If all are NIL, NIL is returned. 1337FEXPR PROCEDURE OR(U); 1338BEGIN SCALAR X; 1339LOOP: IF NULL U THEN RETURN NIL 1340 ELSE IF (X := EVAL CAR U) THEN RETURN X; 1341 U := CDR U; 1342 GO LOOP 1343END;" 1344 (declare (debug t)) 1345 `(or ,@u)) 1346 1347 1348;;; Arithmetic Functions 1349;;; ==================== 1350 1351;; Run the Calc library quietly: 1352(setq calc-display-working-message nil) 1353 1354(defmacro bigpos (&rest digits) 1355 "Return a big integer representation. 1356A call of the form (bigpos d1 ... dn) is self-quoting; the result 1357of evaluating it is the big integer representation itself." 1358 ;; cf. the definition of `lambda' in "subr.el". 1359 (list 'quote (cons 'bigpos digits))) 1360 1361(defmacro bigneg (&rest digits) 1362 "Return a big integer representation. 1363A call of the form (bigneg d1 ... dn) is self-quoting; the result 1364of evaluating it is the big integer representation itself." 1365 ;; cf. the definition of `lambda' in "subr.el". 1366 (list 'quote (cons 'bigneg digits))) 1367 1368(defun esl--arith-op2 (op math-op u v) 1369 "OP(U:number, V:number); MATH-OP is math-integer version of OP." 1370 (if (math-integerp u) 1371 (if (math-integerp v) 1372 (funcall math-op u v) 1373 ;; v is a float or invalid: 1374 (funcall op (FLOAT u) v)) 1375 ;; u is a float or invalid: 1376 (funcall op u (FLOAT v)))) 1377 1378(defun ABS (u) 1379 "ABS(U:number):number eval, spread 1380Returns the absolute value of its argument. 1381EXPR PROCEDURE ABS(U); 1382 IF LESSP(U, 0) THEN MINUS(U) ELSE U;" 1383 (if (numberp u) 1384 (abs u) 1385 ;; u is a math-integer or invalid: 1386 (math-abs u))) 1387 1388(defun ADD1 (u) 1389 "ADD1(U:number):number eval, spread 1390Returns the value of U plus 1 of the same type as U (fixed or floating). 1391EXPR PROCEDURE ADD1(U); 1392 PLUS2(U, 1);" 1393 (PLUS2 u 1)) 1394 1395(defun DIFFERENCE (u v) 1396 "DIFFERENCE(U:number, V:number):number eval, spread 1397The value U - V is returned." 1398 (esl--arith-op2 #'- #'math-sub u v)) 1399 1400(defun DIVIDE (u v) 1401 "DIVIDE(U:number, V:number):dotted-pair eval, spread 1402The dotted-pair (quotient . remainder) is returned. The quotient 1403part is computed the same as by QUOTIENT and the remainder 1404the same as by REMAINDER. An error occurs if division by zero is 1405attempted: 1406***** Attempt to divide by 0 in DIVIDE 1407EXPR PROCEDURE DIVIDE(U, V); 1408 (QUOTIENT(U, V) . REMAINDER(U, V));" 1409 (cons (QUOTIENT u v) (REMAINDER u v))) 1410 1411;; (EXPT 10 40) overflows! 1412;; (defun EXPT (u v) 1413;; "EXPT(U:number, V:integer):number eval, spread 1414;; Returns U raised to the V power. A floating point U to an integer 1415;; power V does not have V changed to a floating number before 1416;; exponentiation." 1417;; (cond ((and (numberp u) (numberp v)) (expt u v)) 1418;; ((math-integerp u) (math-pow u v)) 1419;; ;; u is a float, v is a math-integer, u^v = e^(ln(u)*v): 1420;; ;; THIS VIOLATES THE SPECIFICATION! 1421;; (t (exp (* (log u) (FLOAT v)))))) 1422 1423(defun EXPT (u v) 1424 "EXPT(U:number, V:integer):number eval, spread 1425Returns U raised to the V power. A floating point U to an integer 1426power V does not have V changed to a floating number before 1427exponentiation." 1428 (cond ((math-integerp u) (math-pow u v)) 1429 ((and (floatp u) (numberp v)) (expt u v)) 1430 ;; u is a float, v is a math-integer, u^v = e^(ln(u)*v): 1431 ;; THIS VIOLATES THE SPECIFICATION! 1432 (t (exp (* (log u) (FLOAT v)))))) 1433 1434;; The IEEE binary64 format (https://en.wikipedia.org/wiki/IEEE_754) 1435;; uses a 53-bit significand (s) and 11-bit exponent (e). If the 1436;; (binary) exponent is 53 or more then the float has zero fractional 1437;; part, so truncating it cannot lose digits. An Elisp integer uses 1438;; 61 bits (range 2**61 - 1 to -2**61), so a float with exponent up to 1439;; 60 should truncate reliably to an Elisp integer. Choose a maximum 1440;; exponent value (emax) between 53 and 60 and only truncate a float 1441;; with exponent <= emax to reliably obtain an accurate Elisp integer. 1442 1443(defun FIX (u) 1444 "FIX(U:number):integer eval, spread 1445Returns an integer which corresponds to the truncated value of U. 1446The result of conversion must retain all significant portions of U. If 1447U is an integer it is returned unchanged." 1448 (if (math-integerp u) 1449 u 1450 ;; u is a float: 1451 (let* ((emax 58) 1452 (s.e (frexp u)) ; s float: 0.5 <= s < 1.0 1453 (e (cdr s.e))) ; e integer: u = s*2^e 1454 (if (<= e emax) 1455 (truncate u) 1456 (math-mul (truncate (ldexp (car s.e) emax)) ; (s*2^emax) * 1457 (math-pow 2 (- e emax))) ; (2^(e-emax)) 1458 )))) 1459 1460(defun FLOAT (u) 1461 "FLOAT(U:number):floating eval, spread 1462The floating point number corresponding to the value of the 1463argument U is returned. Some of the least significant digits of 1464an integer may be lost do to the implementation of floating point 1465numbers. FLOAT of a floating point number returns the number 1466unchanged. If U is too large to represent in floating point an 1467error occurs: 1468***** Argument to FLOAT is too large" 1469 ;; Convert ANY number U to a native ELisp float. 1470 (if (numberp u) 1471 (float u) 1472 ;; math-float returns `MANT * 10^EXP' as `(float MANT EXP)' 1473 (let ((me (cdr (math-float u)))) 1474 (* (car me) (expt 10.0 (cadr me)))))) 1475 1476(defun GREATERP (u v) 1477 "GREATERP(U:number, V:number):boolean eval, spread 1478Returns T if U is strictly greater than V, otherwise returns NIL." 1479 (esl--arith-op2 #'< #'math-lessp v u)) 1480 1481(defun LESSP (u v) 1482 "LESSP(U:number, V:number):boolean eval, spread 1483Returns T if U is strictly less than V, otherwise returns NIL." 1484 (esl--arith-op2 #'< #'math-lessp u v)) 1485 1486(defmacro MAX (&rest u) 1487 "MAX([U:number]):number noeval, nospread, or macro 1488Returns the largest of the values in U. If two or more values are the 1489same the first is returned. 1490MACRO PROCEDURE MAX(U); 1491 EXPAND(CDR U, 'MAX2);" 1492 (EXPAND u 'MAX2)) 1493 1494(defun MAX2 (u v) 1495 "MAX2(U:number, V:number):number eval, spread 1496Returns the larger of U and V. If U and V are the same value U is 1497returned (U and V might be of different types). 1498EXPR PROCEDURE MAX2(U, V); 1499 IF LESSP(U, V) THEN V ELSE U;" 1500 (if (LESSP u v) v u)) 1501 1502(defmacro MIN (&rest u) 1503 "MIN([U:number]):number noeval, nospread, or macro 1504Returns the smallest of the values in U. If two or more values are the 1505same the first of these is returned. 1506MACRO PROCEDURE MIN(U); 1507 EXPAND(CDR U, 'MIN2);" 1508 (EXPAND u 'MIN2)) 1509 1510(defun MIN2 (u v) 1511 "MIN2(U:number, V:number):number eval, spread 1512Returns the smaller of its arguments. If U and V are the same value, 1513U is returned (U and V might be of different types). 1514EXPR PROCEDURE MIN2(U, V); 1515 IF GREATERP(U, V) THEN V ELSE U;" 1516 (if (GREATERP u v) v u)) 1517 1518(defun MINUS (u) 1519 "MINUS(U:number):number eval, spread 1520Returns -U. 1521EXPR PROCEDURE MINUS(U); 1522 DIFFERENCE(0, U);" 1523 (if (numberp u) 1524 (- u) 1525 ;; u is a math-integer or invalid: 1526 (math-neg u))) 1527 1528(defmacro PLUS (&rest u) 1529 "PLUS([U:number]):number noeval, nospread, or macro 1530Forms the sum of all its arguments. 1531MACRO PROCEDURE PLUS(U); 1532 EXPAND(CDR U, 'PLUS2);" 1533 (declare (debug t)) 1534 (EXPAND u #'PLUS2)) 1535 1536(defun PLUS2 (u v) 1537 "PLUS2(U:number, V:number):number eval, spread 1538Returns the sum of U and V." 1539 (esl--arith-op2 #'+ #'math-add u v)) 1540 1541(defun esl-xor (u v) 1542 "(exclusive-or U V)" 1543 (cond (u (not v)) (v (not u)))) 1544 1545(defun esl--math-integer-quotient (u v) 1546 "Correct quotient of math-integers U and V." 1547 (let ((w (math-quotient (math-abs u) (math-abs v)))) 1548 (if (esl-xor (math-negp u) (math-negp v)) 1549 (math-neg w) 1550 w))) 1551 1552(defun QUOTIENT (u v) 1553 "QUOTIENT(U:number, V:number):number eval, spread 1554The quotient of U divided by V is returned. Division of two positive 1555or two negative integers is conventional. When both U and V are 1556integers and exactly one of them is negative the value returned is 1557the negative truncation of the absolute value of U divided by the 1558absolute value of V. An error occurs if division by zero is attempted: 1559***** Attempt to divide by 0 in QUOTIENT" 1560 (esl--arith-op2 #'/ #'esl--math-integer-quotient u v)) 1561 1562(defun REMAINDER (u v) 1563 "REMAINDER(U:number, V:number):number eval, spread 1564If both U and V are integers the result is the integer remainder of 1565U divided by V. If either parameter is floating point, the result is 1566the difference between U and V*(U/V) all in floating point. If either 1567number is negative the remainder is negative. If both are positive or 1568both are negative the remainder is positive. An error occurs if V is 1569zero: 1570***** Attempt to divide by 0 in REMAINDER 1571EXPR PROCEDURE REMAINDER(U, V); 1572 DIFFERENCE(U, TIMES2(QUOTIENT(U, V), V));" 1573 (DIFFERENCE u (TIMES2 (QUOTIENT u v) v))) 1574 1575(defun SUB1 (u) 1576 "SUB1(U:number):number eval, spread 1577Returns the value of U less 1. If U is a FLOAT type number, the 1578value returned is U less 1.0. 1579EXPR PROCEDURE SUB1(U); 1580 DIFFERENCE(U, 1);" 1581 (DIFFERENCE u 1)) 1582 1583(defmacro TIMES (&rest u) 1584 "TIMES([U:number]):number noeval, nospread, or macro 1585Returns the product of all its arguments. 1586MACRO PROCEDURE TIMES(U); 1587 EXPAND(CDR U, 'TIMES2);" 1588 (declare (debug t)) 1589 (EXPAND u #'TIMES2)) 1590 1591(defun TIMES2 (u v) 1592 "TIMES2(U:number, V:number):number eval, spread 1593Returns the product of U and V." 1594 (esl--arith-op2 #'* #'math-mul u v)) 1595 1596;; Fast built-in small integer (inum) arithmetic: 1597 1598(defalias 'IPLUS '+) 1599(defalias 'ITIMES '*) 1600(defalias 'IPLUS2 '+) 1601(defalias 'ITIMES2 '*) 1602(defalias 'IADD1 '1+) 1603(defalias 'ISUB1 '1-) 1604(defalias 'IMINUS '-) 1605(defalias 'IMINUSP 'cl-minusp) 1606(defalias 'IDIFFERENCE '-) 1607(defalias 'IQUOTIENT '/) 1608(defalias 'IREMAINDER '%) 1609(defalias 'ILESSP '<) 1610(defalias 'IGREATERP '>) 1611(defalias 'ILEQ '<=) 1612(defalias 'IGEQ '>=) 1613 1614(defmacro IZEROP (number) 1615 "Return t if NUMBER is zero." 1616 `(= ,number 0)) 1617 1618(defmacro IONEP (number) 1619 "Return t if NUMBER is one." 1620 `(= ,number 1)) 1621 1622;; Fast built-in floating point functions: 1623 1624;; (defalias 'ACOS 'acos) 1625;; (defalias 'ASIN 'asin) 1626;; (defalias 'ATAN 'atan) 1627;; (defalias 'ATAN2 'atan) 1628;; (defalias 'COS 'cos) 1629;; (defalias 'EXP 'exp) 1630;; (defalias 'LN 'log) 1631;; (defalias 'LOG 'log) 1632;; (defalias 'LOGB 'log) 1633;; (defsubst LOG10 (x) (log x 10)) 1634;; (defalias 'SIN 'sin) 1635;; (defalias 'SQRT 'sqrt) 1636;; (defalias 'TAN 'tan) 1637;; ;; The following will fail for floats with very large magnitudes since 1638;; ;; they return fixnums rather than big integers. If that is a problem 1639;; ;; then remove these aliases and in particular remove the lose flags 1640;; ;; in "eslrend.red". 1641;; (defalias 'CEILING 'ceiling) 1642;; (defalias 'FLOOR 'floor) 1643;; (defalias 'ROUND 'round) 1644 1645;; The above cause errors in the arith test file when trig results or 1646;; arguments are complex so all commented out for now. 1647 1648 1649;;; MAP Composite Functions 1650;;; ======================= 1651 1652;; I use funcall below to avoid compiler warnings. 1653 1654(defun MAP (x fn) 1655 "MAP(X:list, FN:function):any eval, spread 1656Applies FN to successive CDR segments of X. NIL is returned. 1657EXPR PROCEDURE MAP(X, FN); 1658 WHILE X DO << FN X; X := CDR X >>;" 1659 (while x 1660 (funcall fn x) 1661 (setq x (cdr x)))) 1662 1663(defun MAPC (x fn) 1664 "MAPC(X:list, FN:function):any eval, spread 1665FN is applied to successive CAR segments of list X. NIL is returned. 1666EXPR PROCEDURE MAPC(X, FN); 1667 WHILE X DO << FN CAR X; X := CDR X >>;" 1668 (mapc fn x) 1669 nil) 1670 1671(defun MAPCAN (x fn) 1672 "MAPCAN(X:list, FN:function):any eval, spread 1673A concatenated list of FN applied to successive CAR elements of X 1674is returned. 1675EXPR PROCEDURE MAPCAN(X, FN); 1676 IF NULL X THEN NIL 1677 ELSE NCONC(FN CAR X, MAPCAN(CDR X, FN));" 1678 (mapcan fn x)) 1679 1680(defun MAPCAR (x fn) 1681 "MAPCAR(X:list, FN:function):any eval, spread 1682Returned is a constructed list of FN applied to each CAR of list X. 1683EXPR PROCEDURE MAPCAR(X, FN); 1684 IF NULL X THEN NIL 1685 ELSE FN CAR X . MAPCAR(CDR X, FN);" 1686 (mapcar fn x)) 1687 1688(defun MAPCON (x fn) 1689 "MAPCON(X:list, FN:function):any eval, spread 1690Returned is a concatenated list of FN applied to successive CDR 1691segments of X. 1692EXPR PROCEDURE MAPCON(X, FN); 1693 IF NULL X THEN NIL 1694 ELSE NCONC(FN X, MAPCON(CDR X, FN));" 1695 (if x (nconc (funcall fn x) (MAPCON (cdr x) fn)))) 1696 1697(defun MAPLIST (x fn) 1698 "MAPLIST(X:list, FN:function):any eval, spread 1699Returns a constructed list of FN applied to successive CDR segments 1700of X. 1701EXPR PROCEDURE MAPLIST(X, FN); 1702 IF NULL X THEN NIL 1703 ELSE FN X . MAPLIST(CDR X, FN);" 1704 (if x (cons (funcall fn x) (MAPLIST (cdr x) fn)))) 1705 1706 1707;;; Composite Functions 1708;;; =================== 1709 1710(defun APPEND (u v) 1711 "(append U:list V:list): list expr 1712Returns a constructed list in which the last element of U is followed by the 1713first element of V. The list U is copied, but V is not." 1714 ;; Some REDUCE code assumes the PSL definition, which allows U to 1715 ;; have any type: 1716 (if (consp u) (append u v) v)) 1717 1718(defalias 'ASSOC 'assoc 1719 "ASSOC(U:any, V:alist):{dotted-pair, NIL} eval, spread 1720If U occurs as the CAR portion of an element of the alist V, the 1721dotted-pair in which U occurred is returned, else NIL is 1722returned. ASSOC might not detect a poorly formed alist so an 1723invalid construction may be detected by CAR or CDR. 1724EXPR PROCEDURE ASSOC(U, V); 1725 IF NULL V THEN NIL 1726 ELSE IF ATOM CAR V THEN 1727 ERROR(000, LIST(V, \"is a poorly formed alist\")) 1728 ELSE IF U = CAAR V THEN CAR V 1729 ELSE ASSOC(U, CDR V);") 1730 1731(defun DEFLIST (u ind) 1732 "DEFLIST(U:dlist, IND:id):list eval, spread 1733A \"dlist\" is a list in which each element is a two element list: (ID:id 1734PROP:any). Each ID in U has the indicator IND with property 1735PROP placed on its property list by the PUT function. The value 1736of DEFLIST is a list of the first elements of each two element list. 1737Like PUT, DEFLIST may not be used to define functions. 1738EXPR PROCEDURE DEFLIST(U, IND); 1739 IF NULL U THEN NIL 1740 ELSE << PUT(CAAR U, IND, CADAR U); 1741 CAAR U >> . DEFLIST(CDR U, IND);" 1742 (when u 1743 (if *DEFN (esl--save-plist (caar u))) 1744 (put (caar u) ind (CADAR u)) 1745 (cons (caar u) (DEFLIST (cdr u) ind)))) 1746 1747(defun DELETE (u v) 1748 ;; Must be non-destructive, so cannot use Elisp delete function! 1749 ;; Doing so causes obscure problems, e.g. in the Bareiss code for 1750 ;; computing determinants and in for all ... let. 1751 "DELETE(U:any, V:list ):list eval, spread 1752Returns V with the first top level occurrence of U removed from it. 1753EXPR PROCEDURE DELETE(U, V); 1754 IF NULL V THEN NIL 1755 ELSE IF CAR V = U THEN CDR V 1756 ELSE CAR V . DELETE(U, CDR V);" 1757 (cond ((null v) nil) 1758 ((equal (car v) u) (cdr v)) 1759 (t (cons (car v) (DELETE u (cdr v)))))) 1760 1761(defun DIGIT (u) 1762 "DIGIT(U:any):boolean eval, spread 1763Returns T if U is a digit, otherwise NIL. 1764EXPR PROCEDURE DIGIT(U); 1765 IF MEMQ(U, '(!0 !1 !2 !3 !4 !5 !6 !7 !8 !9)) 1766 THEN T ELSE NIL;" 1767 (if (memq u '(\0 \1 \2 \3 \4 \5 \6 \7 \8 \9)) t)) 1768 1769(defun LENGTH (x) 1770 "LENGTH(X:any):integer eval, spread 1771The top level length of the list X is returned. 1772EXPR PROCEDURE LENGTH(X); 1773 IF ATOM X THEN 0 1774 ELSE PLUS(1, LENGTH CDR X);" 1775 ;; The Elisp length function cannot be used because it does not 1776 ;; accept atoms or dotted pairs! 1777 (if (ATOM x) 1778 0 1779 (1+ (LENGTH (cdr x))))) 1780 1781(defun LITER (u) 1782 "LITER(U:any):boolean eval, spread 1783Returns T if U is a character of the alphabet, NIL otherwise. 1784EXPR PROCEDURE LITER(U); 1785 IF MEMQ(U, '(!A !B !C !D !E !F !G !H !I !J !K !L !M 1786 !N !O !P !Q !R !S !T !U !V !W !X !Y !Z 1787 !a !b !c !d !e !f !g !h !i !j !k !l !m 1788 !n !o !p !q !r !s !t !u !v !w !x !y !z)) 1789 THEN T ELSE NIL;" 1790 ;; This is Emacs Lisp, so no ! escapes: 1791 (if (memq u '(A B C D E F G H I J K L M 1792 N O P Q R S T U V W X Y Z 1793 a b c d e f g h i j k l m 1794 n o p q r s t u v w x y z)) 1795 t)) 1796 1797(defalias 'MEMBER 'member 1798 "MEMBER(A:any, B:list):extra-boolean eval, spread 1799Returns NIL if A is not a member of list B, returns the remainder of 1800B whose first element is A. 1801EXPR PROCEDURE MEMBER(A, B); 1802 IF NULL B THEN NIL 1803 ELSE IF A = CAR B THEN B 1804 ELSE MEMBER(A, CDR B);") 1805 1806(defalias 'MEMQ 'memq 1807 "MEMQ(A:any, B:list):extra-boolean eval, spread 1808Same as MEMBER but an EQ check is used for comparison. 1809EXPR PROCEDURE MEMQ(A, B); 1810 IF NULL B THEN NIL 1811 ELSE IF A EQ CAR B THEN B 1812 ELSE MEMQ(A, CDR B);") 1813 1814(defalias 'NCONC 'nconc 1815 "NCONC(U:list, V:list):list eval, spread 1816Concatenates V to U without copying U. The last CDR of U is 1817modified to point to V. 1818EXPR PROCEDURE NCONC(U, V); 1819BEGIN SCALAR W; 1820 IF NULL U THEN RETURN V; 1821 W := U; 1822 WHILE CDR W DO W := CDR W; 1823 RPLACD(W, V); 1824 RETURN U 1825END;") 1826 1827(defun PAIR (u v) 1828 "PAIR(U:list, V:list):alist eval, spread 1829U and V are lists which must have an identical number of elements. 1830If not, an error occurs (the 000 used in the ERROR call is arbitrary 1831and need not be adhered to). Returned is a list where each element 1832is a dotted-pair, the CAR of the pair being from U, and the CDR 1833the corresponding element from V. 1834EXPR PROCEDURE PAIR(U, V); 1835 IF AND(U, V) THEN (CAR U . CAR V) . PAIR(CDR U, CDR V) 1836 ELSE IF OR(U, V) THEN ERROR(000, 1837 \"Different length lists in PAIR\") 1838 ELSE NIL;" 1839 (cond ((and u v) (cons (cons (car u) (car v)) (PAIR (cdr u) (cdr v)))) 1840 ((or u v) (error "%s" "000 Different length lists in PAIR")))) 1841 1842(defalias 'REVERSE 'reverse 1843 "REVERSE(U:list):list eval, spread 1844Returns a copy of the top level of U in reverse order. 1845EXPR PROCEDURE REVERSE(U); 1846BEGIN SCALAR W; 1847 WHILE U DO << W := CAR U . W; 1848 U := CDR U >>; 1849 RETURN W 1850END;") 1851 1852(defalias 'REVERSIP 'nreverse) ; PSL function 1853 1854(defun SASSOC (u v fn) 1855 "SASSOC(U:any, V:alist, FN:function):any eval, spread 1856Searches the alist V for an occurrence of U. If U is not in the alist 1857the evaluation of function FN is returned. 1858EXPR PROCEDURE SASSOC(U, V, FN); 1859 IF NULL V THEN FN() 1860 ELSE IF U = CAAR V THEN CAR V 1861 ELSE SASSOC(U, CDR V, FN);" 1862 (cond ((null v) (funcall fn)) 1863 ((equal u (caar v)) (car v)) 1864 (t (SASSOC u (cdr v) fn)))) 1865 1866(defun SUBLIS (x y) 1867 "SUBLIS(X:alist, Y:any):any eval, spread 1868The value returned is the result of substituting the CDR of each 1869element of the alist X for every occurrence of the CAR part of that 1870element in Y. 1871EXPR PROCEDURE SUBLIS(X, Y); 1872 IF NULL X THEN Y 1873 ELSE BEGIN SCALAR U; 1874 U := ASSOC(Y, X); 1875 RETURN IF U THEN CDR U 1876 ELSE IF ATOM Y THEN Y 1877 ELSE SUBLIS(X, CAR Y) . 1878 SUBLIS(X, CDR Y) 1879 END;" 1880 (if (null x) 1881 y 1882 (let ((u (assoc y x))) 1883 (cond (u (cdr u)) 1884 ((ATOM y) y) 1885 (t (cons (SUBLIS x (car y)) (SUBLIS x (cdr y)))))))) 1886 1887(defun SUBST (u v w) 1888 "SUBST(U:any, V:any, W:any):any eval, spread 1889The value returned is the result of substituting U for all occurrences 1890of V in W. 1891EXPR PROCEDURE SUBST(U, V, W); 1892 IF NULL W THEN NIL 1893 ELSE IF V = W THEN U 1894 ELSE IF ATOM W THEN W 1895 ELSE SUBST(U, V, CAR W) . SUBST(U, V, CDR W);" 1896 (cond ((null w) nil) 1897 ((equal v w) u) 1898 ((ATOM w) w) 1899 (t (cons (SUBST u v (car w)) (SUBST u v (cdr w)))))) 1900 1901 1902;;; The Interpreter 1903;;; =============== 1904 1905(defalias 'APPLY 'apply 1906 "APPLY(FN:{id,function}, ARGS:any-list):any eval, spread 1907APPLY returns the value of FN with actual parameters ARGS. The 1908actual parameters in ARGS are already in the form required for 1909binding to the formal parameters of FN. Implementation specific 1910portions described in English are enclosed in boxes. 1911EXPR PROCEDURE APPLY(FN, ARGS); 1912BEGIN SCALAR DEFN; 1913 IF CODEP FN THEN RETURN 1914 | Spread the actual parameters in ARGS 1915 | following the conventions: for calling 1916 | functions, transfer to the entry point 1917 | of the function, and return the value 1918 | returned by the function.; 1919 IF IDP FN THEN RETURN 1920 IF NULL(DEFN := GETD FN) THEN 1921 ERROR(000, LIST(FN, \"is an undefined function\")) 1922 ELSE IF CAR DEFN EQ 'EXPR THEN 1923 APPLY(CDR DEFN, ARGS) 1924 ELSE ERROR(000, 1925 LIST(FN, \"cannot be evaluated by APPLY\")); 1926 IF OR(ATOM FN, NOT(CAR FN EQ 'LAMBDA)) THEN 1927 ERROR(000, 1928 LIST(FN, \"cannot be evaluated by APPLY\")); 1929 RETURN 1930 | Bind the actual parameters in ARGS to 1931 | the formal parameters of the lambda 1932 | expression. If the two lists are not 1933 | of equal length then ERROR(000, \"Number 1934 | of parameters do not match\"); The value 1935 | returned is EVAL CADDR FN. 1936END;") 1937 1938(defalias 'EVAL 'eval 1939 "EVAL(U:any):any eval, spread 1940The value of the expression U is computed. Error numbers are 1941arbitrary. Portions of EVAL involving machine specific coding are 1942expressed in English enclosed in boxes. 1943EXPR PROCEDURE EVAL(U); 1944BEGIN SCALAR FN; 1945 IF CONSTANTP U THEN RETURN U; 1946 IF IDP U THEN RETURN 1947 | U is an id. Return the value most 1948 | currently bound to U or if there 1949 | is no such binding: ERROR(000, 1950 | LIST(\"Unbound:\", U)); 1951 IF PAIRP CAR U THEN RETURN 1952 IF CAAR U EQ 'LAMBDA THEN APPLY(CAR U, EVLIS CDR U) 1953 ELSE ERROR(000, LIST(CAR U, 1954 \"improperly formed LAMBDA expression\")) 1955 ELSE IF CODEP CAR U THEN 1956 RETURN APPLY(CAR U, EVLIS CDR U); 1957 FN := GETD CAR U; 1958 IF NULL FN THEN 1959 ERROR(000, LIST(CAR U, \"is an undefined function\")) 1960 ELSE IF CAR FN EQ 'EXPR THEN 1961 RETURN APPLY(CDR FN, EVLIS CDR U) 1962 ELSE IF CAR FN EQ 'FEXPR THEN 1963 RETURN APPLY(CDR FN, LIST CDR U) 1964 ELSE IF CAR FN EQ 'MACRO THEN 1965 RETURN EVAL APPLY(CDR FN, LIST U) 1966END;") 1967 1968(defun EVLIS (u) 1969 "EVLIS(U:any-list):any-list eval, spread 1970EVLIS returns a list of the evaluation of each element of U. 1971EXPR PROCEDURE EVLIS(U); 1972 IF NULL U THEN NIL 1973 ELSE EVAL CAR U . EVLIS CDR U;" 1974 (if u (cons (eval (car u)) (EVLIS (cdr u))))) 1975 1976(defun EXPAND (l fn) 1977 "EXPAND(L:list, FN:function):list eval, spread 1978FN is a defined function of two arguments to be used in the expansion 1979of a MACRO. EXPAND returns a list in the form: 1980 (FN L0 (FN L1 ... (FN Ln-1 Ln) ... )) 1981where n is the number of elements in L, Li is the ith element of L. 1982EXPR PROCEDURE EXPAND(L,FN); 1983 IF NULL CDR L THEN CAR L 1984 ELSE LIST(FN, CAR L, EXPAND(CDR L, FN));" 1985 (if (null (cdr l)) 1986 (car l) 1987 (list fn (car l) (EXPAND (cdr l) fn)))) 1988 1989(defmacro FUNCTION (fn) ; rlisp.red does not compile if alias 1990 "FUNCTION(FN:function):function noeval, nospread 1991The function FN is to be passed to another function. If FN is to have 1992side effects its free variables must be fluid or global. FUNCTION is 1993like QUOTE but its argument may be affected by compilation. We 1994do not consider FUNARGs in this report." 1995 (declare (debug function)) 1996 `(function ,fn)) 1997 1998(defmacro QUOTE (u) ; does not work as alias 1999 "QUOTE(U:any):any noeval, nospread 2000Stops evaluation and returns U unevaluated. 2001FEXPR PROCEDURE QUOTE(U); 2002 CAR U;" 2003 (declare (debug quote)) 2004 `',u) 2005 2006 2007;;; Input and Output 2008;;; ================ 2009 2010;; An ESL filehandle has the form (stream . mode) where mode is 'INPUT 2011;; or 'OUTPUT and stream is as defined below: 2012 2013(defvar esl--read-stream nil 2014 "The current input stream. 2015The stream nil represents the terminal, an interactive window. 2016A buffer stream represents the input file opened in it.") 2017 2018(defvar esl--write-stream nil 2019 "The current output stream. 2020The stream nil represents the terminal, an interactive window. 2021A buffer stream represents the output file to which it will be 2022saved when it is closed.") 2023 2024(defconst esl--read-prefix " ESL-IN " 2025 "Prefixed to file names to make input buffer names.") 2026 2027(defconst esl--write-prefix " ESL-OUT " 2028 "Prefixed to file names to make output buffer names.") 2029 2030(defconst esl--write-prefix-length (length esl--write-prefix) 2031 "Length of `esl--write-prefix' string.") 2032 2033(defconst esl--default-output-buffer-name "*Standard LISP*" 2034 "The name of the terminal window buffer.") 2035 2036(defvar esl--default-output-buffer nil 2037 "The terminal window buffer, set when the buffer is created." ) 2038 2039(defun CLOSE (filehandle) 2040 "CLOSE(FILEHANDLE:any):any eval, spread 2041Closes the file with the internal name FILEHANDLE writing any 2042necessary end of file marks and such. The value of FILEHANDLE 2043is that returned by the corresponding OPEN. The value returned is 2044the value of FILEHANDLE. An error occurs if the file can not be 2045closed. 2046***** FILEHANDLE could not be closed" 2047 ;; A null filehandle represents the terminal; ignore it. 2048 (if filehandle 2049 (let (buf) 2050 (if (and (consp filehandle) 2051 (bufferp (setq buf (car filehandle))) 2052 ;; It might be better to ignore a non-existent file 2053 ;; buffer, assuming it has already been closed. 2054 (cond ((eq (cdr filehandle) 'INPUT) 2055 t) 2056 ((eq (cdr filehandle) 'OUTPUT) 2057 (with-current-buffer buf 2058 ;; Filename follows esl--write-prefix in 2059 ;; buffer name, so... 2060 (write-file 2061 (substring (buffer-name) 2062 esl--write-prefix-length) 2063 ;; Require confirmation to overwrite an 2064 ;; existing file unless in batch mode: 2065 (not noninteractive))) 2066 t))) 2067 (kill-buffer buf) 2068 (error "%s could not be closed" filehandle)))) 2069 filehandle) 2070 2071(defun EJECT () 2072 "EJECT():NIL eval, spread 2073Skip to the top of the next output page. Automatic EJECTs are 2074executed by the print functions when the length set by the PAGE- 2075LENGTH function is exceeded." 2076 nil) 2077 2078(defvar esl--linelength 80 2079 "Current Standard LISP line length accessed via function `LINELENGTH'.") 2080 2081(defun LINELENGTH (len) 2082 "LINELENGTH(LEN:{integer, NIL}):integer eval, spread 2083If LEN is an integer the maximum line length to be printed before 2084the print functions initiate an automatic TERPRI is set to the value 2085LEN. No initial Standard LISP line length is assumed. The previous 2086line length is returned except when LEN is NIL. This special case 2087returns the current line length and does not cause it to be reset. An 2088error occurs if the requested line length is too large for the currently 2089selected output file or LEN is negative or zero. 2090***** LEN is an invalid line length" 2091 (if len 2092 (if (or (not (integerp len)) (<= len 0)) 2093 (error "%s is an invalid line length" len) 2094 (prog1 esl--linelength (setq esl--linelength len))) 2095 esl--linelength)) 2096 2097(defun LPOSN () 2098 "LPOSN():integer eval, spread 2099Returns the number of lines printed on the current page. At the top 2100of a page, 0 is returned." 2101 0) 2102 2103(defun OPEN (file how) 2104 "OPEN(FILE:any, HOW:id):any eval, spread 2105Open the file with the system dependent name FILE for output if 2106HOW is EQ to OUTPUT, or input if HOW is EQ to INPUT. If the 2107file is opened successfully, a value which is internally associated with 2108the file is returned. This value must be saved for use by RDS and 2109WRS. An error occurs if HOW is something other than INPUT or 2110OUTPUT or the file can't be opened. 2111***** HOW is not option for OPEN 2112***** FILE could not be opened" 2113 (cond ((eq how 'INPUT) 2114 ;; Read file into a buffer and return (buffer . 'INPUT). 2115 (save-current-buffer 2116 ;; Leading space means buffer hidden and no undo: 2117 (set-buffer (get-buffer-create (concat esl--read-prefix file))) 2118 ;; Allow re-opening a file and continuing to read it: 2119 (if (zerop (buffer-size)) 2120 (insert-file-contents file)) 2121 (cons (current-buffer) 'INPUT))) 2122 ((eq how 'OUTPUT) 2123 ;; Create a new file buffer and return (buffer . 'OUTPUT). 2124 (cons (get-buffer-create (concat esl--write-prefix file)) 'OUTPUT)) 2125 (t (error "%s is not option for OPEN" how)))) 2126 2127(defun PAGELENGTH (_len) ; unused argument 2128 "PAGELENGTH(LEN:{integer, NIL}):integer eval, spread 2129Sets the vertical length (in lines) of an output page. Automatic page 2130EJECTs are executed by the print functions when this length is 2131reached. The initial vertical length is implementation specific. The 2132previous page length is returned. If LEN is 0, no automatic page 2133ejects will occur." 2134 nil) 2135 2136(defvar esl--posn 0 2137 "Number of characters in the current line output by Standard LISP. 2138Accessed (read-only) via the function `POSN'. 2139It's value should be between 0 and `esl--linelength' inclusive.") 2140 2141(defun POSN () 2142 "POSN():integer eval, spread 2143Returns the number of characters in the output buffer. When the 2144buffer is empty, 0 is returned." 2145 esl--posn) 2146 2147(defvar *LOWER t 2148 "If *LOWER is non-nil then all identifiers are output using 2149lower case.") 2150 2151(defun esl--prin-string (s) 2152 "Print string S preceded by a newline if necessary. 2153Check and update `esl--posn' to keep it <= `esl--linelength'." 2154 (let ((len (length s))) 2155 (setq esl--posn (+ esl--posn len)) 2156 (when (> esl--posn esl--linelength) 2157 (setq esl--posn len) 2158 (terpri)) 2159 (princ s))) 2160 2161(defsubst esl--downcase-string-maybe (s) 2162 "Down-case string S if *LOWER is non-nil." 2163 (if *LOWER (downcase s) s)) 2164 2165(defun PRINC (u) 2166 "PRINC(U:id):id eval, spread 2167U must be a single character id such as produced by EXPLODE or 2168read by READCH or the value of !$EOL!$. The effect is the character 2169U displayed upon the currently selected output device. The value of 2170!$EOL!$ causes termination of the current line like a call to TERPRI." 2171 ;; NB: This version does not handle !$EOL!$ correctly. 2172 (esl--prin-string (esl--downcase-string-maybe (symbol-name u)))) 2173 2174(defun PRINT (u) 2175 "PRINT(U:any):any eval, spread 2176Displays U in READ readable format and terminates the print line. 2177The value of U is returned. 2178EXPR PROCEDURE PRINT(U); 2179<< PRIN1 U; TERPRI(); U >>;" 2180 (PRIN1 u) 2181 (terpri) 2182 u) 2183 2184(defun esl--prin1-id-to-string (u) 2185 "Convert identifier U to a string including appropriate `!' characters. 2186Down-case if *LOWER is non-nil." 2187 (setq u (esl--downcase-string-maybe (symbol-name u))) 2188 (if (string-prefix-p "!:" u) 2189 (concat "!:" (esl--prin1-id-to-string--internal (substring u 2))) 2190 (esl--prin1-id-to-string--internal u))) 2191 2192(defun esl--prin1-id-to-string--internal (u) 2193 "Include appropriate `!' characters in string U. 2194U does not begin with `!:'." 2195 (let (not-first) 2196 (mapconcat 2197 (lambda (c) 2198 (prog1 2199 (if (or (and not-first (>= c ?0) (<= c ?9)) 2200 (and (>= c ?A) (<= c ?Z)) 2201 (and (>= c ?a) (<= c ?z)) 2202 (eq c ?_)) 2203 (string c) 2204 (string ?! c)) 2205 (setq not-first t))) 2206 u ""))) 2207 2208(defun PRIN1 (u) 2209 "PRIN1(U:any):any eval, spread 2210U is displayed in a READ readable form. The format of display is 2211the result of EXPLODE expansion; special characters are prefixed 2212with the escape character !, and strings are enclosed in \"...\". Lists 2213are displayed in list-notation and vectors in vector-notation." 2214 ;; NB: This version will not print a vector containing big integers 2215 ;; correctly, but the output should be readable! 2216 (cond ((symbolp u) (esl--prin-string (esl--prin1-id-to-string u))) 2217 ((not (consp u)) (esl--prin-string (prin1-to-string u))) 2218 ((esl-bigint-p u) (esl--prin-string (esl-bigint-to-string u))) 2219 (t (esl--prin-string "(") 2220 (PRIN1 (car u)) 2221 (esl--prin1-cdr (cdr u)) 2222 (esl--prin-string ")"))) 2223 u) 2224 2225(defsubst esl--prin-space-maybe () 2226 "Print a space unless at the end of a line." 2227 (if (< esl--posn (1- esl--linelength)) 2228 (esl--prin-string " ") 2229 (TERPRI))) 2230 2231(defun esl--prin1-cdr (u) 2232 "If U is non-nil then print it or its elements spaced appropriately. 2233U is the cdr of a cons cell: nil, an atom or a cons cell." 2234 (cond ((null u)) ; do nothing 2235 ((atom u) 2236 (esl--prin-space-maybe) (esl--prin-string ".") 2237 (esl--prin-space-maybe) (PRIN1 u)) 2238 (t (esl--prin-space-maybe) 2239 (PRIN1 (car u)) 2240 (esl--prin1-cdr (cdr u))))) 2241 2242(defun esl--prin2-id-to-string (u) 2243 "Convert identifier U to a string excluding inappropriate `!' characters. 2244Down-case if *LOWER is non-nil." 2245 (setq u (esl--downcase-string-maybe (symbol-name u))) 2246 (if (string-prefix-p "!:" u) (substring u 1) u)) 2247 2248(defun PRIN2 (u) 2249 "PRIN2(U:any):any eval, spread 2250U is displayed upon the currently selected print device but output is 2251not READ readable. The value of U is returned. Items are displayed 2252as described in the EXPLODE function with the exceptions that 2253the escape character does not prefix special characters and strings 2254are not enclosed in \"...\". Lists are displayed in list-notation and 2255vectors in vector-notation. The value of U is returned." 2256 ;; NB: This version will not print a vector containing big integers 2257 ;; correctly, but the output should be readable! 2258 (cond ((symbolp u) (esl--prin-string (esl--prin2-id-to-string u))) 2259 ((not (consp u)) (esl--prin-string (prin1-to-string u t))) 2260 ((esl-bigint-p u) (esl--prin-string (esl-bigint-to-string u))) 2261 (t (esl--prin-string "(") 2262 (PRIN2 (car u)) 2263 (esl--prin2-cdr (cdr u)) 2264 (esl--prin-string ")"))) 2265 u) 2266 2267(defun esl--prin2-cdr (u) 2268 "If U is non-nil then print it or its elements spaced appropriately. 2269U is the cdr of a cons cell: nil, an atom or a cons cell." 2270 (cond ((null u)) ; do nothing 2271 ((atom u) 2272 (esl--prin-space-maybe) (esl--prin-string ".") 2273 (esl--prin-space-maybe) (PRIN2 u)) 2274 (t (esl--prin-space-maybe) 2275 (PRIN2 (car u)) 2276 (esl--prin2-cdr (cdr u))))) 2277 2278(defun RDS (filehandle) 2279 "RDS(FILEHANDLE:any):any eval, spread 2280Input from the currently selected input file is suspended and 2281further input comes from the file named. FILEHANDLE is a system 2282dependent internal name which is a value returned by OPEN. If 2283FILEHANDLE is NIL the standard input device is selected. When end 2284of file is reached on a non-standard input device, the standard 2285input device is reselected. When end of file occurs on the 2286standard input device the Standard LISP reader terminates. RDS 2287returns the internal name of the previously selected input file. 2288***** FILEHANDLE could not be selected for input" 2289 (let (stream) 2290 (if filehandle 2291 (unless (and (consp filehandle) 2292 (eq (cdr filehandle) 'INPUT) 2293 (bufferp (setq stream (car filehandle)))) 2294 (error "%s could not be selected for input" filehandle))) 2295 (prog1 2296 (if esl--read-stream (cons esl--read-stream 'INPUT)) 2297 (setq esl--read-stream stream)))) 2298 2299(defun esl--read-and-echo () 2300 "Read one Lisp expression as text from current `filehandle'. 2301Return as Lisp object. Echo the input if `*ECHO' is non-nil." 2302 (let ((value 2303 (let (standard-output 2304 ;; to avoid minibuffer errors resetting this 2305 (standard-input (or esl--read-stream t))) 2306 (read)))) 2307 (when (or (eq standard-input t) *ECHO) ; always echo minibuffer input 2308 (if noninteractive 2309 (progn (prin1 value) (terpri) (terpri)) 2310 (with-current-buffer standard-output 2311 (goto-char (point-max)) ; in case point moved interactively 2312 (prin1 value) (terpri) (terpri)))) 2313 value)) 2314 2315(defun READ () 2316 "READ():any 2317The next expression from the file currently selected for 2318input. Valid input forms are: vector-notation, dot-notation, 2319list-notation, numbers, function-pointers, strings, and 2320identifiers with escape characters. Identifiers are interned on 2321the OBLIST (see the INTERN function in \"Identifiers\"). READ 2322returns the value of !$EOF!$ when the end of the currently 2323selected input file is reached. 2324 2325This ESL implementation is incomplete and provided primarily to 2326support the REDUCE YESP function." 2327 (condition-case nil 2328 (let ((value (esl--read-and-echo))) 2329 (if (symbolp value) 2330 (intern (upcase (symbol-name value))) 2331 value)) 2332 (end-of-file $EOF$))) 2333 2334(defvar esl--marker (make-marker) 2335 "Marker from which the next input should be read.") 2336 2337(defvar esl--readch-use-minibuffer nil 2338 "If non-nil then READCH reads from the minibuffer as terminal. 2339Otherwise, it reads from an interaction buffer as terminal.") 2340 2341(defvar esl--readch-input-string nil 2342 "String used to store minibuffer input so that READCH can read 2343it character-by-character.") 2344 2345(defvar esl--readch-input-string-index nil 2346 "Integer used to store the index of the next character for 2347READCH to return from `esl--readch-input-string'.") 2348 2349(defvar esl--readch-input-string-length nil 2350 "Integer used to store the length of `esl--readch-input-string'.") 2351 2352(defvar esl--readch-history nil 2353 "READCH minibuffer input history.") 2354 2355(defvar esl--readch-prev-char nil 2356 "Previous character returned by READCH.") 2357 2358(defun esl--readch-char-to-interned-id (c) 2359 "Convert ELisp character C to an interned SLisp identifier. 2360Up-case letters if !*RAISE is non-nil unless previous char was `!'." 2361 (intern 2362 (string 2363 (cond ((eq esl--readch-prev-char '!) c) 2364 ((and *RAISE (>= c ?a) (<= c ?z)) (- c 32)) 2365 (t c))))) 2366 2367(defun READCH () 2368 "READCH():id 2369Returns the next interned character from the file currently selected 2370for input. Two special cases occur. If all the characters in an input 2371record have been read, the value of !$EOL!$ is returned. If the file 2372selected for input has all been read the value of !$EOF!$ is returned. 2373Comments delimited by % and end-of-line are not transparent to READCH. 2374 2375In ESL, echo minibuffer input to `standard-output' and if *ECHO 2376is non-nil then echo file input." 2377 (setq 2378 esl--readch-prev-char 2379 (if esl--read-stream 2380 ;; Read from a file: 2381 (let ((result 2382 (with-current-buffer esl--read-stream 2383 (cond ((eobp) $EOF$) 2384 ((eolp) (if *ECHO (terpri)) 2385 (forward-line) $EOL$) 2386 (t (let ((c (char-after))) 2387 (if *ECHO (write-char c)) 2388 (forward-char) 2389 (esl--readch-char-to-interned-id c))))))) 2390 ;; When end of file is reached on a non-standard input device, 2391 ;; the standard input device is reselected. But can't kill the 2392 ;; buffer within `with-current-buffer'! 2393 ;; OR MAYBE YOU CAN!!! But leave this version for now. 2394 (if (eq result $EOF$) 2395 (CLOSE (RDS nil))) 2396 result) 2397 ;; Read from terminal: 2398 (if esl--readch-use-minibuffer 2399 ;; Read from the minibuffer: 2400 (progn 2401 (when (null esl--readch-input-string) 2402 ;; If the input string is null then this is a call for new 2403 ;; input. Read a new input string from the minibuffer, 2404 ;; save it and return the first character. 2405 (setq esl--readch-input-string 2406 (if noninteractive 2407 (read-from-minibuffer "") 2408 (let (standard-output) 2409 ;; to avoid minibuffer errors resetting this 2410 (read-from-minibuffer "REDUCE: " 2411 nil nil nil 'esl--readch-history))) 2412 esl--readch-input-string-length 2413 (length esl--readch-input-string) 2414 esl--readch-input-string-index 0) 2415 ;; (when *ECHO 2416 ;; Echo the new input line unless in batch mode: 2417 (unless noninteractive 2418 (with-current-buffer standard-output 2419 (goto-char (point-max)) ; in case point moved interactively 2420 (princ esl--readch-input-string) (terpri))));) 2421 ;; Then return the next character from the input string. 2422 ;; When the last character has been returned, clear the 2423 ;; string to trigger new input. 2424 (if (or (equal esl--readch-input-string "") ; Empty input. 2425 (= esl--readch-input-string-index ; Off end of 2426 esl--readch-input-string-length)) ; input line. 2427 (progn 2428 (setq esl--readch-input-string nil) 2429 $EOL$) 2430 ;; Return the next character and move the pointer along: 2431 (let ((c (aref esl--readch-input-string 2432 esl--readch-input-string-index))) 2433 (setq esl--readch-input-string-index 2434 (1+ esl--readch-input-string-index)) 2435 ;; Might get \n in pasted text: 2436 (if (eq c ?\n) $EOL$ (esl--readch-char-to-interned-id c))))) 2437 ;; Read from interaction buffer: 2438 (with-current-buffer "*Standard LISP*" 2439 (goto-char esl--marker) 2440 ;; When end of file occurs on the standard input device the 2441 ;; Standard LISP reader terminates. [NOT YET IMPLEMENTED.] 2442 (cond ((eobp) $EOF$) 2443 ((eolp) (forward-line) 2444 (set-marker esl--marker (point)) $EOL$) 2445 (t (let ((c (char-after esl--marker))) 2446 (set-marker esl--marker (1+ esl--marker)) 2447 (esl--readch-char-to-interned-id c))))))))) 2448 2449;; (advice-add 'READCH :filter-return 2450;; (lambda (x) (princ x #'external-debugging-output))) 2451 2452;; (advice-add 'read-from-minibuffer :filter-return 2453;; (lambda (x) (princ x #'external-debugging-output))) 2454 2455(defun TERPRI () 2456 "TERPRI():NIL 2457The current print line is terminated." 2458 (setq esl--posn 0) 2459 (terpri) 2460 nil) 2461 2462(defun WRS (filehandle) 2463 "WRS(FILEHANDLE:any):any eval, spread 2464Output to the currently active output file is suspended and further 2465output is directed to the file named. FILEHANDLE is an internal 2466name which is returned by OPEN. The file named must have been 2467opened for output. If FILEHANDLE is NIL the standard output 2468device is selected. WRS returns the internal name of the previously 2469selected output file. 2470***** FILEHANDLE could not be selected for output" 2471 (let (stream) 2472 (if filehandle 2473 (unless (and (consp filehandle) 2474 (eq (cdr filehandle) 'OUTPUT) 2475 (or (eq (setq stream (car filehandle)) t) 2476 (bufferp stream))) 2477 (error "%s could not be selected for output" filehandle)) 2478 ;; In batch mode, output to stdout: 2479 (if noninteractive (setq stream t))) 2480 (prog1 2481 (if esl--write-stream (cons esl--write-stream 'OUTPUT)) 2482 (setq esl--write-stream stream 2483 standard-output (or stream esl--default-output-buffer))))) 2484 2485 2486;;; LISP Reader 2487;;; =========== 2488 2489;; Interaction via Emacs based on the standard read-eval-print loop. 2490 2491;; From the ELisp Manual: 2492 2493;; `t' used as a stream means that the input is read from the 2494;; minibuffer. In fact, the minibuffer is invoked once and the text 2495;; given by the user is made into a string that is then used as the 2496;; input stream. If Emacs is running in batch mode, standard input is 2497;; used instead of the minibuffer. For example, 2498;; (message "%s" (read t)) 2499;; will read a Lisp expression from standard input and print the 2500;; result to standard output. 2501 2502;; Use the above approach to make READCH read from the minibuffer. 2503 2504(define-derived-mode esl-standard-lisp-interaction-mode 2505 lisp-interaction-mode "SLISP Interaction" 2506 "Major mode for entering and evaluating Standard LISP forms.") 2507 2508(defun STANDARD-LISP () 2509 "Run Standard LISP with input via the minibuffer and output via a buffer." 2510 ;; EXPR PROCEDURE STANDARD!-LISP(); 2511 ;; BEGIN SCALAR VALUE; 2512 ;; RDS NIL; WRS NIL; 2513 ;; PRIN2 \"Standard LISP\"; TERPRI(); 2514 ;; WHILE T DO 2515 ;; << PRIN2 \"EVAL:\"; TERPRI(); 2516 ;; VALUE := ERRORSET(QUOTE EVAL READ(), T, T); 2517 ;; IF NOT ATOM VALUE THEN PRINT CAR VALUE; 2518 ;; TERPRI() >>; 2519 ;; END; 2520 (interactive) 2521 (switch-to-buffer 2522 (setq esl--default-output-buffer 2523 (get-buffer-create esl--default-output-buffer-name))) 2524 (esl-standard-lisp-interaction-mode) 2525 (goto-char (point-max)) ; in case buffer already exists 2526 (let (value ; value of last sexp 2527 ;; Output to the END of the current buffer: 2528 ;; (standard-output (set-marker esl--marker (point-max))) 2529 ;; The above is proving unreliable, so try this: 2530 (standard-output (or noninteractive ; in batch mode, output to stdout 2531 (current-buffer))) 2532 ;; Make (READCH) read from the minibuffer: 2533 (esl--readch-use-minibuffer t)) 2534 (if (= (buffer-size) 0) 2535 (princ "Standard LISP")) 2536 (RDS nil) (WRS nil) 2537 (catch 'QUIT 2538 (while t 2539 (terpri) 2540 (princ "Eval: ") 2541 (setq value (ERRORSET '(eval (esl--read-and-echo)) t t)) 2542 (unless (ATOM value) 2543 (terpri) 2544 (princ "====> ") (princ (car value)) (terpri)))))) 2545 2546(defun QUIT () 2547 "QUIT() 2548Causes termination of the LISP reader and control to be 2549transferred to the operating system." 2550 (throw 'QUIT nil)) 2551 2552;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2553 2554 2555;;; Emacs Support Code 2556;;; ================== 2557 2558(defvar esl-interaction-mode-map 2559 (let ((map (make-sparse-keymap))) 2560 (define-key map "\e\C-x" 'esl-read-eval-print) 2561 (define-key map "\C-j" 'esl-read-eval-print) 2562 map) 2563 "Keymap for Standard LISP interaction mode. 2564Most commands are inherited from `lisp-interaction-mode-map'.") 2565 2566(define-derived-mode esl-interaction-mode 2567 lisp-interaction-mode "SLISP Interaction" 2568 "Major mode for entering and evaluating Standard LISP forms." 2569 (make-local-variable 'comment-start) 2570 (setq comment-start "%") 2571 ;; Always advance point in this buffer's window when text is inserted: 2572 (make-local-variable 'window-point-insertion-type) 2573 (setq window-point-insertion-type t) 2574 ) 2575 2576(defun esl-run (rlisp-mode) 2577 "Run Standard LISP with IO via a buffer." 2578 (interactive "P") 2579 (switch-to-buffer 2580 (setq esl--default-output-buffer 2581 (get-buffer-create esl--default-output-buffer-name))) 2582 (esl-interaction-mode) 2583 (let ((standard-output (set-marker esl--marker 1))) 2584 (princ "Standard LISP") (terpri) 2585 (terpri) (princ "Eval: ")) 2586 (when rlisp-mode 2587 (load-file "boot.elc") 2588 (insert "(BEGIN2)\n\n;end;") 2589 (forward-line -1))) 2590 2591(defun esl-read-eval-print (rlisp-mode) 2592 "Read input after `esl--marker', eval it and print the result." 2593 (interactive "P") 2594 (let ((standard-input esl--marker) 2595 (standard-output esl--marker) 2596 value) 2597 (setq value (ERRORSET '(eval (read)) t t)) 2598 (unless (ATOM value) 2599 (terpri) (terpri) (princ "====> ") (princ (car value))) 2600 (terpri) (terpri) (princ "Eval: ") 2601 ;; Output does not necessarily advance point, so... 2602 (goto-char esl--marker)) 2603 (when rlisp-mode 2604 (insert "(BEGIN2)\n\n;end;") 2605 (forward-line -1))) 2606 2607(defun esl-eval-print-last-sexp () 2608 "Copy sexp before point to end of *Standard LISP* buffer. 2609Then evaluate it and print value into *Standard LISP* buffer." 2610 (interactive) 2611 (let ((sexp (buffer-substring-no-properties 2612 (save-excursion (backward-sexp) (point)) 2613 (point)))) 2614 (save-current-buffer 2615 (set-buffer "*Standard LISP*") 2616 (insert sexp) 2617 (esl-read-eval-print nil) 2618 ))) 2619 2620(global-set-key "\C-c\C-j" 'esl-eval-print-last-sexp) 2621 2622(defun esl-pp-fn (symbol) 2623 "Pretty-print SYMBOL's function definition." 2624 (interactive) 2625 (null (pp (symbol-function symbol)))) 2626 2627 2628;;; Additional Lisp functions expected by REDUCE 2629;;; ============================================ 2630 2631;;; These function are not defined in the Standard Lisp Report. 2632 2633(defalias 'ID2STRING 'symbol-name) 2634 2635(defalias 'CONCAT 'concat) 2636 2637;; This function does not appear in the PSL manual either; I have no 2638;; idea where it is supposed to be defined! 2639(defalias 'RASSOC 'rassoc) 2640 2641(defun EXPLODE2 (u) 2642 "(explode2 U:atom-vector): id-list expr 2643PRIN2-like version of EXPLODE without escapes or double quotes." 2644 ;; NB: This function may need more work. It will not explode a 2645 ;; vector containing big integers correctly! 2646 (seq-map 2647 (lambda (c) (intern (string c))) 2648 (if (esl-bigint-p u) 2649 (esl-bigint-to-string u) 2650 (prin1-to-string u t)))) 2651 2652(defun INT2ID (i) 2653 "(int2id I:integer): id expr 2654Converts an integer to an id; this refers to the I'th id in the id space. Since 26550 ... 255 correspond to ASCII characters, int2id with an argument in this 2656range converts an ASCII code to the corresponding single character id. The 2657id NIL is always found by (int2id 128)." 2658 ;; I'm guessing that the id should be interned! If not, use make-symbol. 2659 (intern (string i))) 2660 2661(defun STRING-DOWNCASE (u) 2662 "Convert identifier or string U to a lower-case string." 2663 (downcase (if (symbolp u) (symbol-name u) u))) 2664 2665(defvar esl-load-message nil ; cf. the PSL VERBOSELOAD switch 2666 "If non-nil print message before and after loading a Lisp library.") 2667 2668(defun LOAD-MODULE (module) 2669 "Load the compiled REDUCE module file \"fasl/MODULE.elc\". 2670If `esl-load-message' is non-nil then output loading messages." 2671 ;; Not currently used in the REDUCE distribution. 2672 (load (concat "fasl/" (STRING-DOWNCASE module) ".elc") 2673 nil (not esl-load-message) t)) 2674 2675(defun EVLOAD (l) 2676 "Load each compiled REDUCE module in the list of identifiers L." 2677 ;; symbolic procedure evload l; 2678 ;; for each m in l do load!-module m; 2679 (mapc #'LOAD-MODULE l)) 2680 2681(defmacro LOAD (&rest files) ; not sure about this! 2682 ;; From the PSL manual: 2683 "(load [FILE:fstring, idg]): nil macro 2684For each argument FILE, an attempt is made to locate a 2685corresponding file. If a file is found then it will be loaded by 2686a call on an appropriate function. A full file name is 2687constructed by using the directory specifications in 2688loaddirectories* and the extensions in loadextensions*. The 2689strings from each list are used in a left to right order, for a 2690given string from loaddirectories* each extension from 2691loadextensions* is used. 2692 2693In addition, the name FILE is added to the list referenced by 2694options*. If FILE is found to be in options* then the attempt to 2695load FILE will be ignored. 2696*** FILE already loaded 2697Note that memq is used to determine if FILE is in 2698options*. Therefore when you use string arguments for loading 2699files, although identical names for ids refer to the same object, 2700identical names for strings refer to different objects." 2701 `(progn 2702 (mapc 2703 (lambda (x) 2704 (let ((filename (concat "fasl/" (STRING-DOWNCASE x) ".elc"))) 2705 (unless (and (symbolp x) 2706 (assoc (expand-file-name filename) load-history)) 2707 (load filename t (not esl-load-message) t)))) 2708 ',files) 2709 nil)) 2710 2711(defun TIME () 2712 "(time): integer expr 2713Elapsed time from some arbitrary initial point in milliseconds." 2714 (round (* (float-time) 1000))) 2715 2716(defun GCTIME () 2717 "(gctime): integer expr 2718Accumulated time elapsed in garbage collections in milliseconds." 2719 (round (* gc-elapsed 1000))) 2720 2721(defun DATE () 2722 "(date): string expr 2723The date in the form \"day-month-year\" 27241 lisp> (date) 2725\"21-Jan-1997\"" 2726 (format-time-string "%d-%b-%Y")) 2727 2728(defalias 'GETENV 'getenv) 2729;; GETENV is used by REDUCE module tmprint and probably others. I'm 2730;; guessing how it is defined since I can't find any documentation! 2731 2732;; The following 3 functions are defined in the PSL manual and will 2733;; probably be required or at least useful: 2734 2735(defun SYSTEM (command) 2736 "(system COMMAND:string):undefined expr 2737starts a (system specific) command interpreter and passes the 2738command to the interpreter. E.g. under the UNIX operating system 2739a Bourne shell is started and COMMAND is interpreted following 2740the conventions of this shell. Of course it is possible to use 2741e.g. (system \"bash\")" 2742 ;; Output to current buffer. 2743 (call-process-shell-command command nil t)) 2744 2745(defun PWD () 2746 "(pwd):STRING expr 2747returns the current working directory in system specific format." 2748 default-directory) 2749 2750(defalias 'CD 'cd) ; This may not be quite compatible with PSL. 2751;; (cd DIR:string):BOOLEAN expr 2752;; sets the current working directory to DIR after expanding the 2753;; filename according to the rules of the operating system. If this 2754;; operation is not sucessful, the value Nil is returned. 2755 2756(defun COPY (u) ; From the PSL manual 2757 "(copy U:any): any expr 2758This function returns a copy of U. While each pair is copied, 2759atomic elements (for example ids, strings, and vectors) are not. 2760See totalcopy in section 7.5. Note that copy is recursive and 2761will not terminate if its argument is a circular list." 2762 (if (consp u) 2763 (cons (COPY (car u)) (COPY (cdr u))) 2764 u)) 2765 2766(defalias 'COMPILETIME 'eval-when-compile ; From the PSL manual 2767 "(compiletime U:form): nil expr 2768Evaluate the expression U at compile time only.") 2769 2770(defun BLDMSG (fmt &rest args) ; From the PSL manual 2771 "(bldmsg FORMAT:string, [ARGS:any]): string expr 2772Printf to string." 2773 ;; This is a quick and dirty hack! 2774 ;; See "support/csl.red" for a better version. 2775 ;; The format argument is not well documented, so I can only guess 2776 ;; at what format specifiers might be accepted! Those actually used 2777 ;; in REDUCE appear to be %w (use prin2), %d (integer) and %s (???). 2778 (apply #'format 2779 (replace-regexp-in-string "%[^s%]" "%s" fmt) 2780 args)) 2781 2782 2783;;; Debugging support 2784;;; ================= 2785 2786;; In (esl)rend.red, the functions tr, trst, untr, untrst are flagged 2787;; noform and given the stat property rlis. cslrend.red defines them 2788;; all as macros, much as I do below. 2789 2790;; These functions are modelled on those provided by PSL and use the 2791;; Elisp trace package. (But unfortunately there doesn't seem to be 2792;; any Elisp facility for assignment tracing!) 2793 2794(defmacro TR (&rest idlist) 2795 "Trace the functions in IDLIST." 2796 ;; mapc returns its second argument, SEQUENCE. 2797 `(mapc #'trace-function-foreground ',idlist)) 2798 2799(defmacro UNTR (&rest idlist) 2800 "Untrace the functions in IDLIST." 2801 `(progn (mapc #'untrace-function ',idlist) nil)) 2802 2803 2804(defalias 'PROP 'symbol-plist 2805 "Return an identifier's property list as in PSL.") 2806 2807(defalias 'PLIST 'symbol-plist 2808 "Return an identifier's property list as in CSL.") 2809 2810 2811;;; Fast loading (FASL) support 2812;;; =========================== 2813 2814;; This code is modelled loosely on "mkfasl.red" and CSL/PSL 2815;; behaviour. It is intended only to be run in REDUCE and requires 2816;; RLISP, i.e. "rlisp.red" and "eslrend.red". 2817 2818;; THERE IS SOME CODE DUPLICATION HERE THAT SHOULD PERHAPS BE REMOVED! 2819 2820;; (defun MKFASL (name) 2821;; "Produce an ESL FASL (.elc) file for the module NAME. 2822;; NAME should be an identifier or string." 2823;; (if (fboundp 'BEGIN1) 2824;; (let* (*INT *ECHO faslout-filehandle faslout-stream ichan oldichan 2825;; name.el esl--saved-plist-alist 2826;; (*DEFN t) 2827;; ;; Don't need prettyprinted Lisp output; print 2828;; ;; output should suffice: 2829;; (defn-print (lambda (x) (print x faslout-stream))) 2830;; ;; Functions are often used before they are defined and several 2831;; ;; modules refer to undefined free variables, so... 2832;; (byte-compile-warnings '(not free-vars unresolved))) 2833;; (setq name (STRING-DOWNCASE name)) 2834;; (princ (format "*** Compiling %s ..." name)) 2835;; ;; Output the Emacs Lisp version of the file: 2836;; (setq faslout-filehandle 2837;; (OPEN (setq name.el (concat name ".el")) 'OUTPUT)) 2838;; (setq faslout-stream (car faslout-filehandle)) 2839;; (setq ichan (OPEN (concat name ".red") 'INPUT)) 2840;; (setq oldichan (RDS ichan)) 2841;; (advice-add 'PRETTYPRINT :override defn-print) 2842;; (unwind-protect 2843;; (BEGIN1) 2844;; (advice-remove 'PRETTYPRINT defn-print) 2845;; (CLOSE ichan) (RDS oldichan) 2846;; (CLOSE faslout-filehandle) 2847;; (esl-reinstate-plists)) 2848;; ;; Compile and then delete the Emacs Lisp version of the file: 2849;; (if (byte-compile-file name.el) 2850;; (progn 2851;; (delete-file name.el) 2852;; (princ " succeeded\n") 2853;; nil) 2854;; (error "Error during mkfasl of %s" name))))) 2855 2856;; (FLAG '(MKFASL) 'OPFN) ; make it a symbolic operator 2857;; (FLAG '(MKFASL) 'NOVAL) ; just return Lisp value 2858 2859;; (defun FASLOUT (name) 2860;; "Compile subsequent input into ESL FASL file \"NAME.elc\". 2861;; NAME should be an identifier or string." 2862;; ;; Output subsequent code as Lisp to a temporary file until FASLEND 2863;; ;; evaluated. 2864;; (if (fboundp 'BEGIN1) 2865;; (let* (faslout-filehandle faslout-stream name.el 2866;; (*DEFN t) 2867;; ;; Don't need prettyprinted Lisp output; print 2868;; ;; output should suffice: 2869;; (defn-print (lambda (x) (print x faslout-stream))) 2870;; ;; Functions are often used before they are defined, so... 2871;; (byte-compile-warnings '(unresolved))) 2872;; (setq name (STRING-DOWNCASE name)) 2873;; (princ (format "FASLOUT %s: IN files; or type in expressions. 2874;; When all done, execute FASLEND;\n\n" name)) 2875;; ;; Output the Emacs Lisp version of the file: 2876;; (setq faslout-filehandle (OPEN (setq name.el (concat name ".el")) 'OUTPUT)) 2877;; (setq faslout-stream (car faslout-filehandle)) 2878;; (advice-add 'PRETTYPRINT :override defn-print) 2879;; (catch 'faslend 2880;; (unwind-protect 2881;; (BEGIN1) 2882;; (advice-remove 'PRETTYPRINT defn-print) 2883;; (CLOSE faslout-filehandle))) 2884;; ;; Compile and then delete the Emacs Lisp version of the file: 2885;; (princ (format "*** Compiling %s ..." name)) 2886;; (if (byte-compile-file name.el) 2887;; (progn 2888;; (delete-file name.el) 2889;; (princ " succeeded\n") 2890;; nil) 2891;; (error "Error during compilation of %s" name))))) 2892 2893;; (FLAG '(FASLOUT) 'OPFN) 2894;; (FLAG '(FASLOUT) 'NOVAL) 2895 2896;; (defun FASLEND () 2897;; "Terminate a previous FASLOUT and generate the .elc file." 2898;; ;; Only allowed after a previous FASLOUT. 2899;; ;; Close the temporary Lisp output file and then compile it. 2900;; (throw 'faslend nil)) 2901 2902;; (PUT 'FASLEND 'STAT 'ENDSTAT) 2903;; (FLAG '(FASLEND) 'EVAL) ; must be evaluated in this model 2904 2905(defvar *INT) 2906(defvar *WRITINGFASLFILE nil 2907 "REDUCE variable set to t by FASLOUT and reset to nil by FASLEND.") 2908 2909(defvar esl--faslout-filehandle) 2910(defvar esl--faslout-name.el) 2911(defvar esl--faslout-stream) 2912(defvar esl--faslout-old-lower) 2913 2914(declare-function SUPERPRINM "eslpretty" (X LMAR)) 2915 2916(defun esl--faslout-prettyprint-override (x) 2917 "Print X with output to the faslout stream. 2918For readable output, this function prettyprints each form 2919followed by a blank line. But if the Lisp source code will be 2920deleted then `print' would suffice!" 2921 (unless (equal x '(FASLEND)) ; better way? 2922 (let ((standard-output esl--faslout-stream) 2923 (esl--linelength 120)) ; default of 80 seems too short 2924 (advice-add 'EXPLODE :override #'esl--faslout-explode-override) 2925 (SUPERPRINM x 0) 2926 (advice-remove 'EXPLODE #'esl--faslout-explode-override) 2927 (terpri) nil))) 2928 2929(defun esl--faslout-explode-override (u) 2930 "As (EXPLODE U) but using Emacs Lisp syntax. 2931Used for faslout Lisp generation, which must be Emacs Lisp, 2932not Standard LISP, since it will be compiled by Emacs." 2933 (seq-map 2934 (lambda (c) (intern (string c))) 2935 (prin1-to-string u))) 2936 2937(defun FASLOUT (name) 2938 "Compile subsequent input into ESL FASL file \"NAME.elc\". 2939NAME should be an identifier or string." 2940 ;; Output subsequent code as Lisp to a temporary file until FASLEND 2941 ;; evaluated. 2942 (setq name (STRING-DOWNCASE name)) 2943 (setq esl--faslout-old-lower *LOWER) 2944 (setq *WRITINGFASLFILE t 2945 *DEFN t 2946 *LOWER nil) 2947 (if *INT 2948 (princ (format "FASLOUT %s: IN files; or type in expressions. 2949When all done, execute FASLEND;\n\n" name))) 2950 ;; Output the Emacs Lisp version of the file: 2951 (setq esl--faslout-filehandle 2952 (OPEN (setq esl--faslout-name.el (concat name ".el")) 'OUTPUT)) 2953 (setq esl--faslout-stream (car esl--faslout-filehandle)) 2954 ;; Must have a definition of PRETTYPRINT to advise, so... 2955 (require 'eslpretty) 2956 (advice-add 'PRETTYPRINT :override #'esl--faslout-prettyprint-override)) 2957 2958(FLAG '(FASLOUT) 'OPFN) 2959(FLAG '(FASLOUT) 'NOVAL) 2960 2961(defun FASLEND () 2962 "Terminate a previous FASLOUT and generate the .elc file." 2963 ;; Only allowed after a previous FASLOUT. 2964 ;; First, tidy up after the call of FASLOUT: 2965 (advice-remove 'PRETTYPRINT #'esl--faslout-prettyprint-override) 2966 (setq *WRITINGFASLFILE nil 2967 *DEFN nil 2968 *LOWER esl--faslout-old-lower) 2969 ;; Now process the Lisp output generated by FASLOUT: 2970 (let ((buf (car esl--faslout-filehandle)) 2971 ;; Functions are often used before they are defined and 2972 ;; several modules refer to undefined free variables, so... 2973 (byte-compile-warnings '(not free-vars unresolved cl-functions)) 2974 *COMP) ; OFF COMP -- don't re-compile compiled code! 2975 (if (zerop (buffer-size buf)) 2976 (progn 2977 (lwarn '(esl fasl) :error 2978 "No output generated for fasl file %s" esl--faslout-name.el) 2979 ;; Do not output an empty file, just kill the empty buffer: 2980 (kill-buffer buf)) 2981 (esl-reinstate-plists) 2982 ;; Hack (until I think of a better solution) to remove the "%+" 2983 ;; continuation marker added by the prettyprinter to long atoms, 2984 ;; such as big integers, that prevents the content being read by 2985 ;; Emacs Lisp. This matters for "specfn/spfdata". 2986 (with-current-buffer buf 2987 (goto-char 0) 2988 (while (search-forward "%+\n" nil t) (replace-match ""))) 2989 ;; Close the temporary Lisp output file and then compile it. 2990 (CLOSE esl--faslout-filehandle) 2991 ;; Check that an Emacs Lisp file has been written: 2992 (let ((attribs (file-attributes esl--faslout-name.el))) 2993 (unless (and attribs (> (file-attribute-size attribs) 0)) 2994 (error "Error writing %s" esl--faslout-name.el)) 2995 ;; Compile the Emacs Lisp version of the file: 2996 (message "Compiling %s..." esl--faslout-name.el) 2997 (if (byte-compile-file esl--faslout-name.el) 2998 ;; (progn 2999 ;; (delete-file esl--faslout-name.el) ; keep to aid debugging 3000 (message "Compiling %s...done" esl--faslout-name.el) 3001 ;; nil) 3002 (error "Error compiling %s" esl--faslout-name.el)))))) 3003 3004(PUT 'FASLEND 'STAT 'ENDSTAT) 3005(FLAG '(FASLEND) 'EVAL) ; must be evaluated in this model 3006 3007 3008;;; Miscellaneous 3009;;; ============= 3010 3011;; This procedure should be defined in rend.red, but I need to use 3012;; Emacs Lisp and hence lower case, so it's easier to define it here. 3013 3014;; symbolic procedure orderp(u,v); 3015;; % Returns true if U has same or higher order than id V by some 3016;; % consistent convention (eg unique position in memory). 3017;; wleq(inf u,inf v); % PSL 3.4 form. 3018;; % id2int u <= id2int v; % PSL 3.2 form. 3019 3020(defun ORDERP (u v) 3021 "Returns true if id U has same or higher order than id V by 3022some consistent convention (eg unique position in memory)." 3023 ;; Ignore case by down-casing the strings. 3024 (not (string< (downcase (symbol-name v)) 3025 (downcase (symbol-name u))))) 3026 3027;; To run Edebug on a FUNCTION defined in RLISP, use esl-pp-fn in 3028;; *scratch* to get an Emacs Lisp version of FUNCTION, change the 3029;; header from `lambda' to `defun FUNCTION', and then instrument this 3030;; definition for debugging. 3031 3032;; Support for running Edebug on the BLOCK macro, which is defined in 3033;; rlisp.red essentially as if it were written in Emacs Lisp like 3034;; this: 3035;; 3036;; (defmacro BLOCK (&rest U) 3037;; (setq U (cons 'BLOCK U)) 3038;; (CONS 'PROG (CONS 3039;; (MAPCAR (CADR U) (FUNCTION CAR)) 3040;; (CDDR U)))) 3041 3042(def-edebug-spec BLOCK (sexp body)) 3043 3044;; This code is useful for bootstrapping: (DSKIN "dbuild.el") 3045 3046(defvar OLDCHAN*) 3047 3048(defun DSKIN (name) 3049 "(dskin NAME:string): nil, abort expr 3050The contents of the file NAME are processed as if they were typed in. 3051Once the input stream has been bound to the channel which 3052represents the open file, each form is processed." 3053 (RDS (setq OLDCHAN* (OPEN name 'INPUT)))) 3054 3055(provide 'esl) 3056 3057;;; esl.el ends here 3058