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.

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)