aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/compiler.boot58
-rw-r--r--src/interp/fnewmeta.lisp42
-rw-r--r--src/interp/g-opt.boot10
-rw-r--r--src/interp/metalex.lisp2
-rw-r--r--src/interp/newaux.lisp2
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|))