aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xconfigure20
-rw-r--r--configure.ac2
-rw-r--r--src/ChangeLog30
-rw-r--r--src/doc/msgs/s2-us.msgs2
-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
12 files changed, 189 insertions, 38 deletions
diff --git a/configure b/configure
index 1c331d39..d6cc2840 100755
--- a/configure
+++ b/configure
@@ -1,6 +1,6 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.65 for OpenAxiom 1.4.0-2010-12-05.
+# Generated by GNU Autoconf 2.65 for OpenAxiom 1.4.0-2010-12-06.
#
# Report bugs to <open-axiom-bugs@lists.sf.net>.
#
@@ -701,8 +701,8 @@ MAKEFLAGS=
# Identity of this package.
PACKAGE_NAME='OpenAxiom'
PACKAGE_TARNAME='openaxiom'
-PACKAGE_VERSION='1.4.0-2010-12-05'
-PACKAGE_STRING='OpenAxiom 1.4.0-2010-12-05'
+PACKAGE_VERSION='1.4.0-2010-12-06'
+PACKAGE_STRING='OpenAxiom 1.4.0-2010-12-06'
PACKAGE_BUGREPORT='open-axiom-bugs@lists.sf.net'
PACKAGE_URL=''
@@ -1491,7 +1491,7 @@ if test "$ac_init_help" = "long"; then
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
-\`configure' configures OpenAxiom 1.4.0-2010-12-05 to adapt to many kinds of systems.
+\`configure' configures OpenAxiom 1.4.0-2010-12-06 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@@ -1566,7 +1566,7 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of OpenAxiom 1.4.0-2010-12-05:";;
+ short | recursive ) echo "Configuration of OpenAxiom 1.4.0-2010-12-06:";;
esac
cat <<\_ACEOF
@@ -1677,7 +1677,7 @@ fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-OpenAxiom configure 1.4.0-2010-12-05
+OpenAxiom configure 1.4.0-2010-12-06
generated by GNU Autoconf 2.65
Copyright (C) 2009 Free Software Foundation, Inc.
@@ -2569,7 +2569,7 @@ cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by OpenAxiom $as_me 1.4.0-2010-12-05, which was
+It was created by OpenAxiom $as_me 1.4.0-2010-12-06, which was
generated by GNU Autoconf 2.65. Invocation command line was
$ $0 $@
@@ -5468,7 +5468,7 @@ fi
# Define the identity of the package.
PACKAGE='openaxiom'
- VERSION='1.4.0-2010-12-05'
+ VERSION='1.4.0-2010-12-06'
cat >>confdefs.h <<_ACEOF
@@ -20961,7 +20961,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
-This file was extended by OpenAxiom $as_me 1.4.0-2010-12-05, which was
+This file was extended by OpenAxiom $as_me 1.4.0-2010-12-06, which was
generated by GNU Autoconf 2.65. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
@@ -21027,7 +21027,7 @@ _ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
-OpenAxiom config.status 1.4.0-2010-12-05
+OpenAxiom config.status 1.4.0-2010-12-06
configured by $0, generated by GNU Autoconf 2.65,
with options \\"\$ac_cs_config\\"
diff --git a/configure.ac b/configure.ac
index f98096a0..c29dab32 100644
--- a/configure.ac
+++ b/configure.ac
@@ -33,7 +33,7 @@ dnl Makefiles for building OpenAxiom interpreter, compiler, libraries, and
dnl auxiliary tools where appropriate.
dnl
-AC_INIT([OpenAxiom], [1.4.0-2010-12-05],
+AC_INIT([OpenAxiom], [1.4.0-2010-12-06],
[open-axiom-bugs@lists.sf.net])
dnl Most of the macros used in this configure.ac are defined in files
diff --git a/src/ChangeLog b/src/ChangeLog
index 0d573f06..2621e6cb 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,33 @@
+2010-12-06 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ Add support for exception handling.
+ * interp/parsing.lisp (TEST-LEXING): Remove.
+ (RTRACE): Likewise.
+ (RUNTRACE): Likewise.
+ (MATCH-ADVANCE-KEYWORD): New.
+ (MATCH-ADVANCE-GLYPH): Likewise.
+ (MATCH-ADVANCE-SPECIAL): Likewise.
+ (MATCH-SPECIAL): Likewise.
+ (MATCH-KEYWORD-NEXT): Likewise.
+ * interp/newaux.lisp: Make try and throw prefix operators.
+ * interp/metalex.lisp (KEYWORDS): Include finally, catch and throw.
+ * interp/fnewmeta.lisp (PARSE-Throw): New. Parse throw-expressions.
+ (PARSE-Catch): New. Parse catch-expressions.
+ (PARSE-Finally): New. Parse finally-expressions.
+ (PARSE-Try): New. Parse try-expressions.
+ * interp/compiler.boot (compThrow): New. Register to compile
+ throw-expressions.
+ (compTry): New. Register to compiler try-expressions.
+ (compCatch): New. Compile catch-handler expression.
+ * interp/g-opt.boot (optTry): New. Simplify simple expressions in
+ the try operand.
+ * interp/g-util.boot (expandThrow): New. Expand %throw forms.
+ (domainMatchCode): New.
+ (expandTry): New. Expand %try forms.
+ * doc/msgs/s2-us.msgs: Add new message with key S2GE0020.
+ * interp/g-error.boot (systemErrorHandler): Handle possible
+ uncaucght expression condition.
+
2010-12-05 Gabriel Dos Reis <gdr@cs.tamu.edu>
* interp/metalex.lisp (KEYWORDS): Include try.
diff --git a/src/doc/msgs/s2-us.msgs b/src/doc/msgs/s2-us.msgs
index 9f6cc921..c702924c 100644
--- a/src/doc/msgs/s2-us.msgs
+++ b/src/doc/msgs/s2-us.msgs
@@ -1138,6 +1138,8 @@ S2GE0016
Unexpected error or improper call to system function %1b: %2
S2GE0017
Unexpected error in call to system function %1b
+S2GE0020
+ Uncaught exception
S2GL0001
%ceon
%b OpenAxiom: The Open Scientific Computation Platform %d %l
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.")
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-30 11:12:45 +0000