aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2007-12-08 20:52:48 +0000
committerdos-reis <gdr@axiomatics.org>2007-12-08 20:52:48 +0000
commit8bd29deee2d75510dc62408582ac8449df93a166 (patch)
treecfa9c528b1a66a1a4ae8295c967427ebef4feca0 /src
parent8b3133a5015424ab3b0b90ecc0fb606be000aa2a (diff)
downloadopen-axiom-8bd29deee2d75510dc62408582ac8449df93a166.tar.gz
Add support for quasiquotation.
* compiler.boot (compileQuasiquote): New function. * fnewmeta.lisp (|PARSE-Enclosure|): Parse quasiquotes too. * i-intern.boot (mkAtree3): Don't evaluate arguments to quasiquote. * i-spec1.boot ($specialOps): Register [||]. (up[||]): Handle quasiquotes. * newaux.lisp: Register `[|' and `|]' as new glyphs. * pf2sex.boot ($insideApplication): Now count the nesting level of application forms. ($insideQuasiquote): New. Count nesting level of quasiquotes. (pfFinishApplication): Ensure application form nesting level is properly decreased. (pfApplication2Sex): Use it. (pfQuasiquotation2Sex): Transform quasiquote forms. (pf2Sex1): Use it. * sys-constants.boot ($Syntax): New.
Diffstat (limited to 'src')
-rw-r--r--src/interp/ChangeLog20
-rw-r--r--src/interp/compiler.boot18
-rw-r--r--src/interp/fnewmeta.lisp11
-rw-r--r--src/interp/i-intern.boot1
-rw-r--r--src/interp/i-spec1.boot3
-rw-r--r--src/interp/i-spec2.boot6
-rw-r--r--src/interp/newaux.lisp3
-rw-r--r--src/interp/pf2sex.boot45
-rw-r--r--src/interp/sys-constants.boot4
9 files changed, 96 insertions, 15 deletions
diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog
index a0b657db..43b6b849 100644
--- a/src/interp/ChangeLog
+++ b/src/interp/ChangeLog
@@ -1,3 +1,23 @@
+2007-12-08 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ Add support for quasiquotation.
+ * compiler.boot (compileQuasiquote): New function.
+ * fnewmeta.lisp (|PARSE-Enclosure|): Parse quasiquotes too.
+ * i-intern.boot (mkAtree3): Don't evaluate arguments to
+ quasiquote.
+ * i-spec1.boot ($specialOps): Register [||].
+ (up[||]): Handle quasiquotes.
+ * newaux.lisp: Register `[|' and `|]' as new glyphs.
+ * pf2sex.boot ($insideApplication): Now count the nesting level of
+ application forms.
+ ($insideQuasiquote): New. Count nesting level of quasiquotes.
+ (pfFinishApplication): Ensure application form nesting level is
+ properly decreased.
+ (pfApplication2Sex): Use it.
+ (pfQuasiquotation2Sex): Transform quasiquote forms.
+ (pf2Sex1): Use it.
+ * sys-constants.boot ($Syntax): New.
+
2007-12-08 Alfredo Portes <alfredo.portes@gmail.com>
Gabriel Dos Reis <gdr@cs.tamu.edu>
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 81108797..b39ad841 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -667,6 +667,21 @@ setqMultipleExplicit(nameList,valList,m,e) ==
[["PROGN",:[T.expr for T in assignList],:[T.expr for T in reAssignList]],
$NoValueMode, (LAST reAssignList).env]
+--% Quasiquotation
+
+++ Compile a quotation `[| form |]'. form is not type-checked, and
+++ is returned as is. Note: when get to support splicing, we would
+++ need to scan `form' to see whether there is any computation that
+++ must be done.
+++ ??? Another strategy would be to infer a more accurate domain
+++ ??? based on the meta operator, e.g. (DEF ...) would be a
+++ DefinitionAst, etc. That however requires that we have a full
+++ fledged AST algebra -- which we don't have yet in mainstream.
+compileQuasiquote(["[||]",:form],m,e) ==
+ null form => nil
+ [["QUOTE", :form],$Syntax,e]
+
+
--% WHERE
compWhere([.,form,:exprList],m,eInit) ==
$insideExpressionIfTrue: local:= false
@@ -1469,5 +1484,6 @@ for x in [["_|", :function compSuchthat],_
["UnionCategory", :function compConstructorCategory],_
["VECTOR", :function compVector],_
["VectorCategory", :function compConstructorCategory],_
- ["where", :function compWhere]] repeat
+ ["where", :function compWhere],_
+ ["[||]", :function compileQuasiquote]] repeat
MAKEPROP(car x, 'SPECIAL, cdr x)
diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp
index 1abd09dc..43d7d3c5 100644
--- a/src/interp/fnewmeta.lisp
+++ b/src/interp/fnewmeta.lisp
@@ -813,7 +813,16 @@
NIL))))
(AND (MATCH-ADVANCE-STRING "}")
(PUSH-REDUCTION '|PARSE-Enclosure|
- (CONS '|brace| NIL))))))))
+ (CONS '|brace| NIL))))))
+ (AND (MATCH-ADVANCE-STRING "[|")
+ (MUST (AND (|PARSE-Statement|)
+ (MUST (MATCH-ADVANCE-STRING "|]"))
+ (PUSH-REDUCTION '|PARSE-Enclosure|
+ (CONS '|[\|\|]|
+ (CONS (POP-STACK-1) NIL))))))
+
+
+ ))
(DEFUN |PARSE-IntegerTok| () (PARSE-NUMBER))
diff --git a/src/interp/i-intern.boot b/src/interp/i-intern.boot
index 37d8d72d..e58821c1 100644
--- a/src/interp/i-intern.boot
+++ b/src/interp/i-intern.boot
@@ -249,6 +249,7 @@ mkAtree3(x,op,argl) ==
r := [[first types,:at],:r']
[mkAtreeNode 'DEF,[[op,:v.0],:r],if v.2 then v.2 else true,false]
[mkAtreeNode 'DEF,[a,:r],true,false]
+ op="[||]" => [mkAtreeNode op, :argl]
--x is ['when,y,pred] =>
-- y isnt ['DEF,a,:r] =>
-- keyedSystemError("S2II0003",['"when",y,'"improper argument form"])
diff --git a/src/interp/i-spec1.boot b/src/interp/i-spec1.boot
index 6316a23f..0047f7f0 100644
--- a/src/interp/i-spec1.boot
+++ b/src/interp/i-spec1.boot
@@ -43,7 +43,8 @@ $anonymousMapCounter := 0
$specialOps := '(
ADEF AlgExtension _and _case COERCE COLLECT construct Declare DEF Dollar
equation error free has IF _is _isnt iterate _break LET _local MDEF _or
- pretend QUOTE REDUCE REPEAT _return SEQ TARGET Tuple typeOf _where )
+ pretend QUOTE REDUCE REPEAT _return SEQ TARGET Tuple typeOf _where
+ _[_|_|_] )
--% Void stuff
diff --git a/src/interp/i-spec2.boot b/src/interp/i-spec2.boot
index 94c7309f..b8dfdf42 100644
--- a/src/interp/i-spec2.boot
+++ b/src/interp/i-spec2.boot
@@ -796,6 +796,12 @@ evalQUOTE(op,[expr],[m]) ==
objNew(['QUOTE,expr],m)
putValue(op,triple)
+--% Quasiquotation
+up_[_|_|_] t ==
+ t isnt [op, x] => nil
+ putValue(op, objNewWrap(x, $Syntax))
+ putModeSet(op, [$Syntax])
+
--% Handler for pretend
uppretend t ==
diff --git a/src/interp/newaux.lisp b/src/interp/newaux.lisp
index 8837c699..dcbdfd95 100644
--- a/src/interp/newaux.lisp
+++ b/src/interp/newaux.lisp
@@ -172,7 +172,7 @@
(mapcar #'(lambda (x) (makeprop (car x) 'gliph (cdr x)))
`(
- ( \| (\)) )
+ ( \| (\)) (]) )
( * (*) )
( \( (<) (\|) )
( + (- (>)) )
@@ -185,6 +185,7 @@
( \. (\.) )
( ^ (=) )
( \~ (=) )
+ ( [ (\|) )
( \: (=) (-) (\:))))
;; RENAMETOK defines alternate token strings which can be used for different
diff --git a/src/interp/pf2sex.boot b/src/interp/pf2sex.boot
index 871d0c77..b4cde2eb 100644
--- a/src/interp/pf2sex.boot
+++ b/src/interp/pf2sex.boot
@@ -38,6 +38,12 @@ import '"ptrees"
$dotdot := INTERN('"..", '"BOOT")
$specificMsgTags := nil
+++ nonzero means we are processing an Application parse form
+$insideApplication := 0
+
+++ nonzero means we are processing a quasiquotation parse form
+$insideQuasiquotation := 0
+
-- Pftree to s-expression translation. Used to interface the new parser
-- technology to the interpreter. The input is a parseTree and the
-- output is an old-parser-style s-expression
@@ -45,8 +51,9 @@ $specificMsgTags := nil
pf2Sex pf ==
intUnsetQuiet()
$insideRule:local := false
- $insideApplication: local := false
+ $insideApplication := 0
$insideSEQ: local := false
+ $insideQuasiquotation := 0
pf2Sex1 pf
pf2Sex1 pf ==
@@ -202,11 +209,19 @@ pfOp2Sex pf ==
op
op
+pfFinishApplication pf ==
+ $insideApplication := $insideApplication - 1
+ pf
+
pfApplication2Sex pf ==
- $insideApplication: local := true
+ -- Assume we are parsing an application, so that we can translate
+ -- (DEF ...) as optional argument specification. That is a weird
+ -- syntax used for example with the drawing package for specifying
+ -- argument to the draw() commands.
+ $insideApplication := $insideApplication + 1
op := pfOp2Sex pfApplicationOp pf
op := opTran op
- op = "->" =>
+ op = "->" => pfFinishApplication
args := pf0TupleParts pfApplicationArg pf
if pfTuple? CAR args then
typeList := [pf2Sex1 arg for arg in pf0TupleParts CAR args]
@@ -215,11 +230,11 @@ pfApplication2Sex pf ==
args := [pf2Sex1 CADR args, :typeList]
["Mapping", :args]
symEqual(op, ":") and $insideRule = 'left =>
- ["multiple", pf2Sex pfApplicationArg pf]
+ pfFinishApplication ["multiple", pf2Sex pfApplicationArg pf]
symEqual(op, "?") and $insideRule = 'left =>
- ["optional", pf2Sex pfApplicationArg pf]
+ pfFinishApplication ["optional", pf2Sex pfApplicationArg pf]
args := pfApplicationArg pf
- pfTuple? args =>
+ pfTuple? args => pfFinishApplication
symEqual(op, "|") and $insideRule = 'left =>
pfSuchThat2Sex args
argSex := rest pf2Sex1 args
@@ -248,15 +263,23 @@ pfApplication2Sex pf ==
val := hasOptArgs? argSex => [op, :val]
[op, :argSex]
op is [qt, realOp] and symEqual(qt, "QUOTE") =>
- ["applyQuote", op, pf2Sex1 args]
- symEqual(op, "braceFromCurly") =>
+ pfFinishApplication ["applyQuote", op, pf2Sex1 args]
+ symEqual(op, "braceFromCurly") => pfFinishApplication
-- ["brace", ["construct", pf2Sex1 args]]
x := pf2Sex1 args
x is ["SEQ", :.] => x
["SEQ", x]
symEqual(op, "by") =>
- ["BY", pf2Sex1 args]
- [op, pf2Sex1 args]
+ pfFinishApplication ["BY", pf2Sex1 args]
+ symEqual(op, "[||]") =>
+ pfFinishApplication pfQuasiquotation2Sex(op, args)
+ pfFinishApplication [op, pf2Sex1 args]
+
+pfQuasiquotation2Sex(op, form) ==
+ $insideQuasiquotation := $insideQuasiquotation + 1
+ form := pf2Sex1 form
+ $insideQuasiquotation := $insideQuasiquotation - 1
+ [op, form]
hasOptArgs? argSex ==
nonOpt := nil
@@ -269,7 +292,7 @@ hasOptArgs? argSex ==
NCONC (nreverse nonOpt, [["construct", :nreverse opt]])
pfDefinition2Sex pf ==
- $insideApplication =>
+ $insideApplication > $insideQuasiquotation =>
["OPTARG", pf2Sex1 CAR pf0DefinitionLhsItems pf,
pf2Sex1 pfDefinitionRhs pf]
idList := [pf2Sex1 x for x in pf0DefinitionLhsItems pf]
diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot
index 345e665c..0ce969c6 100644
--- a/src/interp/sys-constants.boot
+++ b/src/interp/sys-constants.boot
@@ -291,6 +291,10 @@ $Void ==
$Any ==
'(Any)
+++ The Syntax domain constructor form
+$Syntax ==
+ '(Syntax)
+
++ Boolean domain constructor form
$Boolean ==
'(Boolean)