aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/ChangeLog9
-rw-r--r--src/boot/ast.boot12
-rw-r--r--src/boot/parser.boot6
-rw-r--r--src/boot/strap/ast.clisp46
-rw-r--r--src/boot/strap/parser.clisp2
-rw-r--r--src/boot/strap/translator.clisp20
-rw-r--r--src/boot/strap/utility.clisp50
-rw-r--r--src/boot/translator.boot8
-rw-r--r--src/boot/utility.boot19
-rw-r--r--src/interp/c-util.boot6
-rw-r--r--src/interp/functor.boot2
-rw-r--r--src/interp/lisplib.boot2
12 files changed, 148 insertions, 34 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 70f23a99..143fe6af 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,14 @@
2011-12-10 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * boot/parser.boot (bpArgtypeList): Accept mapping types.
+ * boot/ast.boot (bfType): New.
+ * boot/translator.boot (genDeclaration): Use it.
+ * boot/utility.boot (every?): New. Export.
+ (any?): Likewise.
+ (takeWhile): Lilkewise.
+
+2011-12-10 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* interp/g-opt.boot (mkDefault): New.
(coagulateWhenSeries): Likewise.
(packWhen!): Likewise. Use them.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index be52533d..4a476189 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1344,6 +1344,18 @@ bfThrow e ==
["THROW",KEYWORD::OPEN_-AXIOM_-CATCH_-POINT,
["CONS",KEYWORD::OPEN_-AXIOM_-CATCH_-POINT,["CONS",t,x]]]
+--%
+
+bfType x ==
+ x is ['%Mapping,t,s] =>
+ if bfTupleP s then
+ s := s.args
+ if ident? s then
+ s := [s]
+ ['FUNCTION,[bfType y for y in s],bfType t]
+ x is [.,:.] => [x.op,:[bfType y for y in x.args]]
+ x
+
--% Type alias definition
backquote: (%Form,%List %Symbol) -> %Form
diff --git a/src/boot/parser.boot b/src/boot/parser.boot
index f9ae96dc..dde2bd3e 100644
--- a/src/boot/parser.boot
+++ b/src/boot/parser.boot
@@ -507,10 +507,10 @@ bpSimpleMapping() ==
++ ArgtypeList:
++ ( ArgtypeSequence )
++ ArgtypeSequence:
-++ Application
-++ Application , ArgtypeSequence
+++ SimpleMapping
+++ SimpleMapping , ArgtypeSequence
bpArgtypeList() ==
- bpTuple function bpApplication
+ bpTuple function bpSimpleMapping
++ Parse a mapping expression
++ Mapping:
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index f074ad0b..3bf3ce53 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -2392,6 +2392,52 @@
(LIST 'THROW :OPEN-AXIOM-CATCH-POINT
(LIST 'CONS :OPEN-AXIOM-CATCH-POINT (LIST 'CONS |t| |x|)))))))
+(DEFUN |bfType| (|x|)
+ (PROG (|s| |ISTMP#2| |t| |ISTMP#1|)
+ (RETURN
+ (COND
+ ((AND (CONSP |x|) (EQ (CAR |x|) '|%Mapping|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |t| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |s| (CAR |ISTMP#2|)) T))))))
+ (COND ((|bfTupleP| |s|) (SETQ |s| (CDR |s|))))
+ (COND ((|ident?| |s|) (SETQ |s| (LIST |s|))))
+ (LIST 'FUNCTION
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|y| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2| #1=(CONS (|bfType| |y|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (|bfType| |t|)))
+ ((CONSP |x|)
+ (CONS (CAR |x|)
+ (LET ((|bfVar#5| NIL)
+ (|bfVar#6| NIL)
+ (|bfVar#4| (CDR |x|))
+ (|y| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#4|))
+ (PROGN (SETQ |y| (CAR |bfVar#4|)) NIL))
+ (RETURN |bfVar#5|))
+ ((NULL |bfVar#5|)
+ (SETQ |bfVar#5| #2=(CONS (|bfType| |y|) NIL))
+ (SETQ |bfVar#6| |bfVar#5|))
+ (T (RPLACD |bfVar#6| #2#) (SETQ |bfVar#6| (CDR |bfVar#6|))))
+ (SETQ |bfVar#4| (CDR |bfVar#4|))))))
+ (T |x|)))))
+
(DECLAIM (FTYPE (FUNCTION (|%Form| (|%List| |%Symbol|)) |%Form|) |backquote|))
(DEFUN |backquote| (|form| |params|)
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index a91db6cc..f6799dbf 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -494,7 +494,7 @@
T)
(T NIL)))
-(DEFUN |bpArgtypeList| () (|bpTuple| #'|bpApplication|))
+(DEFUN |bpArgtypeList| () (|bpTuple| #'|bpSimpleMapping|))
(DEFUN |bpMapping| ()
(AND (|bpParenthesized| #'|bpArgtypeList|) (|bpEqKey| 'ARROW)
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 9abbe2ca..4294b1ba 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -484,23 +484,11 @@
((NULL |$stack|) (|bpGeneralErrorHere|) NIL) (T (CAR |$stack|)))))))
(DEFUN |genDeclaration| (|n| |t|)
- (PROG (|t'| |vars| |argTypes| |ISTMP#2| |valType| |ISTMP#1|)
+ (PROG (|t'| |ISTMP#2| |vars| |ISTMP#1|)
(RETURN
(COND
- ((AND (CONSP |t|) (EQ (CAR |t|) '|%Mapping|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |t|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |valType| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |argTypes| (CAR |ISTMP#2|)) T))))))
- (COND ((|bfTupleP| |argTypes|) (SETQ |argTypes| (CDR |argTypes|))))
- (COND
- ((AND |argTypes| (SYMBOLP |argTypes|))
- (SETQ |argTypes| (LIST |argTypes|))))
- (LIST 'DECLAIM (LIST 'FTYPE (LIST 'FUNCTION |argTypes| |valType|) |n|)))
+ ((AND (CONSP |t|) (EQ (CAR |t|) '|%Mapping|))
+ (LIST 'DECLAIM (LIST 'FTYPE (|bfType| |t|) |n|)))
((AND (CONSP |t|) (EQ (CAR |t|) '|%Forall|)
(PROGN
(SETQ |ISTMP#1| (CDR |t|))
@@ -533,7 +521,7 @@
(SETQ |bfVar#3| (CDR |bfVar#3|))))
(SETQ |bfVar#1| (CDR |bfVar#1|))))
|t'|)))))
- (T (LIST 'DECLAIM (LIST 'TYPE |t| |n|)))))))
+ (T (LIST 'DECLAIM (LIST 'TYPE (|bfType| |t|) |n|)))))))
(DEFUN |translateSignatureDeclaration| (|d|)
(CASE (CAR |d|)
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index 457ea66e..73e14218 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -20,8 +20,8 @@
|lastNode| |append| |append!| |copyList| |substitute|
|substitute!| |setDifference| |setUnion| |setIntersection|
|symbolAssoc| |applySubst| |applySubst!| |applySubstNQ|
- |objectAssoc| |remove| |removeSymbol| |atomic?| |copyTree|
- |finishLine|)))
+ |objectAssoc| |remove| |removeSymbol| |atomic?| |every?|
+ |any?| |takeWhile| |copyTree| |finishLine|)))
(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|))
@@ -74,6 +74,20 @@
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Boolean|) |atomic?|))
+(DECLAIM
+ (FTYPE (FUNCTION ((FUNCTION (|%Thing|) |%Thing|) (|%List| |%Thing|)) |%Thing|)
+ |every?|))
+
+(DECLAIM
+ (FTYPE (FUNCTION ((FUNCTION (|%Thing|) |%Thing|) (|%List| |%Thing|)) |%Thing|)
+ |any?|))
+
+(DECLAIM
+ (FTYPE
+ (FUNCTION ((FUNCTION (|%Thing|) |%Thing|) (|%List| |%Thing|))
+ (|%List| |%Thing|))
+ |takeWhile|))
+
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |copyTree|))
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Void|) |finishLine|))
@@ -86,6 +100,38 @@
(DEFUN |atomic?| (|x|) (OR (NOT (CONSP |x|)) (EQ (CAR |x|) 'QUOTE)))
+(DEFUN |every?| (|f| |l|)
+ (LET ((|bfVar#2| T) (|bfVar#1| |l|) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T (SETQ |bfVar#2| (APPLY |f| |x| NIL))
+ (COND ((NOT |bfVar#2|) (RETURN NIL)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
+(DEFUN |any?| (|f| |l|)
+ (LET ((|bfVar#2| NIL) (|bfVar#1| |l|) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T (SETQ |bfVar#2| (APPLY |f| |x| NIL))
+ (COND (|bfVar#2| (RETURN |bfVar#2|)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
+(DEFUN |takeWhile| (|f| |l|)
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)
+ (NOT (APPLY |f| |x| NIL)))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS |x| NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
(DEFUN |copyTree| (|t|)
(COND ((CONSP |t|) (CONS (|copyTree| (CAR |t|)) (|copyTree| (CDR |t|))))
(T |t|)))
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index 7179d8fa..a58f55eb 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -380,17 +380,13 @@ shoeOutParse stream ==
++ Generate a global signature declaration for symbol `n'.
genDeclaration(n,t) ==
- t is ["%Mapping",valType,argTypes] =>
- if bfTupleP argTypes then argTypes := rest argTypes
- if argTypes ~= nil and symbol? argTypes
- then argTypes := [argTypes]
- ["DECLAIM",["FTYPE",["FUNCTION",argTypes,valType],n]]
+ t is ["%Mapping",:.] => ["DECLAIM",["FTYPE",bfType t,n]]
t is ["%Forall",vars,t'] =>
vars = nil => genDeclaration(n,t')
if symbol? vars then
vars := [vars]
genDeclaration(n,applySubst([[v,:"*"] for v in vars],t'))
- ["DECLAIM",["TYPE",t,n]]
+ ["DECLAIM",["TYPE",bfType t,n]]
++ Translate the signature declaration `d' to its Lisp equivalent.
translateSignatureDeclaration d ==
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index 5b870a6d..6e08acb5 100644
--- a/src/boot/utility.boot
+++ b/src/boot/utility.boot
@@ -48,7 +48,8 @@ module utility (objectMember?, symbolMember?, stringMember?,
lastNode, append, append!, copyList, substitute, substitute!,
setDifference, setUnion, setIntersection,
symbolAssoc, applySubst, applySubst!, applySubstNQ, objectAssoc,
- remove,removeSymbol,atomic?,copyTree,finishLine) where
+ remove, removeSymbol, atomic?, every?, any?, takeWhile, copyTree,
+ finishLine) where
substitute: (%Thing,%Thing,%Thing) -> %Thing
substitute!: (%Thing,%Thing,%Thing) -> %Thing
append: (%List %Thing,%List %Thing) -> %List %Thing
@@ -63,6 +64,9 @@ module utility (objectMember?, symbolMember?, stringMember?,
setUnion: (%List %Thing,%List %Thing) -> %List %Thing
setIntersection: (%List %Thing,%List %Thing) -> %List %Thing
atomic?: %Thing -> %Boolean
+ every?: (%Thing -> %Thing, %List %Thing) -> %Thing
+ any?: (%Thing -> %Thing, %List %Thing) -> %Thing
+ takeWhile: (%Thing -> %Thing, %List %Thing) -> %List %Thing
copyTree: %Thing -> %Thing
finishLine: %Thing -> %Void
--FIXME: Next signature commented out because of GCL bugs
@@ -77,6 +81,19 @@ module utility (objectMember?, symbolMember?, stringMember?,
atomic? x ==
x isnt [.,:.] or x.op is 'QUOTE
+++ Return the last image of `f' if all images of elements in `l'
+++ are non-nil. Otherwise return nil.
+every?(f,l) ==
+ and/[apply(f,x,nil) for x in l]
+
+++ Return the first non-nil image of `f' of elements in `l'.
+any?(f,l) ==
+ or/[apply(f,x,nil) for x in l]
+
+++ Return the sublist of `l' whose elements have non-nil image by `f'.
+takeWhile(f,l) ==
+ [x for x in l while apply(f,x,nil)]
+
copyTree t ==
t is [.,:.] => [copyTree first t,:copyTree rest t]
t
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index b062f979..b5f9fae3 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1327,7 +1327,7 @@ inlineDirectCall call ==
-- identity function too
parms is [=body] => first call.args
-- conservatively approximate eager semantics
- and/[sideEffectFree? arg for arg in call.args] =>
+ every?(function sideEffectFree?,call.args) =>
-- alpha rename before substitution.
newparms := [gensym() for p in parms]
body := applySubst(pairList(parms,newparms),body)
@@ -1406,7 +1406,7 @@ expandableDefinition?(vars,body) ==
atomic? body => true
[op,:args] := body
not ident? op or symbolMember?(op,$NonExpandableOperators) => false
- and/[atomic? x for x in args]
+ every?(function atomic?,args)
or semiSimpleRelativeTo?(body,$simpleVMoperators) =>
usesVariablesLinearly?(body,vars')
false
@@ -1714,7 +1714,7 @@ needsPROG? form ==
op is 'RETURN => true
op in '(LOOP PROG) => false
form is ['BLOCK,=nil,:.] => false
- or/[needsPROG? x for x in form]
+ any?(function needsPROG?,form)
++ We are processing the complete `body' of a function definition.
++ If this body is a multiway test, there is no need to have
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index 26ffe49b..c07346a4 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -249,7 +249,7 @@ optFunctorBody x ==
x is ['%list,:l] =>
null l => nil
l:= [optFunctorBody u for u in l]
- and/[optFunctorBodyQuotable u for u in l] =>
+ every?(function optFunctorBodyQuotable,l) =>
quote [optFunctorBodyRequote u for u in l]
['%list,:l]
x is ['PROGN,:l] => ['PROGN,:optFunctorPROGN l]
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index 0efc5509..e49d3c27 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -124,7 +124,7 @@ augmentPredVector(dollar,value) ==
isHasDollarPred pred ==
pred is [op,:r] =>
op in '(AND and %and OR or %or NOT not %not) =>
- or/[isHasDollarPred x for x in r]
+ any?(function isHasDollarPred,r)
op in '(HasCategory HasAttribute) => first r is '$
false
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-02 20:45:23 +0000