diff options
Diffstat (limited to 'src/interp/sys-utility.boot')
| -rw-r--r-- | src/interp/sys-utility.boot | 117 |
1 files changed, 117 insertions, 0 deletions
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) + |