diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 9 | ||||
| -rw-r--r-- | src/boot/ast.boot | 12 | ||||
| -rw-r--r-- | src/boot/parser.boot | 6 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 46 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 2 | ||||
| -rw-r--r-- | src/boot/strap/translator.clisp | 20 | ||||
| -rw-r--r-- | src/boot/strap/utility.clisp | 50 | ||||
| -rw-r--r-- | src/boot/translator.boot | 8 | ||||
| -rw-r--r-- | src/boot/utility.boot | 19 | ||||
| -rw-r--r-- | src/interp/c-util.boot | 6 | ||||
| -rw-r--r-- | src/interp/functor.boot | 2 | ||||
| -rw-r--r-- | src/interp/lisplib.boot | 2 |
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 |