diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/Makefile.in | 9 | ||||
| -rw-r--r-- | src/interp/Makefile.pamphlet | 9 | ||||
| -rw-r--r-- | src/interp/g-util.boot | 1 | ||||
| -rw-r--r-- | src/interp/macros.lisp | 125 | ||||
| -rw-r--r-- | src/interp/sys-utility.boot | 117 |
5 files changed, 133 insertions, 128 deletions
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) + |