aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog16
-rw-r--r--src/interp/Makefile.in9
-rw-r--r--src/interp/Makefile.pamphlet9
-rw-r--r--src/interp/g-util.boot1
-rw-r--r--src/interp/macros.lisp125
-rw-r--r--src/interp/sys-utility.boot117
6 files changed, 149 insertions, 128 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 41398bd2..2e2ba3e9 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,19 @@
+2008-02-04 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * interp/Makefile.pamphlet (OBJS): Include sys-utility.$(FASLEXT).
+ (sys-utility.$(FASLEXT)): New rule.
+ * interp/sys-utility.boot: New.
+ * interp/macros.lisp (|functionp|): Move to sys-utility.boot.
+ (|macrop|): Likewise.
+ (|delete|): Likewise.
+ (CONTAINED, contained\,eq, contained\,equal): Likewise.
+ (ASSOCLEFT): Likewise.
+ (ASSOCRIGHT): Likewise.
+ (ADDASSOC): Likewise.
+ (DELLASOS): Likewise.
+ (LASSOC): Likewise.
+ (|rassoc|): Likewise.
+
2008-02-03 Gabriel Dos Reis <gdr@cs.tamu.edu>
* interp/foam_l.lisp (|G-stdoutVar|): Define; don't just assign.
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index a97c829d..2f372312 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -20,7 +20,7 @@ AXIOMSYS= $(axiom_target_bindir)/AXIOMsys$(EXEEXT)
OBJS= vmlisp.$(FASLEXT) hash.$(FASLEXT) \
diagnostics.$(FASLEXT) sys-driver.$(FASLEXT) \
- macros.$(FASLEXT) \
+ sys-utility.$(FASLEXT) macros.$(FASLEXT) \
unlisp.$(FASLEXT) \
astr.$(FASLEXT) bits.$(FASLEXT) \
alql.$(FASLEXT) buildom.$(FASLEXT) \
@@ -551,7 +551,7 @@ metalex.$(FASLEXT): metalex.lisp macros.$(FASLEXT)
nlib.$(FASLEXT): nlib.lisp macros.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-macros.$(FASLEXT): macros.lisp sys-macros.$(FASLEXT)
+macros.$(FASLEXT): macros.lisp sys-macros.$(FASLEXT) sys-utility.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
## The new parser component roughtly is:
@@ -701,7 +701,7 @@ pspad2.$(FASLEXT): pspad2.boot pspad1.$(FASLEXT)
pspad1.$(FASLEXT): pspad1.boot macros.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-g-util.$(FASLEXT): g-util.boot macros.$(FASLEXT)
+g-util.$(FASLEXT): g-util.boot macros.$(FASLEXT) sys-utility.$(FASLEXT)
$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
g-cndata.$(FASLEXT): g-cndata.boot sys-macros.$(FASLEXT)
@@ -758,6 +758,9 @@ axext_l.$(FASLEXT): axext_l.lisp foam_l.$(FASLEXT)
foam_l.$(FASLEXT): foam_l.lisp vmlisp.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+sys-utility.$(FASLEXT): sys-utility.boot vmlisp.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
vmlisp.$(FASLEXT): vmlisp.lisp boot-pkg.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index b5a644e3..e4385f67 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -111,7 +111,7 @@ compiled.
<<environment>>=
OBJS= vmlisp.$(FASLEXT) hash.$(FASLEXT) \
diagnostics.$(FASLEXT) sys-driver.$(FASLEXT) \
- macros.$(FASLEXT) \
+ sys-utility.$(FASLEXT) macros.$(FASLEXT) \
unlisp.$(FASLEXT) \
astr.$(FASLEXT) bits.$(FASLEXT) \
alql.$(FASLEXT) buildom.$(FASLEXT) \
@@ -874,7 +874,7 @@ metalex.$(FASLEXT): metalex.lisp macros.$(FASLEXT)
nlib.$(FASLEXT): nlib.lisp macros.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-macros.$(FASLEXT): macros.lisp sys-macros.$(FASLEXT)
+macros.$(FASLEXT): macros.lisp sys-macros.$(FASLEXT) sys-utility.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
## The new parser component roughtly is:
@@ -1024,7 +1024,7 @@ pspad2.$(FASLEXT): pspad2.boot pspad1.$(FASLEXT)
pspad1.$(FASLEXT): pspad1.boot macros.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
-g-util.$(FASLEXT): g-util.boot macros.$(FASLEXT)
+g-util.$(FASLEXT): g-util.boot macros.$(FASLEXT) sys-utility.$(FASLEXT)
$(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $<
g-cndata.$(FASLEXT): g-cndata.boot sys-macros.$(FASLEXT)
@@ -1081,6 +1081,9 @@ axext_l.$(FASLEXT): axext_l.lisp foam_l.$(FASLEXT)
foam_l.$(FASLEXT): foam_l.lisp vmlisp.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+sys-utility.$(FASLEXT): sys-utility.boot vmlisp.$(FASLEXT)
+ $(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
+
vmlisp.$(FASLEXT): vmlisp.lisp boot-pkg.$(FASLEXT)
$(BOOTSYS) -- --compile --output=$@ --load-directory=. $<
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index 5d62e098..ca50a4e5 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -33,6 +33,7 @@
import '"macros"
+import '"sys-utility"
)package "BOOT"
++
diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp
index 775f76cc..b4e7ab75 100644
--- a/src/interp/macros.lisp
+++ b/src/interp/macros.lisp
@@ -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-2008, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -54,6 +54,7 @@
(import-module "sys-macros")
+(import-module "sys-utility")
(in-package "BOOT")
; 5 PROGRAM STRUCTURE
@@ -62,16 +63,8 @@
(defun SETANDFILE (x y) (LAM\,EVALANDFILEACTQ `(defparameter ,x ',y)))
-; 5.3.2 Declaring Global Variables and Named Constants
-
-(defun |functionp| (fn)
- (if (identp fn) (and (fboundp fn) (not (macro-function fn))) (functionp fn)))
-(defun |macrop| (fn) (and (identp fn) (macro-function fn)))
-
; 6 PREDICATES
-; 6.2 Data Type Predicates
-
; 6.3 Equality Predicates
(defun COMPARE (X Y)
@@ -106,14 +99,6 @@
; 7 CONTROL STRUCTURE
-; 7.1 Constants and Variables
-
-; 7.1.1 Reference
-
-; 7.2 Generalized Variables
-
-; 7.3 Function Invocation
-
; 7.8 Iteration
; 7.8.2 General Iteration
@@ -127,12 +112,6 @@
"Needed by spadCompileOrSetq" 1)
-; 7.8.4 Mapping
-
-
-
-; 7.10 Dynamic Non-local Exits
-
; 10.1 The Property List
@@ -161,15 +140,7 @@
; 10.7 CATCH and THROW
; 12 NUMBERS
-
-; 12.3 Comparisons on Numbers
-
-; 12.4 Arithmetic Operations
-
-; 12.5 Irrational and Transcendental Functions
-
-; 12.5.1 Exponential and Logarithmic Functions
-
+
; 12.6 Small Finite Field ops with vector trimming
(defun TRIMLZ (vec)
@@ -208,28 +179,11 @@
(define-function '|append| #'APPEND)
-;;(defun |delete| (item list) ; renaming from DELETE is done in DEF
-;; (cond ((atom list) list)
-;; ((equalp item (qcar list)) (|delete| item (qcdr list)))
-;; ('t (cons (qcar list) (|delete| item (qcdr list))))))
-
-(defun |delete| (item sequence)
- (cond ((symbolp item) (remove item sequence :test #'eq))
- ((and (atom item) (not (arrayp item))) (remove item sequence))
- (T (remove item sequence :test #'equalp))))
-
-
-
-
-
(defun THETACHECK (VAL VAR OP) (if (EQL VAL VAR) (THETA_ERROR OP) val))
; 15 LISTS
-; 15.1 Conses
-
-
; 15.2 Lists
@@ -314,22 +268,6 @@
; 15.5 Using Lists as Sets
-#-:CCL
-(DEFUN CONTAINED (X Y)
- (if (symbolp x)
- (contained\,eq X Y)
- (contained\,equal X Y)))
-
-(defun contained\,eq (x y)
- (if (atom y) (eq x y)
- (or (contained\,eq x (car y)) (contained\,eq x (cdr y)))))
-
-(defun contained\,equal (x y)
- (cond ((atom y) (equal x y))
- ((equal x y) 't)
- ('t (or (contained\,equal x (car y)) (contained\,equal x (cdr y))))))
-
-
(DEFUN PREDECESSOR (TL L)
"Returns the sublist of L whose CDR is EQ to TL."
(COND ((ATOM L) NIL)
@@ -342,63 +280,6 @@
; 15.6 Association Lists
-
-;; FIXME: Should not this be named `alistAllKeys'?
-(DEFUN ASSOCLEFT (X)
- "Returns all the keys of association list X."
- (if (ATOM X)
- X
- (mapcar #'car x)))
-
-;; FIXME: Should not this be named `alistAllValues'?
-(DEFUN ASSOCRIGHT (X)
- "Returns all the datums of association list X."
- (if (ATOM X)
- X
- (mapcar #'cdr x)))
-
-
-(DEFUN ADDASSOC (X Y L)
- "Put the association list pair (X . Y) into L, erasing any previous association for X"
- (COND ((ATOM L)
- (CONS (CONS X Y) L))
- ((EQUAL X (CAAR L))
- (CONS (CONS X Y) (CDR L)))
- ((CONS (CAR L) (ADDASSOC X Y (CDR L))))))
-
-(DEFUN DELLASOS (U V)
- "Remove any assocation pair (U . X) from list V."
- (COND ((ATOM V) NIL)
- ((EQUAL U (CAAR V))
- (CDR V))
- ((CONS (CAR V) (DELLASOS U (CDR V))))))
-
-
-;; FIXME: Should not this be named `alistValue'?
-(DEFUN LASSOC (X Y)
- "Return the datum associated with key X in association list Y."
- (PROG NIL
- A
- (COND ((ATOM Y)
- (RETURN NIL))
- ((EQUAL (CAAR Y) X)
- (RETURN (CDAR Y))) )
- (SETQ Y (CDR Y))
- (GO A)))
-
-;; FIXME: Should not this be named `alistKey'?
-(DEFUN |rassoc| (X Y)
- "Return the key associated with datum X in association list Y."
- (PROG NIL
- A
- (COND ((ATOM Y)
- (RETURN NIL))
- ((EQUAL (CDAR Y) X)
- (RETURN (CAAR Y))) )
- (SETQ Y (CDR Y))
- (GO A)))
-
-; (defun QLASSQ (p a-list) (let ((y (assoc p a-list :test #'eq))) (if y (cdr y))))
(defun QLASSQ (p a-list) (cdr (assq p a-list)))
(define-function 'LASSQ #'QLASSQ)
diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot
new file mode 100644
index 00000000..727721f0
--- /dev/null
+++ b/src/interp/sys-utility.boot
@@ -0,0 +1,117 @@
+-- Copyright (C) 2007-2008 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.
+--
+
+-- This file defines some utility functions common to both the compiler
+-- and interpreter.
+
+import '"vmlisp"
+)package "BOOT"
+
+++ returns true if `f' is bound to a macro.
+macrop: %Thing -> %Boolean
+macrop f ==
+ IDENTP f and MACRO_-FUNCTION f
+
+++ returns true if `f' is bound to a function
+functionp: %Thing -> %Boolean
+functionp f ==
+ IDENTP f => FBOUNDP f and not MACRO_-FUNCTION f
+ FUNCTIONP f
+
+++ remove `item' from `sequence'.
+delete: (%Thing,%Sequence) -> %Sequence
+delete(item,sequence) ==
+ SYMBOLP item =>
+ REMOVE(item,sequence,KEYWORD::TEST,function EQ)
+ atom item and not ARRAYP item =>
+ REMOVE(item,SEQUENCE)
+ REMOVE(item,sequence,KEYWORD::TEST,function EQUALP)
+
+++ returns true if `x' is contained in `y'.
+CONTAINED: (%Thing,%Thing) -> %Boolean
+CONTAINED(x,y) == main where
+ main() ==
+ SYMBOLP x => eq(x,y)
+ equal(x,y)
+ eq(x,y) ==
+ atom y => EQ(x,y)
+ eq(x, car y) or eq(x, cdr y)
+ equal(x,y) ==
+ atom y => EQUAL(x,y)
+ equal(x, car y) or equal(x, cdr y)
+
+++ Returns all the keys of association list `x'
+-- ??? Should not this be named `alistAllKeys'?
+ASSOCLEFT: %Thing -> %Thing
+ASSOCLEFT x ==
+ atom x => x
+ MAPCAR(function first,x)
+
+++ Returns all the datums of association list `x'.
+-- ??? Should not this be named `alistAllValues'?
+ASSOCRIGHT: %Thing -> %Thing
+ASSOCRIGHT x ==
+ atom x => x
+ MAPCAR(function rest,x)
+
+++ Put the association list pair `(x . y)' into `l', erasing any
+++ previous association for `x'.
+ADDASSOC: (%Thing,%Thing,%List) -> %List
+ADDASSOC(x,y,l) ==
+ atom l => [[x,:y],:l]
+ x = first first l => [[x,:y],:cdr l]
+ [first l,:ADDASSOC(x,y,rest l)]
+
+
+++ Remove any assocation pair `(u . x)' from list `v'.
+DELLASOS: (%Thing,%List) -> %List
+DELLASOS(u,v) ==
+ atom v => nil
+ u = first first v => rest v
+ [first v,:DELLASOS(u,rest v)]
+
+
+++ Return the datum associated with key `x' in association list `y'.
+-- ??? Should not this be named `alistValue'?
+LASSOC: (%Thing,%List) -> %Thing
+LASSOC(x,y) ==
+ atom y => nil
+ x = first first y => rest first y
+ LASSOC(x,rest y)
+
+++ Return the key associated with datum `x' in association list `y'.
+rassoc: (%Thing,%List) -> %Thing
+rassoc(x,y) ==
+ atom y => nil
+ x = rest first y => first first y
+ rassoc(x,rest y)
+