diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/compiler.boot | 58 | ||||
| -rw-r--r-- | src/interp/fnewmeta.lisp | 42 | ||||
| -rw-r--r-- | src/interp/g-opt.boot | 10 | ||||
| -rw-r--r-- | src/interp/metalex.lisp | 2 | ||||
| -rw-r--r-- | src/interp/newaux.lisp | 2 |
5 files changed, 104 insertions, 10 deletions
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 22c5471c..43433524 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1995,6 +1995,22 @@ compRetractGuard(x,t,sn,sm,e) == [caseCode, [[x,restrictCode]],e,envFalse] +++ Subroutine of compRecoverGuard. The parameters and the result +++ have the same meaning as in compRecoverGuard. +++ Note: a value of type Any is a dotted pair (dom . val) where +++ `dom' is a devaluated form of the domain of `val'. +compRecoverDomain(x,t,sn,e) == + -- 1. We recover domains only. + not isDomainForm(t,e) => + stackAndThrow('"Form %1b does not designate a domain",[t]) + caseCode := ["EQUAL",["devaluate",t],["CAR",sn]] + -- 2. Declare `x'. + originalEnv := e + [.,.,e] := compMakeDeclaration(x,t,e) or return nil + e := put(x,"value",[genSomeVariable(),t,$noEnv],e) + -- 3. Assemble the result + [caseCode,[[x,["CDR",sn]]],e,originalEnv] + ++ Subroutine of compAlternativeGuardItem, responsible for ++ compiling a guad item of the form ++ x: t @@ -2014,16 +2030,35 @@ compRecoverGuard(x,t,sn,sm,e) == -- for `x' under the condition that sm is Any, and the -- underlying type is t. -- - -- 1. Evaluate the recovery condition - sm ^= $Any => + -- 0. Type recovery is for expressions of type 'Any'. + (sm = "$" => $functorForm; sm) ^= $Any => stackAndThrow('"Scrutinee must be of type %b Any %d in type recovery alternative of case pattern",nil) - caseCode := ["EQUAL",["devaluate",t],["objMode",sn]] - -- 2. Declare `x'. - originalEnv := e - [.,.,e] := compMakeDeclaration(x,t,e) or return nil - e := put(x,"value",[genSomeVariable(),t,$noEnv],e) - -- 3. Assemble the result - [caseCode,[[x,["objVal",sn]]],e,originalEnv] + -- 1. Do some preprocessing if this is existential type recovery. + t is ["%Exist",var,t'] => + var isnt [":",var',cat'] => + stackAndThrow('"Sorry: Only univariate type schemes are supported in this context",nil) + -- We have a univariate type scheme. At the moment we insist + -- that the body of the type scheme be identical to the type + -- variable. This restriction should be lifted in future work. + not IDENTP t' or t' ^= var' => + stackAndThrow('"Sorry: type %1b too complex",[t']) + not isCategoryForm(cat',e) => + stackAndThrow('"Expression %1b does not designate a category",[cat']) + getmode(var',e) => + stackAndThrow('"You cannot redeclare identifier %1b",[var']) + -- Extract the type component. Here note that we use a wider + -- assignment scope (e.g. "%LET") as opposed to local assignment + -- because the recovered type may be needed in the body of + -- the alternative. + varDef := ["%LET",[":",var',$Type], + [["elt",["Foreign","Builtin"],"evalDomain"], + [["elt",["Foreign","Builtin"],"CAR"], sn]]] + [def,.,e] := compOrCroak(varDef,$EmptyMode,e) + [hasTest,.,e] := compOrCroak(["has",var',cat'],$EmptyMode,e) + [guard,inits,e,envFalse] := compRecoverDomain(x,var',sn,e) + [["PROGN",def,hasTest],inits,e,envFalse] + -- 2. Hand it to whoever is in charge. + compRecoverDomain(x,t,sn,e) warnUnreachableAlternative pat == stackWarning('"Alternative with pattern %1b will not be reached",[pat]) @@ -2147,6 +2182,9 @@ compMatch(["%Match",subject,altBlock],m,env) == ["COND",:nreverse altsCode]] [code,m,savedEnv] +++ Compile the form scheme `x'. +compScheme(x,m,e) == + stackSemanticError(["Sorry: Expression schemes are not supported in this context"],nil) --% --% Inline Requests @@ -2556,6 +2594,8 @@ for x in [["|", :"compSuchthat"],_ ["per",:"compPer"],_ ["rep",:"compRep"],_ ["%Comma",:"compComma"],_ + ["%Exist", : "compScheme"] , _ + ["%Forall", : "compSceheme"] , _ ["%Match",:"compMatch"],_ ["%SignatureImport",:"compSignatureImport"],_ ["[||]", :"compileQuasiquote"]] repeat diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp index 60027f80..e6af7e4c 100644 --- a/src/interp/fnewmeta.lisp +++ b/src/interp/fnewmeta.lisp @@ -474,6 +474,48 @@ (PUSH-REDUCTION '|PARSE-Inline| (CONS '|%Inline| (CONS (POP-STACK-1) NIL))))) +;; quantified types. At the moment, these are used only in +;; pattern-mathing cases. +;; -- gdr, 2009-06-14. +(DEFUN |PARSE-Scheme| () + (OR (AND (|PARSE-Quantifier|) + (MUST (|PARSE-QuantifiedVariableList|)) + (MUST (MATCH-ADVANCE-STRING ".")) + (MUST (|PARSE-Application|)) + (MUST (PUSH-REDUCTION '|PARSE-Forall| + (CONS (POP-STACK-3) + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL)))))) + (|PARSE-Application|))) + +(DEFUN |PARSE-Quantifier| () + (OR (AND (MATCH-ADVANCE-STRING "forall") + (MUST (PUSH-REDUCTION '|PARSE-Quantifier| '|%Forall|))) + (AND (MATCH-ADVANCE-STRING "exist") + (MUST (PUSH-REDUCTION '|PARSE-Quantifier| '|%Exist|))))) + +(DEFUN |PARSE-QuantifiedVariableList| () + (AND (MATCH-ADVANCE-STRING "(") + (MUST (|PARSE-QuantifiedVariable|)) + (OPTIONAL + (AND (STAR REPEATOR + (AND (MATCH-ADVANCE-STRING ",") + (MUST (|PARSE-QuantifiedVariable|)))) + (PUSH-REDUCTION '|PARSE-QuantifiedVariableList| + (CONS '|%Sequence| + (CONS (POP-STACK-2) + (APPEND (POP-STACK-1) NIL)))))) + (MUST (MATCH-ADVANCE-STRING ")")))) + +(DEFUN |PARSE-QuantifiedVariable| () + (AND (PARSE-IDENTIFIER) + (MUST (MATCH-ADVANCE-STRING ":")) + (MUST (|PARSE-Application|)) + (MUST (PUSH-REDUCTION '|PARSE-QuantifiedVariable| + (CONS '|:| + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL))))))) + (DEFUN |PARSE-Infix| () (AND (PUSH-REDUCTION '|PARSE-Infix| (CURRENT-SYMBOL)) (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index c51987dc..0fb44255 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -492,6 +492,15 @@ optLET u == rplac(rest def, second def) SUBLIS(inits,body) +optLET_* form == + form isnt ["LET*",:.] => form + ok := true + while ok for [[var,.],:inits] in tails second form repeat + if CONTAINED(var,inits) then ok := false + not ok => form + rplac(first form,"LET") + optLET form + lispize x == first optimize [x] --% optimizer hash table @@ -499,6 +508,7 @@ lispize x == first optimize [x] for x in '( (call optCall) _ (SEQ optSEQ)_ (LET optLET)_ + (LET_* optLET_*)_ (MINUS optMINUS)_ (QSMINUS optQSMINUS)_ (_- opt_-)_ diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp index 690c6243..27b82522 100644 --- a/src/interp/metalex.lisp +++ b/src/interp/metalex.lisp @@ -570,7 +570,7 @@ empty (if File-Closed (return nil)) (defconstant Keywords - '(|or| |and| |isnt| |is| |when| |where| + '(|or| |and| |isnt| |is| |when| |where| |forall| |exist| |has| |with| |add| |case| |in| |by| |pretend| |mod| |exquo| |div| |quo| |else| |rem| |then| |suchthat| |if| |yield| |iterate| |from| |exit| |leave| |return| diff --git a/src/interp/newaux.lisp b/src/interp/newaux.lisp index a3d2ef79..db00f018 100644 --- a/src/interp/newaux.lisp +++ b/src/interp/newaux.lisp @@ -135,6 +135,8 @@ (|repeat| 130 190 (|PARSE-Loop|)) (|import| 120 0 (|PARSE-Import|) ) (|inline| 120 0 (|PARSE-Inline|) ) + (|forall| 998 999 (|PARSE-Scheme|)) + (|exist| 998 999 (|PARSE-Scheme|)) (|unless|) (|add| 900 120) (|with| 1000 300 (|PARSE-With|)) |