diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/interp/ChangeLog | 20 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 18 | ||||
| -rw-r--r-- | src/interp/fnewmeta.lisp | 11 | ||||
| -rw-r--r-- | src/interp/i-intern.boot | 1 | ||||
| -rw-r--r-- | src/interp/i-spec1.boot | 3 | ||||
| -rw-r--r-- | src/interp/i-spec2.boot | 6 | ||||
| -rw-r--r-- | src/interp/newaux.lisp | 3 | ||||
| -rw-r--r-- | src/interp/pf2sex.boot | 45 | ||||
| -rw-r--r-- | src/interp/sys-constants.boot | 4 |
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) |