diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/compiler.boot | 30 | ||||
| -rw-r--r-- | src/interp/fnewmeta.lisp | 53 | ||||
| -rw-r--r-- | src/interp/g-error.boot | 1 | ||||
| -rw-r--r-- | src/interp/g-opt.boot | 5 | ||||
| -rw-r--r-- | src/interp/g-util.boot | 37 | ||||
| -rw-r--r-- | src/interp/metalex.lisp | 4 | ||||
| -rw-r--r-- | src/interp/newaux.lisp | 2 | ||||
| -rw-r--r-- | src/interp/parsing.lisp | 41 |
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.") |