aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/Makefile.in44
-rw-r--r--src/interp/debug.lisp4
-rw-r--r--src/interp/fname.lisp4
-rw-r--r--src/interp/format.boot2
-rw-r--r--src/interp/g-timer.boot2
-rw-r--r--src/interp/g-util.boot2
-rw-r--r--src/interp/ht-util.boot2
-rw-r--r--src/interp/htcheck.boot4
-rw-r--r--src/interp/htsetvar.boot4
-rw-r--r--src/interp/macros.lisp501
-rw-r--r--src/interp/monitor.lisp2
-rw-r--r--src/interp/newaux.lisp4
-rw-r--r--src/interp/newfort.boot2
-rw-r--r--src/interp/nlib.lisp2
-rw-r--r--src/interp/postpar.boot4
-rw-r--r--src/interp/profile.boot4
-rw-r--r--src/interp/server.boot2
-rw-r--r--src/interp/setvars.boot2
-rw-r--r--src/interp/setvart.boot4
-rw-r--r--src/interp/sfsfun.boot2
-rw-r--r--src/interp/simpbool.boot4
-rw-r--r--src/interp/spad.lisp2
-rw-r--r--src/interp/sys-macros.lisp9
-rw-r--r--src/interp/termrw.boot4
-rw-r--r--src/interp/topics.boot4
-rw-r--r--src/interp/vmlisp.lisp462
-rw-r--r--src/interp/word.boot2
27 files changed, 494 insertions, 590 deletions
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 217a1873..810dd0eb 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -59,7 +59,6 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \
sys-utility.$(FASLEXT) lexing.$(FASLEXT) \
diagnostics.$(FASLEXT) \
union.$(FASLEXT) sys-macros.$(FASLEXT) \
- macros.$(FASLEXT) \
util.$(FASLEXT) \
unlisp.$(FASLEXT) g-util.$(FASLEXT) \
g-opt.$(FASLEXT) c-util.$(FASLEXT) \
@@ -244,7 +243,7 @@ database.date:
fortcall.$(FASLEXT): sys-macros.$(FASLEXT)
## HyperDoc
-topics.$(FASLEXT): macros.$(FASLEXT)
+topics.$(FASLEXT): sys-macros.$(FASLEXT)
alql.$(FASLEXT): br-search.$(FASLEXT)
br-search.$(FASLEXT): bc-util.$(FASLEXT)
br-saturn.$(FASLEXT): bc-util.$(FASLEXT)
@@ -259,15 +258,15 @@ bc-matrix.$(FASLEXT): bc-util.$(FASLEXT)
bc-misc.$(FASLEXT): bc-util.$(FASLEXT)
bc-util.$(FASLEXT): ht-util.$(FASLEXT) c-util.$(FASLEXT)
ht-root.$(FASLEXT): ht-util.$(FASLEXT)
-htcheck.$(FASLEXT): sys-driver.$(FASLEXT) macros.$(FASLEXT)
-ht-util.$(FASLEXT): macros.$(FASLEXT)
-htsetvar.$(FASLEXT): macros.$(FASLEXT)
+htcheck.$(FASLEXT): sys-driver.$(FASLEXT) sys-macros.$(FASLEXT)
+ht-util.$(FASLEXT): sys-macros.$(FASLEXT)
+htsetvar.$(FASLEXT): sys-macros.$(FASLEXT)
hypertex.$(FASLEXT): types.$(FASLEXT)
## OpenAxiom's interpreter.
makeint.$(FASLEXT): util.$(FASLEXT)
-setvars.$(FASLEXT): macros.$(FASLEXT) debug.$(FASLEXT)
-profile.$(FASLEXT): macros.$(FASLEXT)
+setvars.$(FASLEXT): sys-macros.$(FASLEXT) debug.$(FASLEXT)
+profile.$(FASLEXT): sys-macros.$(FASLEXT)
rulesets.$(FASLEXT): vmlisp.$(FASLEXT)
osyscmd.$(FASLEXT): int-top.$(FASLEXT)
int-top.$(FASLEXT): incl.$(FASLEXT) i-toplev.$(FASLEXT) unlisp.$(FASLEXT)
@@ -285,10 +284,10 @@ i-analy.$(FASLEXT): i-object.$(FASLEXT)
i-intern.$(FASLEXT): i-object.$(FASLEXT) ptrees.$(FASLEXT)
i-object.$(FASLEXT): i-util.$(FASLEXT)
i-util.$(FASLEXT): c-util.$(FASLEXT)
-format.$(FASLEXT): macros.$(FASLEXT)
+format.$(FASLEXT): sys-macros.$(FASLEXT)
match.$(FASLEXT): sys-macros.$(FASLEXT)
record.$(FASLEXT): nlib.$(FASLEXT) pathname.$(FASLEXT)
-setvart.$(FASLEXT): macros.$(FASLEXT)
+setvart.$(FASLEXT): sys-macros.$(FASLEXT)
## OpenAxiom's compiler
compiler.$(FASLEXT): msgdb.$(FASLEXT) pathname.$(FASLEXT) define.$(FASLEXT)
@@ -302,11 +301,11 @@ functor.$(FASLEXT): category.$(FASLEXT) lisplib.$(FASLEXT) nrunfast.$(FASLEXT)
category.$(FASLEXT): c-util.$(FASLEXT) g-cndata.$(FASLEXT)
cattable.$(FASLEXT): simpbool.$(FASLEXT) c-util.$(FASLEXT)
compat.$(FASLEXT): pathname.$(FASLEXT)
-simpbool.$(FASLEXT): macros.$(FASLEXT)
-newfort.$(FASLEXT): macros.$(FASLEXT)
+simpbool.$(FASLEXT): sys-macros.$(FASLEXT)
+newfort.$(FASLEXT): sys-macros.$(FASLEXT)
lisplib.$(FASLEXT): nlib.$(FASLEXT) c-util.$(FASLEXT) debug.$(FASLEXT)
c-doc.$(FASLEXT): c-util.$(FASLEXT)
-server.$(FASLEXT): macros.$(FASLEXT)
+server.$(FASLEXT): sys-macros.$(FASLEXT)
##
## OpenAxiom's front-end consists of two parts:
@@ -319,11 +318,10 @@ server.$(FASLEXT): macros.$(FASLEXT)
spad-parser.$(FASLEXT): parse.$(FASLEXT) preparse.$(FASLEXT)
parse.$(FASLEXT): postpar.$(FASLEXT)
packtran.$(FASLEXT): sys-macros.$(FASLEXT)
-postpar.$(FASLEXT): macros.$(FASLEXT)
-newaux.$(FASLEXT): macros.$(FASLEXT)
+postpar.$(FASLEXT): sys-macros.$(FASLEXT)
+newaux.$(FASLEXT): sys-macros.$(FASLEXT)
preparse.$(FASLEXT): lexing.$(FASLEXT)
-nlib.$(FASLEXT): macros.$(FASLEXT)
-macros.$(FASLEXT): sys-macros.$(FASLEXT) sys-utility.$(FASLEXT)
+nlib.$(FASLEXT): sys-macros.$(FASLEXT)
lexing.$(FASLEXT): sys-utility.$(FASLEXT) sys-macros.$(FASLEXT) \
io.$(FASLEXT)
@@ -351,29 +349,29 @@ dq.$(FASLEXT): types.$(FASLEXT)
## General support and utilities.
daase.$(FASLEXT): sys-utility.$(FASLEXT)
-debug.$(FASLEXT): macros.$(FASLEXT) lexing.$(FASLEXT)
+debug.$(FASLEXT): sys-macros.$(FASLEXT) lexing.$(FASLEXT)
spad.$(FASLEXT): spad-parser.$(FASLEXT) postpar.$(FASLEXT) debug.$(FASLEXT)
-monitor.$(FASLEXT): macros.$(FASLEXT)
+monitor.$(FASLEXT): sys-macros.$(FASLEXT)
sfsfun-l.$(FASLEXT): sys-macros.$(FASLEXT)
trace.$(FASLEXT): debug.$(FASLEXT)
-termrw.$(FASLEXT): macros.$(FASLEXT)
+termrw.$(FASLEXT): sys-macros.$(FASLEXT)
showimp.$(FASLEXT): c-util.$(FASLEXT)
-sfsfun.$(FASLEXT): macros.$(FASLEXT)
+sfsfun.$(FASLEXT): sys-macros.$(FASLEXT)
slam.$(FASLEXT): g-timer.$(FASLEXT)
clammed.$(FASLEXT): g-timer.$(FASLEXT)
clam.$(FASLEXT): g-timer.$(FASLEXT)
g-opt.$(FASLEXT): g-util.$(FASLEXT)
-g-timer.$(FASLEXT): macros.$(FASLEXT) g-util.$(FASLEXT)
+g-timer.$(FASLEXT): sys-macros.$(FASLEXT) g-util.$(FASLEXT)
msgdb.$(FASLEXT): g-util.$(FASLEXT)
g-error.$(FASLEXT): diagnostics.$(FASLEXT) g-util.$(FASLEXT)
c-util.$(FASLEXT): g-opt.$(FASLEXT)
pathname.$(FASLEXT): nlib.$(FASLEXT)
word.$(FASLEXT): g-util.$(FASLEXT)
-g-util.$(FASLEXT): ggreater.$(FASLEXT) macros.$(FASLEXT) daase.$(FASLEXT)
+g-util.$(FASLEXT): ggreater.$(FASLEXT) sys-macros.$(FASLEXT) daase.$(FASLEXT)
g-cndata.$(FASLEXT): sys-macros.$(FASLEXT) c-util.$(FASLEXT)
msg.$(FASLEXT): sys-macros.$(FASLEXT) astr.$(FASLEXT)
util.$(FASLEXT): lexing.$(FASLEXT)
-fname.$(FASLEXT): macros.$(FASLEXT)
+fname.$(FASLEXT): sys-macros.$(FASLEXT)
sys-macros.$(FASLEXT): diagnostics.$(FASLEXT) union.$(FASLEXT)
buildom.$(FASLEXT): buildom.boot sys-macros.$(FASLEXT) c-util.$(FASLEXT)
diagnostics.$(FASLEXT): sys-globals.$(FASLEXT) vmlisp.$(FASLEXT)
diff --git a/src/interp/debug.lisp b/src/interp/debug.lisp
index c1db2f22..917c91ff 100644
--- a/src/interp/debug.lisp
+++ b/src/interp/debug.lisp
@@ -43,7 +43,7 @@
; NAME: Debugging Package
; PURPOSE: Debugging hooks for Boot code
-(import-module "macros")
+(import-module "sys-macros")
(import-module "lexing")
(in-package "BOOT")
@@ -602,7 +602,7 @@ EXAMINE (SETQ RECNO (NOTE |$InputStream|))
(if (NOT (OR A V C NL))
(if Caller (return "119") (return "019")))
(SETQ NL (APPEND NL '(\0)))
- (SETQ BUF (GETSTR 12))
+ (SETQ BUF (|makeString| 12))
(SUFFIX (if (or C Caller) #\1 #\0) BUF)
(SUFFIX (if V #\1 #\0) BUF)
(if A (suffix #\9 BUF)
diff --git a/src/interp/fname.lisp b/src/interp/fname.lisp
index 32dd202d..b920f495 100644
--- a/src/interp/fname.lisp
+++ b/src/interp/fname.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2010, Gabriel Dos Reis.
+;; Copyright (C) 2007-2012, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -38,7 +38,7 @@
;; Created: June 20, 1991 (Stephen Watt)
;;
-(import-module "macros")
+(import-module "sys-macros")
(in-package "BOOT")
;; E.g. "/" "/u/smwatt" "../src"
diff --git a/src/interp/format.boot b/src/interp/format.boot
index 9303a252..c759c57c 100644
--- a/src/interp/format.boot
+++ b/src/interp/format.boot
@@ -32,7 +32,7 @@
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
namespace BOOT
--% Functions for display formatting system objects
diff --git a/src/interp/g-timer.boot b/src/interp/g-timer.boot
index a6608432..6604567f 100644
--- a/src/interp/g-timer.boot
+++ b/src/interp/g-timer.boot
@@ -32,7 +32,7 @@
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
import g_-util
namespace BOOT
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index 8865e32a..c961dcc3 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -33,7 +33,7 @@
import ggreater
-import macros
+import sys_-macros
import daase
namespace BOOT
diff --git a/src/interp/ht-util.boot b/src/interp/ht-util.boot
index 6fb2998c..6bd5fe02 100644
--- a/src/interp/ht-util.boot
+++ b/src/interp/ht-util.boot
@@ -32,7 +32,7 @@
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
namespace BOOT
-- HyperTeX Utilities for generating basic Command pages
diff --git a/src/interp/htcheck.boot b/src/interp/htcheck.boot
index 8a0669ef..e4f7c5a5 100644
--- a/src/interp/htcheck.boot
+++ b/src/interp/htcheck.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2010, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -33,7 +33,7 @@
import sys_-driver
-import macros
+import sys_-macros
namespace BOOT
$primitiveHtCommands := '(
diff --git a/src/interp/htsetvar.boot b/src/interp/htsetvar.boot
index 4c84f827..b7a2555b 100644
--- a/src/interp/htsetvar.boot
+++ b/src/interp/htsetvar.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -32,7 +32,7 @@
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
namespace BOOT
htsv() ==
diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp
deleted file mode 100644
index ceb57807..00000000
--- a/src/interp/macros.lisp
+++ /dev/null
@@ -1,501 +0,0 @@
-;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-;; All rights reserved.
-;; Copyright (C) 2007-2012, Gabriel Dos Reis.
-;; All rights reserved.
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are
-;; met:
-;;
-;; - Redistributions of source code must retain the above copyright
-;; notice, this list of conditions and the following disclaimer.
-;;
-;; - Redistributions in binary form must reproduce the above copyright
-;; notice, this list of conditions and the following disclaimer in
-;; the documentation and/or other materials provided with the
-;; distribution.
-;;
-;; - Neither the name of The Numerical Algorithms Group Ltd. nor the
-;; names of its contributors may be used to endorse or promote products
-;; derived from this software without specific prior written permission.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-;; PURPOSE: Provide generally useful macros and functions for MetaLanguage
-;; and Boot code. Contents are organized along Common Lisp datatype
-;; lines, with sections numbered to match the section headings of the
-;; Common Lisp Reference Manual, by Guy Steele, Digital Press, 1984,
-;; Digital Press Order Number EY-00031-DP. This way you can
-;; look up the corresponding section in the manual and see if
-;; there isn't a cleaner and non-VM-specific way of doing things.
-
-
-;; Camm has identified a performace problem during compiles. There is
-;; a loop that continually adds one element to a vector. This causes
-;; the vector to get extended by 1 and copied. These patches fix the
-;; problem since vectors with fill pointers don't need to be copied.
-;;
-;; These cut out the lion's share of the gc problem
-;; on this compile. 30min {\tt ->} 7 min on my box. There is still some gc
-;; churning in cons pages due to many calls to 'list' with small n. One
-;; can likely improve things further with an appropriate (declare
-;; (:dynamic-extent ...)) in the right place -- gcl will allocate such
-;; lists on the C stack (very fast).
-
-
-(import-module "sys-macros")
-(import-module "sys-utility")
-(in-package "BOOT")
-
-; 5 PROGRAM STRUCTURE
-
-; 5.3 Top-Level Forms
-
-; 6 PREDICATES
-
-; 6.3 Equality Predicates
-
-(defun COMPARE (X Y)
- "True if X is an atom or X and Y are lists and X and Y are equal up to X."
- (COND ((ATOM X) T)
- ((ATOM Y) NIL)
- ((EQUAL (CAR X) (CAR Y)) (COMPARE (CDR X) (CDR Y)))))
-
-
-(DEFUN ?ORDER (U V) "Multiple-type ordering relation."
- (COND ((NULL U))
- ((NULL V) NIL)
- ((ATOM U)
- (if (ATOM V)
- (COND ((NUMBERP U) (if (NUMBERP V) (> V U) T))
- ((NUMBERP V) NIL)
- ((|ident?| U) (AND (|ident?| V) (string> (SYMBOL-NAME V) (SYMBOL-NAME U))))
- ((|ident?| V) NIL)
- ((STRINGP U) (AND (STRINGP V) (string> V U)))
- ((STRINGP V) NIL)
- ((AND (simple-vector-p U) (simple-vector-p V))
- (AND (> (SIZE V) (SIZE U))
- (DO ((I 0 (1+ I)))
- ((GT I (MAXINDEX U)) 'T)
- (COND ((NOT (EQUAL (ELT U I) (ELT V I)))
- (RETURN (?ORDER (ELT U I) (ELT V I))))))))
- ((croak "Do not understand")))
- T))
- ((ATOM V) NIL)
- ((EQUAL U V))
- ((NOT (string> (write-to-string U) (write-to-string V))))))
-
-; 7 CONTROL STRUCTURE
-
-; 7.8 Iteration
-
-; 7.8.2 General Iteration
-
-(defmacro |Zero| (&rest L)
- (declare (ignore l))
- "Needed by spadCompileOrSetq" 0)
-
-(defmacro |One| (&rest L)
- (declare (ignore l))
- "Needed by spadCompileOrSetq" 1)
-
-
-; 10.1 The Property List
-
-
-
-(defun PROPERTY (X IND N)
- "Returns the Nth element of X's IND property, if it exists."
- (let (Y) (if (AND (INTEGERP N) (SETQ Y (GET X IND)) (>= (LENGTH Y) N)) (ELEM Y N))))
-
-; 10.3 Creating Symbols
-
-
-(defvar $GENNO 0)
-
-(DEFUN GENVAR () (INTERNL "$" (STRINGIMAGE (SETQ $GENNO (1+ $GENNO)))))
-
-(DEFUN IS_GENVAR (X)
- (AND (|ident?| X)
- (let ((y (symbol-name x)))
- (and (char= #\$ (elt y 0)) (> (size y) 1) (digitp (elt y 1))))))
-
-(DEFUN IS_\#GENVAR (X)
- (AND (|ident?| X)
- (let ((y (symbol-name x)))
- (and (char= #\# (ELT y 0)) (> (SIZE Y) 1) (DIGITP (ELT Y 1))))))
-
-; 10.7 CATCH and THROW
-
-; 12 NUMBERS
-
-; 12.6 Small Finite Field ops with vector trimming
-
-(defun TRIMLZ (vec)
- (declare (simple-vector vec))
- (let ((n (position 0 vec :from-end t :test-not #'eql)))
- (cond ((null n) (vector))
- ((eql n (|maxIndex| vec)) vec)
- (t (subseq vec 0 (+ n 1))))))
-
-; 14 SEQUENCES
-
-; 14.1 Simple Sequence Functions
-
-(defun GETCHARN (A M) "Return the code of the Mth character of A"
- (let ((a (if (|ident?| a) (symbol-name a) a))) (char-code (elt A M))))
-
-; 14.2 Concatenating, Mapping, and Reducing Sequences
-
-(DEFUN STRINGPAD (STR N)
- (let ((M (length STR)))
- (if (>= M N)
- STR
- (concatenate 'string str (make-string (- N M) :initial-element #\Space)))))
-
-(DEFUN STRINGSUFFIX (TARGET SOURCE) "Suffix source to target if enough room else nil."
- (concatenate 'string target source))
-
-(defun THETACHECK (VAL VAR OP) (if (EQL VAL VAR) (THETA_ERROR OP) val))
-
-; 15 LISTS
-
-; 15.2 Lists
-
-
-(defmacro TL (&rest L) `(tail . ,L))
-
-(DEFUN LASTELEM (X) (car (|lastNode| X)))
-
-(defun LISTOFATOMS (X)
- (COND ((NULL X) NIL)
- ((ATOM X) (LIST X))
- ((|append!| (LISTOFATOMS (CAR X)) (LISTOFATOMS (CDR X))))))
-
-(DEFUN LASTATOM (L) (if (ATOM L) L (LASTATOM (CDR L))))
-
-(DEFUN NUMOFNODES (X) (if (ATOM X) 0 (+ 1 (NUMOFNODES (CAR X)) (NUMOFNODES (CDR X)))))
-
-(DEFUN TRUNCLIST (L TL) "Truncate list L at the point marked by TL."
- (let ((U L)) (TRUNCLIST-1 L TL) U))
-
-(DEFUN TRUNCLIST-1 (L TL)
- (COND ((ATOM L) L)
- ((EQL (CDR L) TL) (RPLACD L NIL))
- ((TRUNCLIST-1 (CDR L) TL))))
-
-; 15.5 Using Lists as Sets
-
-(DEFUN PREDECESSOR (TL L)
- "Returns the sublist of L whose CDR is EQ to TL."
- (COND ((ATOM L) NIL)
- ((EQ TL (CDR L)) L)
- ((PREDECESSOR TL (CDR L)))))
-
-(defun remdup (l) (remove-duplicates l :test #'equalp))
-
-; 15.6 Association Lists
-
-;;; Operations on Association Sets (AS)
-
-(defun AS-INSERT (A B L)
- ;; PF(item) x PF(item) x LIST(of pairs) -> LIST(of pairs with (A . B) added)
- ;; destructive on L; if (A . C) appears already, C is replaced by B
- (cond ((null l) (list (cons a b)))
- ((equal a (caar l)) (rplacd (car l) b) l)
- ((?order a (caar l)) (cons (cons a b) l))
- (t (as-insert1 a b l) l)))
-
-(defun as-insert1 (a b l)
- (cond ((null (cdr l)) (rplacd l (list (cons a b))))
- ((equal a (caadr l)) (rplacd (cadr l) b))
- ((?order a (caadr l)) (rplacd l (cons (cons a b) (cdr l))))
- (t (as-insert1 a b (cdr l)))))
-
-
-; 17 ARRAYS
-
-; 17.6 Changing the Dimensions of an Array
-
-
-(defun lengthenvec (v n)
- (if
- (and (array-has-fill-pointer-p v) (adjustable-array-p v))
- (if
- (>= n (array-total-size v))
- (adjust-array v (* n 2) :fill-pointer n)
- (progn
- (setf (fill-pointer v) n)
- v))
- (replace (make-array n :fill-pointer t) v)))
-
-(defun make-init-vector (n val)
- (make-array n :initial-element val :fill-pointer t))
-
-
-; 22 INPUT/OUTPUT
-
-; 22.2 Input Functions
-
-; 22.2.1 Input from Character Streams
-
-(DEFUN STREAM-EOF (&optional (STRM |$InputStream|))
- "T if input stream STRM is at the end or saw a ~."
- (not (peek-char nil STRM nil nil nil)) )
-
-(DEFUN CONSOLEINPUTP (STRM) (|ioTerminal?| STRM))
-
-(defvar $filelinenumber 0)
-(defvar $prompt "--->")
-(defvar stream-buffer nil)
-
-(DEFUN NEXTSTRMLINE (STRM) "Returns the next input line from stream STRM."
- (let ((v (read-line strm nil -1 nil)))
- (if (equal v -1) (throw 'spad_reader nil)
- (progn (setq stream-buffer v) v))))
-
-(DEFUN CURSTRMLINE (STRM)
- "Returns the current input line from the stream buffer of STRM (VM-specific!)."
- (cond (stream-buffer)
- ((stream-eof strm) (fail))
- ((nextstrmline strm))))
-
-(defvar *EOF* NIL)
-
-(DEFUN CURMAXINDEX (STRM)
-"Something bizarre and VM-specific with respect to streams."
- (if *EOF* (FAIL) (ELT (ELT (LASTATOM STRM) 1) 3)))
-
-(DEFUN ADJCURMAXINDEX (STRM)
-"Something unearthly and VM-specific with respect to streams."
- (let (v) (if *eof* (fail)
- (progn (SETQ V (ELT (LASTATOM STRM) 1))
- (SETF (ELT V 3) (SIZE (ELT V 0)))))))
-
-(DEFUN STRMBLANKLINE (STRM)
-"Something diabolical and VM-specific with respect to streams."
- (if *EOF* (FAIL) (AND (EQ '\ (CAR STRM)) (EQL 1 (CURMAXINDEX STRM)))))
-
-(DEFUN STRMSKIPTOBLANK (STRM)
-"Munch away on the stream until you get to a blank line."
- (COND (*EOF* (FAIL))
- ((PROGN (NEXTSTRMLINE STRM) (STRMBLANKLINE STRM)) STRM)
- ((STRMSKIPTOBLANK STRM))))
-
-(DEFUN CURINPUTLINE () (CURSTRMLINE |$InputStream|))
-
-(DEFUN NEXTINPUTLINE () (NEXTSTRMLINE |$InputStream|))
-
-; 22.3 Output Functions
-
-; 22.3.1 Output to Character Streams
-
-(DEFUN ATOM2STRING (X)
- "Give me the string which would be printed out to denote an atom."
- (cond ((atom x) (symbol-name x))
- ((stringp x) x)
- ((write-to-string x))))
-
-;; the following are redefined in MSGDB BOOT
-
-(DEFUN BLANKS (N &optional (stream |$OutputStream|))
- "Print N blanks."
- (declare (fixnum N))
- (do ((i 1 (the fixnum(1+ i))))
- ((> i N))
- (declare (fixnum i))
- (princ " " stream)))
-
-; 23 FILE SYSTEM INTERFACE
-
-; 23.2 Opening and Closing Files
-
-(DEFUN DEFSTREAM (file MODE)
- (if (member mode '(i input))
- (MAKE-INSTREAM file)
- (MAKE-OUTSTREAM file)))
-
-; 23.3 Renaming, Deleting and Other File Operations
-
-(DEFUN NOTE (STRM)
-"Attempts to return the current record number of a file stream. This is 0 for
-terminals and empty or at-end files. In Common Lisp, we must assume record sizes of 1!"
- (COND ((STREAM-EOF STRM) 0)
- ((|ioTerminal?| STRM) 0)
- ((file-position STRM))))
-
-(DEFUN |ioTerminal?|-NOT-XEDIT (S) (not (OR (NULL (|ioTerminal?| S)))))
-
-(DEFUN POINTW (RECNO STRM)
-"Does something obscure and VM-specific with respect to streams."
- (let (V)
- (if (STREAM-EOF STRM) (FAIL))
- (SETQ V (LASTATOM STRM))
- (SETF (ELT V 4) RECNO)
- (SETQ *EOF* (STREAM-EOF STRM))
- strm))
-
-(DEFUN POINT (RECNO STRM) (file-position strm recno))
-
-(DEFUN STRM (RECNO STRM)
-"Does something obscure and VM-specific with respect to streams."
- (let (V)
- (if (STREAM-EOF STRM) (FAIL))
- (SETQ V (LASTATOM STRM))
- (SETF (ELT V 4) RECNO)
- (read-char STRM)
- (SETQ *EOF* (STREAM-EOF STRM))
- strm))
-
-; 25 MISCELLANEOUS FEATURES
-
-;; range tests and assertions
-
-(defmacro |elapsedUserTime| () '(get-internal-run-time))
-
-#+IBCL
-(defmacro |elapsedGcTime| () '(system:gbc-time-report))
-
-#+AKCL
-(defmacro |elapsedGcTime| () '(system:gbc-time))
-
-#-(OR IBCL AKCL)
-(defmacro |elapsedGcTime| () '0)
-
-; This function was modified by Greg Vanuxem on March 31, 2005
-; to handle the special case of #'(lambda ..... which expands
-; into (function (lambda .....
-;
-; The extra if clause fixes bugs #196 and #114
-;
-; an example that used to cause the failure was:
-; )set func comp off
-; f(xl:LIST FRAC INT): LIST FRAC INT == map(x +-> x, xl)
-; f [1,2,3]
-;
-; which expanded into
-;
-; (defun |xl;f;1;initial| (|#1| |envArg|)
-; (prog (#:G1420)
-; (return
-; (progn
-; (lett #:G1420 'uninitialized_variable |f| |#1;f;1:initial|)
-; (spadcall
-; (cons (|function| (lambda (#:G1420 |envArg|) #:G1420)) (vector))
-; |#1|
-; (svref |*1;f;1;initial;MV| 0))))))
-;
-; the (|function| (lambda form used to cause an infinite expansion loop
-;
-(defun macroexpandall (sexpr)
- (cond
- ((atom sexpr) sexpr)
- ((eq (car sexpr) 'quote) sexpr)
- ((eq (car sexpr) 'defun)
- (cons (car sexpr) (cons (cadr sexpr)
- (mapcar #'macroexpandall (cddr sexpr)))))
- ((and (symbolp (car sexpr)) (macro-function (car sexpr)))
- (do ()
- ((not (and (consp sexpr) (symbolp (car sexpr))
- (macro-function (car sexpr)))))
- (setq sexpr (macroexpand sexpr)))
- (if (consp sexpr)
- (let ((a (car sexpr)) (b (caadr sexpr)))
- (if (and (eq a 'function) (eq b 'lambda))
- (cons a (list (cons b (mapcar #'macroexpandall (cdadr sexpr)))))
- (mapcar #'macroexpandall sexpr)))
- sexpr))
- ('else
- (mapcar #'macroexpandall sexpr))))
-
-
-(defun |deleteWOC| (item list) (delete item list :test #'equal))
-
-;;---- Added by WFS.
-
-(proclaim '(ftype (function (t t) t) |subWord|)) ;hack for bug in akcl-478
-
-(DEFUN |subWord| (|str| N )
- (declare (fixnum n ) (string |str|))
- (PROG (|word| (|n| 0) |inWord|(|l| 0) )
- (declare (fixnum |n| |l|))
- (RETURN
- (SEQ (COND
- ((> 1 N) NIL)
- ('T (SPADLET |l| (SPADDIFFERENCE (|#| |str|) 1))
- (COND
- ((EQL |l| 0) NIL)
- ('T (SPADLET |n| 0) (SPADLET |word| '||)
- (SPADLET |inWord| NIL)
- (DO ((|i| 0 (1+ |i|))) ((> |i| |l|) NIL)
- (declare (fixnum |i|))
- (SEQ (EXIT (COND
- ((eql (aref |str| |i|) #\space)
- (COND
- ((NULL |inWord|) NIL)
- ((eql |n| N) (RETURN |word|))
- ('T (SPADLET |inWord| NIL))))
- ('T
- (COND
- ((NULL |inWord|)
- (SPADLET |inWord| 'T)
- (SPADLET |n| (PLUS |n| 1))))
- (COND
- ((eql |n| N)
- (cond ((eq |word| '||)
- (setq |word|
- (make-array 10 :adjustable t
- :element-type 'standard-char
- :fill-pointer 0))))
- (or |word| (error "bad"))
- (vector-push-extend (aref |str| |i|)
- (the string |word|)
- )
- )
- ('T NIL)))))))
- (COND ((> N |n|) NIL) ('T |word|))))))))))
-
-(defun print-full (expr &optional (stream |$OutputStream|))
- (let ((*print-circle* t) (*print-array* t) *print-level* *print-length*)
- (print expr stream)
- (terpri stream)
- (finish-output stream)))
-
-;; stream handling for paste-in generation
-
-(defun |applyWithOutputToString| (func args)
- ;; returns the cons of applying func to args and a string produced
- ;; from standard-output while executing.
- (let* ((out-stream (make-string-output-stream))
- (curoutstream out-stream)
- (|$algebraOutputStream| out-stream)
- (|$OutputStream| out-stream)
- val)
- (declare (special curoutstream |$algebraOutputStream|))
- (setq val (catch |$SpadReaderTag|
- (catch |$intTopLevel|
- (apply (symbol-function func) args))))
- (cons val (get-output-stream-string |$OutputStream|))))
-
-(defun |breakIntoLines| (str)
- (let ((bol 0) (eol) (line-list nil))
- (loop
- (setq eol (|findChar| #\Newline str bol))
- (if (null eol) (return))
- (if (> eol bol)
- (setq line-list (cons (subseq str bol eol) line-list)))
- (setq bol (+ eol 1)))
- (|reverse!| line-list)))
-
-
-(defvar HT nil)
diff --git a/src/interp/monitor.lisp b/src/interp/monitor.lisp
index 075fd0ce..69c27f6f 100644
--- a/src/interp/monitor.lisp
+++ b/src/interp/monitor.lisp
@@ -32,7 +32,7 @@
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-(import-module "macros")
+(import-module "sys-macros")
(in-package "BOOT")
(defun monitor-help ()
diff --git a/src/interp/newaux.lisp b/src/interp/newaux.lisp
index 2d937c33..c11a6760 100644
--- a/src/interp/newaux.lisp
+++ b/src/interp/newaux.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007-2011, Gabriel Dos Reis.
+;; Copyright (C) 2007-2012, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -73,7 +73,7 @@
-(IMPORT-MODULE "macros")
+(IMPORT-MODULE "sys-macros")
(in-package "BOOT")
; ** TABLE CREATION
diff --git a/src/interp/newfort.boot b/src/interp/newfort.boot
index 858f5c77..a9176177 100644
--- a/src/interp/newfort.boot
+++ b/src/interp/newfort.boot
@@ -32,7 +32,7 @@
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
namespace BOOT
$fortranArrayStartingIndex := 0
diff --git a/src/interp/nlib.lisp b/src/interp/nlib.lisp
index 338ae9bd..e17bc448 100644
--- a/src/interp/nlib.lisp
+++ b/src/interp/nlib.lisp
@@ -32,7 +32,7 @@
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-(IMPORT-MODULE "macros")
+(IMPORT-MODULE "sys-macros")
(in-package "BOOT")
;; definition of our stream structure
diff --git a/src/interp/postpar.boot b/src/interp/postpar.boot
index 1ed5778d..391a3019 100644
--- a/src/interp/postpar.boot
+++ b/src/interp/postpar.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -32,7 +32,7 @@
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
namespace BOOT
module postpar
diff --git a/src/interp/profile.boot b/src/interp/profile.boot
index 41796931..75f2e5ab 100644
--- a/src/interp/profile.boot
+++ b/src/interp/profile.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -32,7 +32,7 @@
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
namespace BOOT
--$profileCompiler := true
diff --git a/src/interp/server.boot b/src/interp/server.boot
index bdf64e58..91bd59e3 100644
--- a/src/interp/server.boot
+++ b/src/interp/server.boot
@@ -32,7 +32,7 @@
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
namespace BOOT
-- Scratchpad-II server
diff --git a/src/interp/setvars.boot b/src/interp/setvars.boot
index f3be891c..25efcd12 100644
--- a/src/interp/setvars.boot
+++ b/src/interp/setvars.boot
@@ -53,7 +53,7 @@
-- its arguments, such as describeSetOutputFortran.
-import macros
+import sys_-macros
import debug
namespace BOOT
diff --git a/src/interp/setvart.boot b/src/interp/setvart.boot
index 57c54667..6c078b61 100644
--- a/src/interp/setvart.boot
+++ b/src/interp/setvart.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -32,7 +32,7 @@
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
namespace BOOT
--% Table of )set options
diff --git a/src/interp/sfsfun.boot b/src/interp/sfsfun.boot
index 1ccba154..d7401ef4 100644
--- a/src/interp/sfsfun.boot
+++ b/src/interp/sfsfun.boot
@@ -67,7 +67,7 @@
-import macros
+import sys_-macros
namespace BOOT
FloatError(formatstring,arg) ==
diff --git a/src/interp/simpbool.boot b/src/interp/simpbool.boot
index c14c8d5e..3432317d 100644
--- a/src/interp/simpbool.boot
+++ b/src/interp/simpbool.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -31,7 +31,7 @@
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
namespace BOOT
simpBool x == dnf2pf reduceDnf be x
diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp
index 185a4bd8..fd2cedd6 100644
--- a/src/interp/spad.lisp
+++ b/src/interp/spad.lisp
@@ -311,7 +311,7 @@
(reverse x)
(push (setq newchr (nextcharacter)) x))))
(if (EQUAL NEWCHR '\.) (RETURN (ISLOCALOP-1 IND)))
- (setq BUF (GETSTR (LENGTH SELECTOR)))
+ (setq BUF (|makeString| (LENGTH SELECTOR)))
(mapc #'(lambda (x) (suffix x buf)) selector)
(setq buf (copy-seq selector))
(setq TERMTOK (INTERN BUF))
diff --git a/src/interp/sys-macros.lisp b/src/interp/sys-macros.lisp
index ee189ac1..07eb99b2 100644
--- a/src/interp/sys-macros.lisp
+++ b/src/interp/sys-macros.lisp
@@ -97,15 +97,6 @@
;;
-;; -*- Symbols and Properties -*-
-;;
-
-(defmacro INTERNL (a &rest b)
- (if (not b)
- `(intern ,a)
- `(intern (strconc ,a . ,b))))
-
-;;
;; -*- Equality Predicates -*-
;;
diff --git a/src/interp/termrw.boot b/src/interp/termrw.boot
index 3df5ce55..ee5571e6 100644
--- a/src/interp/termrw.boot
+++ b/src/interp/termrw.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -31,7 +31,7 @@
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
namespace BOOT
termRW(t,R) ==
diff --git a/src/interp/topics.boot b/src/interp/topics.boot
index d30a5eaf..6174b0bd 100644
--- a/src/interp/topics.boot
+++ b/src/interp/topics.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -31,7 +31,7 @@
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-import macros
+import sys_-macros
namespace BOOT
$topicsDefaults := '(
diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp
index 832bb8ae..002a8812 100644
--- a/src/interp/vmlisp.lisp
+++ b/src/interp/vmlisp.lisp
@@ -490,10 +490,6 @@
(define-function 'strconc #'concat)
-(defun make-cvec (sint) (make-array sint :fill-pointer 0 :element-type 'character))
-
-(define-function 'getstr #'make-cvec)
-
; 17.2 Accessing
(defun string2id-n (cvec sint)
@@ -550,25 +546,6 @@
(defun setsize (vector size) (adjust-array vector size))
-(defun trimstring (x) x)
-
-;;-- (defun rplacstr (cvec1 start1 length1 cvec2
-;;-- &optional (start2 0) (length2 nil)
-;;-- &aux end1 end2)
-;;-- (setq cvec2 (string cvec2))
-;;-- (if (null start1) (setq start1 0))
-;;-- (if (null start2) (setq start2 0))
-;;-- (if (null length1) (setq length1 (- (length cvec1) start1)))
-;;-- (if (null length2) (setq length2 (- (length cvec2) start2)))
-;;-- (if (numberp length1) (setq end1 (+ start1 length1)))
-;;-- (if (numberp length2) (setq end2 (+ start2 length2)))
-;;-- (if (/= length1 length2)
-;;-- (concatenate 'string (subseq cvec1 0 start1)
-;;-- (subseq cvec2 start2 end2)
-;;-- (subseq cvec1 end1))
-;;-- (replace cvec1 cvec2 :start1 start1 :end1 end1
-;;-- :start2 start2 :end2 end2)))
-
; The following version has been provided to avoid reliance on the
; Common Lisp concatenate and replace functions. These built-in Lisp
; functions would probably end up doing the character-by-character
@@ -1231,3 +1208,442 @@
(defun make-adjustable-string (n)
(make-array (list n) :element-type 'character :adjustable t))
+; 6 PREDICATES
+
+; 6.3 Equality Predicates
+
+(defun COMPARE (X Y)
+ "True if X is an atom or X and Y are lists and X and Y are equal up to X."
+ (COND ((ATOM X) T)
+ ((ATOM Y) NIL)
+ ((EQUAL (CAR X) (CAR Y)) (COMPARE (CDR X) (CDR Y)))))
+
+
+(DEFUN ?ORDER (U V) "Multiple-type ordering relation."
+ (COND ((NULL U))
+ ((NULL V) NIL)
+ ((ATOM U)
+ (if (ATOM V)
+ (COND ((NUMBERP U) (if (NUMBERP V) (> V U) T))
+ ((NUMBERP V) NIL)
+ ((|ident?| U) (AND (|ident?| V) (string> (SYMBOL-NAME V) (SYMBOL-NAME U))))
+ ((|ident?| V) NIL)
+ ((STRINGP U) (AND (STRINGP V) (string> V U)))
+ ((STRINGP V) NIL)
+ ((AND (simple-vector-p U) (simple-vector-p V))
+ (AND (> (SIZE V) (SIZE U))
+ (DO ((I 0 (1+ I)))
+ ((GT I (MAXINDEX U)) 'T)
+ (COND ((NOT (EQUAL (ELT U I) (ELT V I)))
+ (RETURN (?ORDER (ELT U I) (ELT V I))))))))
+ ((croak "Do not understand")))
+ T))
+ ((ATOM V) NIL)
+ ((EQUAL U V))
+ ((NOT (string> (write-to-string U) (write-to-string V))))))
+
+; 7 CONTROL STRUCTURE
+
+; 7.8 Iteration
+
+; 7.8.2 General Iteration
+
+(defmacro |Zero| (&rest L)
+ (declare (ignore l))
+ "Needed by spadCompileOrSetq" 0)
+
+(defmacro |One| (&rest L)
+ (declare (ignore l))
+ "Needed by spadCompileOrSetq" 1)
+
+
+; 10.1 The Property List
+
+
+
+(defun PROPERTY (X IND N)
+ "Returns the Nth element of X's IND property, if it exists."
+ (let (Y) (if (AND (INTEGERP N) (SETQ Y (GET X IND)) (>= (LENGTH Y) N)) (ELEM Y N))))
+
+; 10.3 Creating Symbols
+
+
+(defvar $GENNO 0)
+
+(DEFUN GENVAR ()
+ (intern (strconc "$" (write-to-string (SETQ $GENNO (1+ $GENNO))))))
+
+(DEFUN IS_GENVAR (X)
+ (AND (|ident?| X)
+ (let ((y (symbol-name x)))
+ (and (char= #\$ (elt y 0)) (> (size y) 1) (digitp (elt y 1))))))
+
+(DEFUN IS_\#GENVAR (X)
+ (AND (|ident?| X)
+ (let ((y (symbol-name x)))
+ (and (char= #\# (ELT y 0)) (> (SIZE Y) 1) (DIGITP (ELT Y 1))))))
+
+; 10.7 CATCH and THROW
+
+; 12 NUMBERS
+
+; 12.6 Small Finite Field ops with vector trimming
+
+(defun TRIMLZ (vec)
+ (declare (simple-vector vec))
+ (let ((n (position 0 vec :from-end t :test-not #'eql)))
+ (cond ((null n) (vector))
+ ((eql n (|maxIndex| vec)) vec)
+ (t (subseq vec 0 (+ n 1))))))
+
+; 14 SEQUENCES
+
+; 14.1 Simple Sequence Functions
+
+(defun GETCHARN (A M) "Return the code of the Mth character of A"
+ (let ((a (if (|ident?| a) (symbol-name a) a))) (char-code (elt A M))))
+
+; 14.2 Concatenating, Mapping, and Reducing Sequences
+
+(DEFUN STRINGPAD (STR N)
+ (let ((M (length STR)))
+ (if (>= M N)
+ STR
+ (concatenate 'string str (make-string (- N M) :initial-element #\Space)))))
+
+(DEFUN STRINGSUFFIX (TARGET SOURCE) "Suffix source to target if enough room else nil."
+ (concatenate 'string target source))
+
+(defun THETACHECK (VAL VAR OP) (if (EQL VAL VAR) (THETA_ERROR OP) val))
+
+; 15 LISTS
+
+; 15.2 Lists
+
+
+(defmacro TL (&rest L) `(tail . ,L))
+
+(DEFUN LASTELEM (X) (car (|lastNode| X)))
+
+(defun LISTOFATOMS (X)
+ (COND ((NULL X) NIL)
+ ((ATOM X) (LIST X))
+ ((|append!| (LISTOFATOMS (CAR X)) (LISTOFATOMS (CDR X))))))
+
+(DEFUN LASTATOM (L) (if (ATOM L) L (LASTATOM (CDR L))))
+
+(DEFUN NUMOFNODES (X) (if (ATOM X) 0 (+ 1 (NUMOFNODES (CAR X)) (NUMOFNODES (CDR X)))))
+
+(DEFUN TRUNCLIST (L TL) "Truncate list L at the point marked by TL."
+ (let ((U L)) (TRUNCLIST-1 L TL) U))
+
+(DEFUN TRUNCLIST-1 (L TL)
+ (COND ((ATOM L) L)
+ ((EQL (CDR L) TL) (RPLACD L NIL))
+ ((TRUNCLIST-1 (CDR L) TL))))
+
+; 15.5 Using Lists as Sets
+
+(DEFUN PREDECESSOR (TL L)
+ "Returns the sublist of L whose CDR is EQ to TL."
+ (COND ((ATOM L) NIL)
+ ((EQ TL (CDR L)) L)
+ ((PREDECESSOR TL (CDR L)))))
+
+(defun remdup (l) (remove-duplicates l :test #'equalp))
+
+; 15.6 Association Lists
+
+;;; Operations on Association Sets (AS)
+
+(defun AS-INSERT (A B L)
+ ;; PF(item) x PF(item) x LIST(of pairs) -> LIST(of pairs with (A . B) added)
+ ;; destructive on L; if (A . C) appears already, C is replaced by B
+ (cond ((null l) (list (cons a b)))
+ ((equal a (caar l)) (rplacd (car l) b) l)
+ ((?order a (caar l)) (cons (cons a b) l))
+ (t (as-insert1 a b l) l)))
+
+(defun as-insert1 (a b l)
+ (cond ((null (cdr l)) (rplacd l (list (cons a b))))
+ ((equal a (caadr l)) (rplacd (cadr l) b))
+ ((?order a (caadr l)) (rplacd l (cons (cons a b) (cdr l))))
+ (t (as-insert1 a b (cdr l)))))
+
+
+; 17 ARRAYS
+
+; 17.6 Changing the Dimensions of an Array
+
+
+(defun lengthenvec (v n)
+ (if
+ (and (array-has-fill-pointer-p v) (adjustable-array-p v))
+ (if
+ (>= n (array-total-size v))
+ (adjust-array v (* n 2) :fill-pointer n)
+ (progn
+ (setf (fill-pointer v) n)
+ v))
+ (replace (make-array n :fill-pointer t) v)))
+
+(defun make-init-vector (n val)
+ (make-array n :initial-element val :fill-pointer t))
+
+
+; 22 INPUT/OUTPUT
+
+; 22.2 Input Functions
+
+; 22.2.1 Input from Character Streams
+
+(DEFUN STREAM-EOF (&optional (STRM |$InputStream|))
+ "T if input stream STRM is at the end or saw a ~."
+ (not (peek-char nil STRM nil nil nil)) )
+
+(DEFUN CONSOLEINPUTP (STRM) (|ioTerminal?| STRM))
+
+(defvar $filelinenumber 0)
+(defvar $prompt "--->")
+(defvar stream-buffer nil)
+
+(DEFUN NEXTSTRMLINE (STRM) "Returns the next input line from stream STRM."
+ (let ((v (read-line strm nil -1 nil)))
+ (if (equal v -1) (throw 'spad_reader nil)
+ (progn (setq stream-buffer v) v))))
+
+(DEFUN CURSTRMLINE (STRM)
+ "Returns the current input line from the stream buffer of STRM (VM-specific!)."
+ (cond (stream-buffer)
+ ((stream-eof strm) (fail))
+ ((nextstrmline strm))))
+
+(defvar *EOF* NIL)
+
+(DEFUN CURMAXINDEX (STRM)
+"Something bizarre and VM-specific with respect to streams."
+ (if *EOF* (FAIL) (ELT (ELT (LASTATOM STRM) 1) 3)))
+
+(DEFUN ADJCURMAXINDEX (STRM)
+"Something unearthly and VM-specific with respect to streams."
+ (let (v) (if *eof* (fail)
+ (progn (SETQ V (ELT (LASTATOM STRM) 1))
+ (SETF (ELT V 3) (SIZE (ELT V 0)))))))
+
+(DEFUN STRMBLANKLINE (STRM)
+"Something diabolical and VM-specific with respect to streams."
+ (if *EOF* (FAIL) (AND (EQ '\ (CAR STRM)) (EQL 1 (CURMAXINDEX STRM)))))
+
+(DEFUN STRMSKIPTOBLANK (STRM)
+"Munch away on the stream until you get to a blank line."
+ (COND (*EOF* (FAIL))
+ ((PROGN (NEXTSTRMLINE STRM) (STRMBLANKLINE STRM)) STRM)
+ ((STRMSKIPTOBLANK STRM))))
+
+(DEFUN CURINPUTLINE () (CURSTRMLINE |$InputStream|))
+
+(DEFUN NEXTINPUTLINE () (NEXTSTRMLINE |$InputStream|))
+
+; 22.3 Output Functions
+
+; 22.3.1 Output to Character Streams
+
+(DEFUN ATOM2STRING (X)
+ "Give me the string which would be printed out to denote an atom."
+ (cond ((atom x) (symbol-name x))
+ ((stringp x) x)
+ ((write-to-string x))))
+
+;; the following are redefined in MSGDB BOOT
+
+(DEFUN BLANKS (N &optional (stream |$OutputStream|))
+ "Print N blanks."
+ (declare (fixnum N))
+ (do ((i 1 (the fixnum(1+ i))))
+ ((> i N))
+ (declare (fixnum i))
+ (princ " " stream)))
+
+; 23 FILE SYSTEM INTERFACE
+
+; 23.2 Opening and Closing Files
+
+(DEFUN DEFSTREAM (file MODE)
+ (if (member mode '(i input))
+ (MAKE-INSTREAM file)
+ (MAKE-OUTSTREAM file)))
+
+; 23.3 Renaming, Deleting and Other File Operations
+
+(DEFUN NOTE (STRM)
+"Attempts to return the current record number of a file stream. This is 0 for
+terminals and empty or at-end files. In Common Lisp, we must assume record sizes of 1!"
+ (COND ((STREAM-EOF STRM) 0)
+ ((|ioTerminal?| STRM) 0)
+ ((file-position STRM))))
+
+(DEFUN |ioTerminal?|-NOT-XEDIT (S) (not (OR (NULL (|ioTerminal?| S)))))
+
+(DEFUN POINTW (RECNO STRM)
+"Does something obscure and VM-specific with respect to streams."
+ (let (V)
+ (if (STREAM-EOF STRM) (FAIL))
+ (SETQ V (LASTATOM STRM))
+ (SETF (ELT V 4) RECNO)
+ (SETQ *EOF* (STREAM-EOF STRM))
+ strm))
+
+(DEFUN POINT (RECNO STRM) (file-position strm recno))
+
+(DEFUN STRM (RECNO STRM)
+"Does something obscure and VM-specific with respect to streams."
+ (let (V)
+ (if (STREAM-EOF STRM) (FAIL))
+ (SETQ V (LASTATOM STRM))
+ (SETF (ELT V 4) RECNO)
+ (read-char STRM)
+ (SETQ *EOF* (STREAM-EOF STRM))
+ strm))
+
+; 25 MISCELLANEOUS FEATURES
+
+;; range tests and assertions
+
+(defmacro |elapsedUserTime| () '(get-internal-run-time))
+
+#+IBCL
+(defmacro |elapsedGcTime| () '(system:gbc-time-report))
+
+#+AKCL
+(defmacro |elapsedGcTime| () '(system:gbc-time))
+
+#-(OR IBCL AKCL)
+(defmacro |elapsedGcTime| () '0)
+
+; This function was modified by Greg Vanuxem on March 31, 2005
+; to handle the special case of #'(lambda ..... which expands
+; into (function (lambda .....
+;
+; The extra if clause fixes bugs #196 and #114
+;
+; an example that used to cause the failure was:
+; )set func comp off
+; f(xl:LIST FRAC INT): LIST FRAC INT == map(x +-> x, xl)
+; f [1,2,3]
+;
+; which expanded into
+;
+; (defun |xl;f;1;initial| (|#1| |envArg|)
+; (prog (#:G1420)
+; (return
+; (progn
+; (lett #:G1420 'uninitialized_variable |f| |#1;f;1:initial|)
+; (spadcall
+; (cons (|function| (lambda (#:G1420 |envArg|) #:G1420)) (vector))
+; |#1|
+; (svref |*1;f;1;initial;MV| 0))))))
+;
+; the (|function| (lambda form used to cause an infinite expansion loop
+;
+(defun macroexpandall (sexpr)
+ (cond
+ ((atom sexpr) sexpr)
+ ((eq (car sexpr) 'quote) sexpr)
+ ((eq (car sexpr) 'defun)
+ (cons (car sexpr) (cons (cadr sexpr)
+ (mapcar #'macroexpandall (cddr sexpr)))))
+ ((and (symbolp (car sexpr)) (macro-function (car sexpr)))
+ (do ()
+ ((not (and (consp sexpr) (symbolp (car sexpr))
+ (macro-function (car sexpr)))))
+ (setq sexpr (macroexpand sexpr)))
+ (if (consp sexpr)
+ (let ((a (car sexpr)) (b (caadr sexpr)))
+ (if (and (eq a 'function) (eq b 'lambda))
+ (cons a (list (cons b (mapcar #'macroexpandall (cdadr sexpr)))))
+ (mapcar #'macroexpandall sexpr)))
+ sexpr))
+ ('else
+ (mapcar #'macroexpandall sexpr))))
+
+
+(defun |deleteWOC| (item list) (delete item list :test #'equal))
+
+;;---- Added by WFS.
+
+(proclaim '(ftype (function (t t) t) |subWord|)) ;hack for bug in akcl-478
+
+(DEFUN |subWord| (|str| N )
+ (declare (fixnum n ) (string |str|))
+ (PROG (|word| (|n| 0) |inWord|(|l| 0) )
+ (declare (fixnum |n| |l|))
+ (RETURN
+ (SEQ (COND
+ ((> 1 N) NIL)
+ ('T (SPADLET |l| (SPADDIFFERENCE (|#| |str|) 1))
+ (COND
+ ((EQL |l| 0) NIL)
+ ('T (SPADLET |n| 0) (SPADLET |word| '||)
+ (SPADLET |inWord| NIL)
+ (DO ((|i| 0 (1+ |i|))) ((> |i| |l|) NIL)
+ (declare (fixnum |i|))
+ (SEQ (EXIT (COND
+ ((eql (aref |str| |i|) #\space)
+ (COND
+ ((NULL |inWord|) NIL)
+ ((eql |n| N) (RETURN |word|))
+ ('T (SPADLET |inWord| NIL))))
+ ('T
+ (COND
+ ((NULL |inWord|)
+ (SPADLET |inWord| 'T)
+ (SPADLET |n| (PLUS |n| 1))))
+ (COND
+ ((eql |n| N)
+ (cond ((eq |word| '||)
+ (setq |word|
+ (make-array 10 :adjustable t
+ :element-type 'standard-char
+ :fill-pointer 0))))
+ (or |word| (error "bad"))
+ (vector-push-extend (aref |str| |i|)
+ (the string |word|)
+ )
+ )
+ ('T NIL)))))))
+ (COND ((> N |n|) NIL) ('T |word|))))))))))
+
+(defun print-full (expr &optional (stream |$OutputStream|))
+ (let ((*print-circle* t) (*print-array* t) *print-level* *print-length*)
+ (print expr stream)
+ (terpri stream)
+ (finish-output stream)))
+
+;; stream handling for paste-in generation
+
+(defun |applyWithOutputToString| (func args)
+ ;; returns the cons of applying func to args and a string produced
+ ;; from standard-output while executing.
+ (let* ((out-stream (make-string-output-stream))
+ (curoutstream out-stream)
+ (|$algebraOutputStream| out-stream)
+ (|$OutputStream| out-stream)
+ val)
+ (declare (special curoutstream |$algebraOutputStream|))
+ (setq val (catch |$SpadReaderTag|
+ (catch |$intTopLevel|
+ (apply (symbol-function func) args))))
+ (cons val (get-output-stream-string |$OutputStream|))))
+
+(defun |breakIntoLines| (str)
+ (let ((bol 0) (eol) (line-list nil))
+ (loop
+ (setq eol (|findChar| #\Newline str bol))
+ (if (null eol) (return))
+ (if (> eol bol)
+ (setq line-list (cons (subseq str bol eol) line-list)))
+ (setq bol (+ eol 1)))
+ (|reverse!| line-list)))
+
+
+(defvar HT nil)
diff --git a/src/interp/word.boot b/src/interp/word.boot
index 8387a2ab..3f3debd4 100644
--- a/src/interp/word.boot
+++ b/src/interp/word.boot
@@ -373,7 +373,7 @@ hasWildCard? str ==
maskConvert str ==
--replace all ? not preceded by an underscore by &
- buf:= GETSTR(#str)
+ buf:= makeString #str
j:= 0 --index into res
final := maxIndex str
for i in 0..final repeat
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-24 16:57:58 +0000