aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/compiler.boot30
-rw-r--r--src/interp/fnewmeta.lisp53
-rw-r--r--src/interp/g-error.boot1
-rw-r--r--src/interp/g-opt.boot5
-rw-r--r--src/interp/g-util.boot37
-rw-r--r--src/interp/metalex.lisp4
-rw-r--r--src/interp/newaux.lisp2
-rw-r--r--src/interp/parsing.lisp41
8 files changed, 146 insertions, 27 deletions
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 501935c1..73d0e136 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -1148,6 +1148,34 @@ compReturn(["return",x],m,e) ==
modifyModeStack(m',index)
[["TAGGEDreturn",0,u],m,e']
+--% throw expressions
+
+compThrow: (%Form,%Mode,%Env) -> %Maybe %Triple
+compThrow(["%Throw",x],m,e) ==
+ T := comp(x,$EmptyMode,e) or return nil
+ -- FIXME: at the moment, throwable expressions must be of type
+ -- FIXME: instantiated from niladic constructors.
+ T.mode isnt [c] or not(niladicConstructorFromDB c) =>
+ stackAndThrow('"throw-operand %1b must be of known niladic type",[x])
+ -- An exception does not use the normal exit/return route, so
+ -- we don't take into account neither $exitModeStack nor $returnMode.
+ [['%throw,T.mode,T.expr],$NoValueMode,T.env]
+
+compCatch: (%Form,%Mode,%Env) -> %Maybe %Triple
+compCatch([x,s],m,e) ==
+ [x',m',e] := compMakeDeclaration(second x, third x,e)
+ T := compOrCroak(s,m,e)
+ [['%catch,second x,m',T.expr],T.mode,e]
+
+compTry: (%Form,%Mode,%Env) -> %Maybe %Triple
+compTry(['%Try,x,ys,z],m,e) ==
+ x' := compOrCroak(x,m,e).expr
+ ys' := [compCatch(y,m,e).expr for y in ys]
+ z' :=
+ z ~= nil => ['%finally,compOrCroak(z,$NoValueMode,e).expr]
+ nil
+ [['%try,x',ys',z'],m,e]
+
--% ELT
++ `op' supposedly designate an external entity with language linkage
@@ -2673,5 +2701,7 @@ for x in [["|", :"compSuchthat"],_
["%Forall", : "compSceheme"] , _
["%Match",:"compMatch"],_
["%SignatureImport",:"compSignatureImport"],_
+ ['%Throw,:'compThrow],
+ ['%Try, :'compTry],
["[||]", :"compileQuasiquote"]] repeat
property(first x, 'SPECIAL) := rest x
diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp
index e575c8af..024ed7c5 100644
--- a/src/interp/fnewmeta.lisp
+++ b/src/interp/fnewmeta.lisp
@@ -50,7 +50,6 @@
(defun |isTokenDelimiter| ()
(MEMBER (CURRENT-SYMBOL) '(\) END\_UNIT NIL)))
-
(DEFUN |PARSE-NewExpr| ()
(OR (AND (MATCH-STRING ")") (ACTION (|processSynonyms|))
(MUST (|PARSE-Command|)))
@@ -321,12 +320,62 @@
(PUSH-REDUCTION '|PARSE-SemiColon|
(CONS '|;| (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))))
-
+;; We should factorize these boilerplates
(DEFUN |PARSE-Return| ()
(AND (MATCH-ADVANCE-STRING "return") (MUST (|PARSE-Expression|))
(PUSH-REDUCTION '|PARSE-Return|
(CONS '|return| (CONS (POP-STACK-1) NIL)))))
+(DEFUN |PARSE-Throw| ()
+ (AND (MATCH-ADVANCE-KEYWORD "throw")
+ (MUST (|PARSE-Expression|))
+ (PUSH-REDUCTION '|PARSE-Throw|
+ (CONS '|%Throw| (CONS (POP-STACK-1) NIL)))))
+
+(DEFUN |PARSE-Catch| ()
+ (AND (MATCH-SPECIAL ";")
+ (MATCH-KEYWORD-NEXT "catch")
+ (ACTION (ADVANCE-TOKEN))
+ (ACTION (ADVANCE-TOKEN))
+ (MUST (MATCH-ADVANCE-GLYPH "("))
+ (MUST (|PARSE-QuantifiedVariable|))
+ (MUST (MATCH-ADVANCE-SPECIAL ")"))
+ (MUST (MATCH-ADVANCE-GLYPH "=>"))
+ (MUST (|PARSE-Expression|))
+ (PUSH-REDUCTION '|PARSE-Catch|
+ (CONS (POP-STACK-2)
+ (CONS (POP-STACK-1) NIL)))))
+
+(DEFUN |PARSE-Finally| ()
+ (AND (MATCH-SPECIAL ";")
+ (MATCH-KEYWORD-NEXT "finally")
+ (ACTION (ADVANCE-TOKEN))
+ (ACTION (ADVANCE-TOKEN))
+ (MUST (|PARSE-Expression|))))
+
+(DEFUN |PARSE-Try| ()
+ (AND (MATCH-ADVANCE-KEYWORD "try")
+ (MUST (|PARSE-Expression|))
+ ;; exception handlers: either a finally-expression, or
+ ;; a series of catch-expressions optionally followed by
+ ;; a finally-expression.
+ (MUST (OR (AND (|PARSE-Finally|)
+ (PUSH-REDUCTION '|PARSE-Try|
+ (CONS '|%Try|
+ (CONS (POP-STACK-2)
+ (CONS NIL
+ (CONS (POP-STACK-1) NIL))))))
+ (AND (MUST (STAR REPEATOR (|PARSE-Catch|)))
+ (BANG FIL_TEST
+ (OPTIONAL (|PARSE-Finally|)))
+ (PUSH-REDUCTION '|PARSE-Try|
+ (CONS '|%Try|
+ (CONS (POP-STACK-3)
+ (CONS (POP-STACK-2)
+ (CONS (POP-STACK-1)
+ NIL))))))))))
+
+
(DEFUN |PARSE-Jump| ()
(LET ((S (CURRENT-SYMBOL)))
(AND S
diff --git a/src/interp/g-error.boot b/src/interp/g-error.boot
index b88206b8..4964e4da 100644
--- a/src/interp/g-error.boot
+++ b/src/interp/g-error.boot
@@ -188,6 +188,7 @@ systemErrorHandler c ==
$BreakMode = "validate" =>
systemError ERROR_-FORMAT('"~a",[c])
not $inLispVM and $BreakMode in '(nobreak query resume) =>
+ TYPEP(c,'CONTROL_-ERROR) => keyedSystemError('S2GE0020,nil)
LET(($inLispVM true)(), systemError ERROR_-FORMAT('"~a",[c]))
$BreakMode = "letPrint2" =>
$BreakMode := nil
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 4e909d60..36f369ec 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -595,6 +595,10 @@ optBind form ==
second(form) := inits
form
+optTry form ==
+ form isnt ['try,e,hs,f] or not(isFloatableVMForm e) or f ~= nil => form
+ e
+
optLIST form ==
form is ["LIST"] => nil
form
@@ -752,6 +756,7 @@ for x in '( (%call optCall) _
(LET optLET)_
(LET_* optLET_*)_
(%bind optBind)_
+ (%try optTry)_
(%not optNot)_
(%and optAnd)_
(%or optOr)_
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index e8fe239c..2462e843 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -371,6 +371,39 @@ expandStore ["%store",place,value] ==
cons? place => ["SETF",place,value]
["SETQ",place,value]
+-- non-local control transfer
+
+$OpenAxiomCatchTag == KEYWORD::OpenAxiomCatchPoint
+
+expandThrow ['%throw,m,x] ==
+ ['THROW,$OpenAxiomCatchTag,
+ ['CONS,$OpenAxiomCatchTag,
+ ['CONS,expandToVMForm m,expandToVMForm x]]]
+
+++ Subroutine of expandTry. Generate code for domain matching
+++ of object `obj' with domain `dom'.
+domainMatchCode(dom,obj) ==
+ -- FIXME: Instead of domain equality, we should also consider
+ -- FIXME: cases of sub-domains, or domain schemes with constraints.
+ ['domainEqual,dom,['%head,obj]]
+
+expandTry ['%try,expr,handlers,cleanup] ==
+ g := gensym() -- hold the exception object
+ ys := [[domainMatchCode(mode,['%tail,g]),
+ ['%bind,[[var,['%tail,['%tail,g]]]],stmt]]
+ for [.,var,mode,stmt] in handlers]
+ handlerBody :=
+ ys = nil => g
+ ys := [:ys,['%true,['THROW,$OpenAxiomCatchTag,g]]]
+ ['%when,
+ [['%and,['%pair?,g],
+ ['%peq,['%head,g],$OpenAxiomCatchTag]], ['%when,:ys]],
+ ['%true,g]]
+ tryBlock := expandBind
+ ['%bind,[[g,['CATCH,$OpenAxiomCatchTag,expr]]],handlerBody]
+ cleanup = nil => tryBlock
+ ['UNWIND_-PROTECT,tryBlock,:expandToVMForm rest cleanup]
+
++ Opcodes with direct mapping to target operations.
for x in [
-- Boolean constants
@@ -523,7 +556,9 @@ for x in [
['%bind, :function expandBind],
['%store, :function expandStore],
- ['%dynval, :function expandDynval]
+ ['%dynval, :function expandDynval],
+ ['%throw, :function expandThrow],
+ ['%try, :function expandTry]
] repeat property(first x,'%Expander) := rest x
++ Return the expander of a middle-end opcode, or nil if there is none.
diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp
index 788eb449..73d6bee1 100644
--- a/src/interp/metalex.lisp
+++ b/src/interp/metalex.lisp
@@ -571,8 +571,8 @@ empty (if File-Closed (return nil))
(defconstant Keywords
'(|or| |and| |isnt| |is| |when| |where| |forall| |exist| |try|
- |has| |with| |add| |case| |in| |by| |pretend| |mod|
- |exquo| |div| |quo| |else| |rem| |then| |suchthat|
+ |has| |with| |add| |case| |in| |by| |pretend| |mod| |finally|
+ |exquo| |div| |quo| |else| |rem| |then| |suchthat| |catch| |throw|
|if| |yield| |iterate| |break| |from| |exit| |leave| |return|
|not| |unless| |repeat| |until| |while| |for| |import| |inline|)
diff --git a/src/interp/newaux.lisp b/src/interp/newaux.lisp
index ed9b0030..3a10a738 100644
--- a/src/interp/newaux.lisp
+++ b/src/interp/newaux.lisp
@@ -154,6 +154,8 @@
(~ 260 259 nil)
(= 400 700)
(|return| 202 201 (|PARSE-Return|))
+ (|try| 202 201 (|PARSE-Try|))
+ (|throw| 202 201 (|PARSE-Throw|))
(|leave| 202 201 (|PARSE-Leave|))
(|exit| 202 201 (|PARSE-Exit|))
(|break| 202 201 (|PARSE-Jump|))
diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp
index 33c8e635..9dfe1d02 100644
--- a/src/interp/parsing.lisp
+++ b/src/interp/parsing.lisp
@@ -1,6 +1,6 @@
;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
;; All rights reserved.
-;; Copyright (C) 2007, Gabriel Dos Reis.
+;; Copyright (C) 2007-2010, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -171,14 +171,6 @@ the stack, then stack a NIL. Return the value of prod."
; (3) Line handling: Next Line, Print Next Line
; (X) Random Stuff
-; A good test for lexing is:
-
-(defmacro test-lexing ()
- '(with-open-file (in-stream "lisp>meta.meta" :direction :input)
- (with-open-file (out-stream "lisp>foo.pars" :direction :output :if-exists :supersede)
- (loop (let ((z (advance-token)))
- (if z (Token-Print z out-stream) (return nil)))))))
-
; 3A (0). String grabbing
; String grabbing is the art of matching initial segments of the current
@@ -215,13 +207,30 @@ the stack, then stack a NIL. Return the value of prod."
:nonBlank nonblank))
t))))
+(defun match-advance-keyword (str)
+ (and (match-token (current-token) 'keyword (intern str))
+ (action (advance-token))))
+
+(defun match-advance-glyph (str)
+ (and (match-token (current-token) 'gliph (intern str))
+ (action (advance-token))))
+
+(defun match-advance-special (str)
+ (and (match-token (current-token) 'special-char (character str))
+ (action (advance-token))))
+
+(defun match-special (str)
+ (match-token (current-token) 'special-char (character str)))
+
+(defun match-keyword-next (str)
+ (match-token (next-token) 'keyword (intern str)))
+
(defun initial-substring-p (part whole)
"Returns length of part if part matches initial segment of whole."
(let ((x (string<= part whole)))
(and x (= x (length part)) x)))
-
; 3A 3. Line Handling.
; PARAMETERS DEFINED IN THIS SECTION:
@@ -401,18 +410,6 @@ the stack, then stack a NIL. Return the value of prod."
(format t " reduced ~A~%" y)))
y)
-#+Symbolics
-(defmacro rtrace (&rest rules)
- `(compiler-let () .
- ,(mapcar #'(lambda (x)
- (let ((rule (intern (strconc "PARSE-" x))))
- `(zl:advise ,rule :around nil nil
- (reduction-print :do-it ',rule))))
- rules)))
-
-#+Symbolics
-(defmacro runtrace () `(zl:unadvise))
-
(defmacro tracemeta (&rest l) `(trmeta ',l))
(defparameter /depth 0 "Used in Debug.lisp.")