diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index a5cc4b6..347b436 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -5446,6 +5446,949 @@ and the current token (\$ttok) @ +\chapter{Pftrees} +\section{Special Nodes} + +\defun{pfNothing?}{Is this a Nothing node?} +\calls{pfNothing?}{pfAbSynOp?} +<>= +(defun |pfNothing?| (form) + (|pfAbSynOp?| form '|nothing|)) + +@ + +\section{Leaves} + +\defun{pfIdSymbol}{Return the Id part} +\calls{pfIdSymbol}{} +<>= +(defun |pfIdSymbol| (|form|) + (|tokPart| |form|)) + +@ + +\defun{pfLiteral?}{Is this a Literal node?} +\calls{pfLiteral?}{pfAbSynOp} +<>= +(defun |pfLiteral?| (form) + (memq (|pfAbSynOp| form) + '(|integer| |symbol| |expression| |one| |zero| |char| |string| |float|))) + +@ + +\defun{pfSymbol?}{Is this a Symbol node?} +\calls{pfSymbol?}{pfAbSynOp?} +<>= +(defun |pfSymbol?| (form) + (|pfAbSynOp?| form '|symbol|)) + +@ + +\defun{pfSymbolSymbol}{Return the Symbol part} +\calls{pfSymbolSymbol}{tokPart} +<>= +(defun |pfSymbolSymbol| (form) + (|tokPart| form)) + +@ + +\section{Trees} + +\defun{pfApplication?}{Is this an Application node?} +\calls{pfApplication?}{pfAbSynOp?} +<>= +(defun |pfApplication?| (pf) + (|pfAbSynOp?| pf '|Application|)) + +@ + +\defun{pfCoerceto?}{Is this a CoerceTo node?} +\calls{pfCoerceto?}{pfAbSynOp?} +<>= +(defun |pfCoerceto?| (pf) + (|pfAbSynOp?| pf '|Coerceto|)) + +@ + +\defun{pfCoercetoExpr}{Return the Expression part of a CoerceTo node} +<>= +(defun |pfCoercetoExpr| (pf) + (cadr pf)) + +@ + +\defun{pfCoercetoType}{Return the Type part of a CoerceTo node} +<>= +(defun |pfCoercetoType| (pf) + (caddr pf)) + +@ + +\defun{pfFromdom?}{Is this a Fromdom mode?} +\calls{pfFromdom?}{pfAbSynOp?} +<>= +(defun |pfFromdom?| (pf) + (|pfAbSynOp?| pf '|Fromdom|)) + +@ + +\defun{pfFromdomWhat}{Return the What part of a Fromdom node} +<>= +(defun |pfFromdomWhat| (pf) + (cadr pf)) + +@ + +\defun{pfFromdomDomain}{Return the Domain part of a Fromdom node} +<>= +(defun |pfFromdomDomain| (pf) + (caddr pf)) + +@ + +\defun{pfIf?}{Is this an If node?} +\calls{pfIf?}{pfAbSynOp?} +<>= +(defun |pfIf?| (pf) + (|pfAbSynOp?| pf '|If|)) + +@ + +\defun{pfIfCond}{Return the Cond part of an If} +<>= +(defun |pfIfCond| (pf) + (cadr pf)) + +@ + +\defun{pfExit?}{Is this an Exit node?} +\calls{pfExit?}{pfAbSynOp?} +<>= +(defun |pfExit?| (pf) + (|pfAbSynOp?| pf '|Exit|)) + +@ + +\defun{pfExitCond}{Return the Cond part of an Exit} +<>= +(defun |pfExitCond| (pf) + (cadr pf)) + +@ + +\defun{pfExitExpr}{Return the Expression part of an Exit} +<>= +(defun |pfExitExpr| (pf) + (caddr pf)) + +@ + +\defun{pfIfThen}{Return the Then part of an If} +<>= +(defun |pfIfThen| (pf) + (caddr pf)) + +@ + +\defun{pfIfElse}{Return the Else part of an If} +<>= +(defun |pfIfElse| (pf) + (cadddr pf)) + +@ + +\defun{pfLoop?}{Is this a Loop node?} +\calls{pfLoop?}{pfAbSynOp?} +<>= +(defun |pfLoop?| (pf) + (|pfAbSynOp?| pf '|Loop|)) + +@ + +\defun{pfPretend?}{Is this a Pretend node?} +\calls{pfPretend?}{pfAbSynOp?} +<>= +(defun |pfPretend?| (pf) + (|pfAbSynOp?| pf '|Pretend|)) + +@ + +\defun{pfPretendExpr}{Return the Expression part of a Pretend node} +<>= +(defun |pfPretendExpr| (pf) + (cadr pf)) + +@ + +\defun{pfPretendType}{Return the Type part of a Pretend node} +<>= +(defun |pfPretendType| (pf) + (caddr pf)) + +@ + +\defun{pfSequence?}{ Is this a Sequence node?} +\calls{pfSequence?}{pfAbSynOp?} +<>= +(defun |pfSequence?| (pf) + (|pfAbSynOp?| pf '|Sequence|)) + +@ + +\defun{pfTagged?}{Is this a Tagged node?} +\calls{pfTagged?}{pfAbSynOp?} +<>= +(defun |pfTagged?| (pf) + (|pfAbSynOp?| pf '|Tagged|)) + +@ + +\defun{pfTaggedExpr}{Return the Expression portion of a Tagged node} +<>= +(defun |pfTaggedExpr| (pf) + (caddr pf)) + +@ + +\defun{pfTaggedTag}{Return the Tag of a Tagged node} +<>= +(defun |pfTaggedTag| (pf) + (cadr pf)) + +@ + +\defun{pfTuple?}{Is this a Tuple node?} +\calls{pfTuple?}{pfAbSynOp?} +<>= +(defun |pfTuple?| (pf) + (|pfAbSynOp?| pf '|Tuple|)) + +@ + +\defun{pf0TupleParts}{Return the parts of a Tuple} +\calls{pf0TupleParts}{pfParts} +\calls{pf0TupleParts}{pfTupleParts} +<>= +(defun |pf0TupleParts| (pf) + (|pfParts| (|pfTupleParts| pf))) + +@ + +\chapter{Pftree to s-expression translation} +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. + +\defun{pf2Sex}{Pftree to s-expression translation} +\calls{pf2Sex}{pf2Sex1} +\usesdollar{pf2Sex}{insideSEQ} +\usesdollar{pf2Sex}{insideApplication} +\usesdollar{pf2Sex}{insideRule} +\usesdollar{pf2Sex}{QuietCommand} +<>= +(defun |pf2Sex| (pf) + (let (|$insideSEQ| |$insideApplication| |$insideRule|) + (declare (special |$insideSEQ| |$insideApplication| |$insideRule| + |$QuietCommand|)) + (setq |$QuietCommand| nil) + (setq |$insideRule| nil) + (setq |$insideApplication| nil) + (setq |$insideSEQ| nil) + (|pf2Sex1| pf))) + +@ + +\defun{pf2Sex1}{Pftree to s-expression translation inner function} +\calls{pf2Sex1}{pfNothing?} +\calls{pf2Sex1}{pfSymbol?} +\calls{pf2Sex1}{pfSymbolSymbol} +\calls{pf2Sex1}{pfLiteral?} +\calls{pf2Sex1}{pfLiteral2Sex} +\calls{pf2Sex1}{pfIdSymbol} +\calls{pf2Sex1}{pfApplication?} +\calls{pf2Sex1}{pfApplication2Sex} +\calls{pf2Sex1}{pfTuple?} +\calls{pf2Sex1}{pf2Sex1} +\calls{pf2Sex1}{pf0TupleParts} +\calls{pf2Sex1}{pfIf?} +\calls{pf2Sex1}{pfIfCond} +\calls{pf2Sex1}{pfIfThen} +\calls{pf2Sex1}{pfIfElse} +\calls{pf2Sex1}{pfTagged?} +\calls{pf2Sex1}{pfTaggedTag} +\calls{pf2Sex1}{pfTaggedExpr} +\calls{pf2Sex1}{pfCoerceto?} +\calls{pf2Sex1}{pfCoercetoExpr} +\calls{pf2Sex1}{pfCoercetoType} +\calls{pf2Sex1}{pfPretend?} +\calls{pf2Sex1}{pfPretendExpr} +\calls{pf2Sex1}{pfPretendType} +\calls{pf2Sex1}{pfFromdom?} +\calls{pf2Sex1}{opTran} +\calls{pf2Sex1}{pfFromdomWhat} +\calls{pf2Sex1}{pfFromdomDomain} +\calls{pf2Sex1}{pfSequence?} +\calls{pf2Sex1}{pfSequence2Sex} +\calls{pf2Sex1}{pfExit?} +\calls{pf2Sex1}{pfExitCond} +\calls{pf2Sex1}{pfExitExpr} +\calls{pf2Sex1}{pfLoop?} +\calls{pf2Sex1}{loopIters2Sex} +\calls{pf2Sex1}{pf0LoopIterators} +\calls{pf2Sex1}{pfCollect?} +\calls{pf2Sex1}{pfCollect2Sex} +\calls{pf2Sex1}{pfForin?} +\calls{pf2Sex1}{pf0ForinLhs} +\calls{pf2Sex1}{pfForinWhole} +\calls{pf2Sex1}{pfWhile?} +\calls{pf2Sex1}{pfWhileCond} +\calls{pf2Sex1}{pfSuchthat?} +\calls{pf2Sex1}{keyedSystemError} +\calls{pf2Sex1}{pfSuchthatCond} +\calls{pf2Sex1}{pfDo?} +\calls{pf2Sex1}{pfDoBody} +\calls{pf2Sex1}{pfTyped?} +\calls{pf2Sex1}{pfTypedType} +\calls{pf2Sex1}{pfNothing?} +\calls{pf2Sex1}{pfTypedId} +\calls{pf2Sex1}{pfTypedType} +\calls{pf2Sex1}{pfAssign?} +\calls{pf2Sex1}{pf0AssignLhsItems} +\calls{pf2Sex1}{pfAssignRhs} +\calls{pf2Sex1}{pfDefinition?} +\calls{pf2Sex1}{pfDefinition2Sex} +\calls{pf2Sex1}{pfLambda?} +\calls{pf2Sex1}{pfLambda2Sex} +\calls{pf2Sex1}{pfMLambda?} +\calls{pf2Sex1}{pfRestrict?} +\calls{pf2Sex1}{pfRestrictExpr} +\calls{pf2Sex1}{pfRestrictType} +\calls{pf2Sex1}{pfFree?} +\calls{pf2Sex1}{pf0FreeItems} +\calls{pf2Sex1}{pfLocal?} +\calls{pf2Sex1}{pf0LocalItems} +\calls{pf2Sex1}{pfWrong?} +\calls{pf2Sex1}{spadThrow} +\calls{pf2Sex1}{pfAnd?} +\calls{pf2Sex1}{pfAndLeft} +\calls{pf2Sex1}{pfAndRight} +\calls{pf2Sex1}{pfOr?} +\calls{pf2Sex1}{pfOrLeft} +\calls{pf2Sex1}{pfOrRight} +\calls{pf2Sex1}{pfNot?} +\calls{pf2Sex1}{pfNotArg} +\calls{pf2Sex1}{pfNovalue?} +\calls{pf2Sex1}{pfNovalueExpr} +\calls{pf2Sex1}{pfRule?} +\calls{pf2Sex1}{pfRule2Sex} +\calls{pf2Sex1}{pfBreak?} +\calls{pf2Sex1}{pfBreakFrom} +\calls{pf2Sex1}{pfMacro?} +\calls{pf2Sex1}{pfReturn?} +\calls{pf2Sex1}{pfReturnExpr} +\calls{pf2Sex1}{pfIterate?} +\calls{pf2Sex1}{pfWhere?} +\calls{pf2Sex1}{pf0WhereContext} +\calls{pf2Sex1}{pfWhereExpr} +\calls{pf2Sex1}{pfAbSynOp} +\calls{pf2Sex1}{tokPart} +\usesdollar{pf2Sex1}{insideSEQ} +\usesdollar{pf2Sex1}{insideRule} +\usesdollar{pf2Sex1}{QuietCommand} +<>= +(defun |pf2Sex1| (pf) + (let (args idList type op tagPart tag s) + (declare (special |$insideSEQ| |$insideRule| |$QuietCommand|)) + (cond + ((|pfNothing?| pf) '|noBranch|) + ((|pfSymbol?| pf) + (if (eq |$insideRule| '|left|) + (progn + (setq s (|pfSymbolSymbol| pf)) + (list '|constant| (list 'quote s))) + (list 'quote (|pfSymbolSymbol| pf)))) + ((|pfLiteral?| pf) (|pfLiteral2Sex| pf)) + ((|pfId?| pf) + (if |$insideRule| + (progn + (setq s (|pfIdSymbol| pf)) + (if (memq s '(|%pi| |%e| |%i|)) + s + (list 'quote s))) + (|pfIdSymbol| pf))) + ((|pfApplication?| pf) (|pfApplication2Sex| pf)) + ((|pfTuple?| pf) (cons '|Tuple| (mapcar #'|pf2Sex1| (|pf0TupleParts| pf)))) + ((|pfIf?| pf) + (list 'if (|pf2Sex1| (|pfIfCond| pf)) + (|pf2Sex1| (|pfIfThen| pf)) + (|pf2Sex1| (|pfIfElse| pf)))) + ((|pfTagged?| pf) + (setq tag (|pfTaggedTag| pf)) + (setq tagPart + (if (|pfTuple?| tag) + (cons '|Tuple| (mapcar #'|pf2Sex1| (|pf0TupleParts| tag))) + (|pf2Sex1| tag))) + (list '|:| tagPart (|pf2Sex1| (|pfTaggedExpr| pf)))) + ((|pfCoerceto?| pf) + (list '|::| (|pf2Sex1| (|pfCoercetoExpr| pf)) + (|pf2Sex1| (|pfCoercetoType| pf)))) + ((|pfPretend?| pf) + (list '|pretend| (|pf2Sex1| (|pfPretendExpr| pf)) + (|pf2Sex1| (|pfPretendType| pf)))) + ((|pfFromdom?| pf) + (setq op (|opTran| (|pf2Sex1| (|pfFromdomWhat| pf)))) + (when (eq op '|braceFromCurly|) (setq op 'seq)) + (list '|$elt| (|pf2Sex1| (|pfFromdomDomain| pf)) op)) + ((|pfSequence?| pf) (|pfSequence2Sex| pf)) + ((|pfExit?| pf) + (if |$insideSEQ| + (list '|exit| (|pf2Sex1| (|pfExitCond| pf)) + (|pf2Sex1| (|pfExitExpr| pf))) + (list 'if (|pf2Sex1| (|pfExitCond| pf)) + (|pf2Sex1| (|pfExitExpr| pf)) '|noBranch|))) + ((|pfLoop?| pf) (cons 'repeat (|loopIters2Sex| (|pf0LoopIterators| pf)))) + ((|pfCollect?| pf) (|pfCollect2Sex| pf)) + ((|pfForin?| pf) + (cons 'in + (append (mapcar #'|pf2Sex1| (|pf0ForinLhs| pf)) + (list (|pf2Sex1| (|pfForinWhole| pf)))))) + ((|pfWhile?| pf) (list 'while (|pf2Sex1| (|pfWhileCond| pf)))) + ((|pfSuchthat?| pf) + (if (eq |$insideRule| '|left|) + (|keyedSystemError| "S2GE0017" (list "pf2Sex1: pfSuchThat")) + (list '|\|| (|pf2Sex1| (|pfSuchthatCond| pf))))) + ((|pfDo?| pf) (|pf2Sex1| (|pfDoBody| pf))) + ((|pfTyped?| pf) + (setq type (|pfTypedType| pf)) + (if (|pfNothing?| type) + (|pf2Sex1| (|pfTypedId| pf)) + (list '|:| (|pf2Sex1| (|pfTypedId| pf)) (|pf2Sex1| (|pfTypedType| pf))))) + ((|pfAssign?| pf) + (setq idList (mapcar #'|pf2Sex1| (|pf0AssignLhsItems| pf))) + (if (not (eql (length idList) 1)) + (setq idList (cons '|Tuple| idList)) + (setq idList (car idList))) + (list 'let idList (|pf2Sex1| (|pfAssignRhs| pf)))) + ((|pfDefinition?| pf) (|pfDefinition2Sex| pf)) + ((|pfLambda?| pf) (|pfLambda2Sex| pf)) + ((|pfMLambda?| pf) '|/throwAway|) + ((|pfRestrict?| pf) + (list '@ (|pf2Sex1| (|pfRestrictExpr| pf)) + (|pf2Sex1| (|pfRestrictType| pf)))) + ((|pfFree?| pf) (cons '|free| (mapcar #'|pf2Sex1| (|pf0FreeItems| pf)))) + ((|pfLocal?| pf) (cons '|local| (mapcar #'|pf2Sex1| (|pf0LocalItems| pf)))) + ((|pfWrong?| pf) (|spadThrow|)) + ((|pfAnd?| pf) + (list '|and| (|pf2Sex1| (|pfAndLeft| pf)) + (|pf2Sex1| (|pfAndRight| pf)))) + ((|pfOr?| pf) + (list '|or| (|pf2Sex1| (|pfOrLeft| pf)) + (|pf2Sex1| (|pfOrRight| pf)))) + ((|pfNot?| pf) (list '|not| (|pf2Sex1| (|pfNotArg| pf)))) + ((|pfNovalue?| pf) + (setq |$QuietCommand| t) + (list 'seq (|pf2Sex1| (|pfNovalueExpr| pf)))) + ((|pfRule?| pf) (|pfRule2Sex| pf)) + ((|pfBreak?| pf) (list '|break| (|pfBreakFrom| pf))) + ((|pfMacro?| pf) '|/throwAway|) + ((|pfReturn?| pf) (list '|return| (|pf2Sex1| (|pfReturnExpr| pf)))) + ((|pfIterate?| pf) (list '|iterate|)) + ((|pfWhere?| pf) + (setq args (mapcar #'|pf2Sex1| (|pf0WhereContext| pf))) + (if (eql (length args) 1) + (cons '|where| (cons (|pf2Sex1| (|pfWhereExpr| pf)) args)) + (list '|where| (|pf2Sex1| (|pfWhereExpr| pf)) (cons 'seq args)))) +; -- under strange circumstances/piling, system commands can wind +; -- up in expressions. This just passes it through as a string for +; -- the user to figure out what happened. + ((eq (|pfAbSynOp| pf) '|command|) (|tokPart| pf)) + (t (|keyedSystemError| "S2GE0017" (list "pf2Sex1")))))) + +@ + +\defun{pfLiteral2Sex}{Convert a Literal to an S-expression} +\calls{pfLiteral2Sex}{pfLiteralClass} +\calls{pfLiteral2Sex}{pfLiteralString} +\calls{pfLiteral2Sex}{float2Sex} +\calls{pfLiteral2Sex}{pfSymbolSymbol} +\calls{pfLiteral2Sex}{pfLeafToken} +\calls{pfLiteral2Sex}{keyedSystemError} +\usesdollar{pfLiteral2Sex}{insideRule} +<>= +(defun |pfLiteral2Sex| (|pf|) + (let (|s| |type|) + (declare (special |$insideRule|)) + (setq |type| (|pfLiteralClass| |pf|)) + (cond + ((eq |type| '|integer|) (read-from-string (|pfLiteralString| |pf|))) + ((or (eq |type| '|string|) (eq |type| '|char|)) + (|pfLiteralString| |pf|)) + ((eq |type| '|float|) (|float2Sex| (|pfLiteralString| |pf|))) + ((eq |type| '|symbol|) + (if |$insideRule| + (progn + (setq |s| (|pfSymbolSymbol| |pf|)) + (list 'quote |s|)) + (|pfSymbolSymbol| |pf|))) + ((eq |type| '|expression|) (list 'quote (|pfLeafToken| |pf|))) + (t + (|keyedSystemError| 'S2GE0017 (list "pfLiteral2Sex: unexpected form")))))) + +@ + +\defun{pfApplication2Sex}{Change an Application node to an S-expression} +\calls{pfApplication2Sex}{pfOp2Sex} +\calls{pfApplication2Sex}{pfApplicationOp} +\calls{pfApplication2Sex}{opTran} +\calls{pfApplication2Sex}{pf0TupleParts} +\calls{pfApplication2Sex}{pfApplicationArg} +\calls{pfApplication2Sex}{pfTuple?} +\calls{pfApplication2Sex}{pf2Sex1} +\calls{pfApplication2Sex}{pf2Sex} +\calls{pfApplication2Sex}{pfSuchThat2Sex} +\calls{pfApplication2Sex}{hasOptArgs?} +\usesdollar{pfApplication2Sex}{insideApplication} +\usesdollar{pfApplication2Sex}{insideRule} +<>= +(defun |pfApplication2Sex| (pf) + (let (|$insideApplication| x val realOp tmp1 qt argSex typeList args op) + (declare (special |$insideApplication| |$insideRule|)) + (setq |$insideApplication| t) + (setq op (|pfOp2Sex| (|pfApplicationOp| pf))) + (setq op (|opTran| op)) + (cond + ((eq op '->) + (setq args (|pf0TupleParts| (|pfApplicationArg| pf))) + (if (|pfTuple?| (car args)) + (setq typeList (mapcar #'|pf2Sex1| (|pf0TupleParts| (car args)))) + (setq typeList (list (|pf2Sex1| (car args))))) + (setq args (cons (|pf2Sex1| (cadr args)) typeList)) + (cons '|Mapping| args)) + ((and (eq op '|:|) (eq |$insideRule| '|left|)) + (list '|multiple| (|pf2Sex| (|pfApplicationArg| pf)))) + ((and (eq op '?) (eq |$insideRule| '|left|)) + (list '|optional| (|pf2Sex| (|pfApplicationArg| pf)))) + (t + (setq args (|pfApplicationArg| pf)) + (cond + ((|pfTuple?| args) + (if (and (eq op '|\||) (eq |$insideRule| '|left|)) + (|pfSuchThat2Sex| args) + (progn + (setq argSex (cdr (|pf2Sex1| args))) + (cond + ((eq op '>) (list '< (cadr argSex) (car argSex))) + ((eq op '>=) (list '|not| (list '< (car argSex) (cadr argSex)))) + ((eq op '<=) (list '|not| (list '< (cadr argSex) (car argSex)))) + ((eq op 'and) (list '|and| (car argSex) (cadr argSex))) + ((eq op 'or) (list '|or| (car argSex) (cadr argSex))) + ((eq op '|Iterate|) (list '|iterate|)) + ((eq op '|by|) (cons 'by argSex)) + ((eq op '|braceFromCurly|) + (if (and (consp argSex) (eq (car argSex) 'seq)) + argSex + (cons 'seq argSex))) + ((and (consp op) + (progn + (setq qt (car op)) + (setq tmp1 (cdr op)) + (and (consp tmp1) + (eq (cdr tmp1) nil) + (progn + (setq realOp (car tmp1)) + t))) + (eq qt 'quote)) + (cons '|applyQuote| (cons op argSex))) + ((setq val (|hasOptArgs?| argSex)) (cons op val)) + (t (cons op argSex)))))) + ((and (consp op) + (progn + (setq qt (car op)) + (setq tmp1 (cdr op)) + (and (consp tmp1) + (eq (cdr tmp1) NIL) + (progn + (setq realOp (car tmp1)) + t))) + (eq qt 'quote)) + (list '|applyQuote| op (|pf2Sex1| args))) + ((eq op '|braceFromCurly|) + (setq x (|pf2Sex1| args)) + (if (and (consp x) (eq (car x) 'seq)) + x + (list 'seq x))) + ((eq op '|by|) (list 'by (|pf2Sex1| args))) + (t (list op (|pf2Sex1| args)))))))) + +@ + +\defun{pfSequence2Sex}{Convert a Sequence node to an S-expression} +\calls{pfSequence2Sex}{pf2Sex1} +\calls{pfSequence2Sex}{pf0SequenceArgs} +\usesdollar{pfSequence2Sex}{insideSEQ} +<>= +(defun |pfSequence2Sex| (pf) + (let (|$insideSEQ| tmp1 ruleList seq) + (declare (special |$insideSEQ|)) + (setq |$insideSEQ| t) + (setq seq (|pfSequence2Sex0| (mapcar #'|pf2Sex1| (|pf0SequenceArgs| pf)))) + (cond + ((and (consp seq) + (eq (car seq) 'seq) + (progn (setq ruleList (cdr seq)) 't) + (consp ruleList) + (progn + (setq tmp1 (car ruleList)) + (and (consp tmp1) (eq (car tmp1) '|rule|)))) + (list '|ruleset| (cons '|construct| ruleList))) + (t seq)))) + +@ + +\defun{pfSequence2Sex0}{pfSequence2Sex0} +\tpdhere{rewrite this using (dolist (item seqList)...)} +\begin{verbatim} +;pfSequence2Sex0 seqList == +; null seqList => "noBranch" +; seqTranList := [] +; while seqList ^= nil repeat +; item := first seqList +; item is ["exit", cond, value] => +; item := ["IF", cond, value, pfSequence2Sex0 rest seqList] +; seqTranList := [item, :seqTranList] +; seqList := nil +; seqTranList := [item ,:seqTranList] +; seqList := rest seqList +; #seqTranList = 1 => first seqTranList +; ["SEQ", :nreverse seqTranList] +\end{verbatim} +\calls{pfSequence2Sex0}{pfSequence2Sex0} +<>= +(defun |pfSequence2Sex0| (seqList) + (let (value tmp2 cond tmp1 item seqTranList) + (if (null seqList) + '|noBranch| + (progn + ((lambda () + (loop + (if (not seqList) + (return nil) + (progn + (setq item (car seqList)) + (cond + ((and (consp item) + (eq (car item) '|exit|) + (progn + (setq tmp1 (cdr item)) + (and (consp tmp1) + (progn + (setq cond (car tmp1)) + (setq tmp2 (cdr tmp1)) + (and (consp tmp2) + (eq (cdr tmp2) nil) + (progn + (setq value (car tmp2)) + t)))))) + (setq item + (list 'if cond value (|pfSequence2Sex0| (cdr seqList)))) + (setq seqTranList (cons item seqTranList)) + (setq seqList nil)) + (t + (progn + (setq seqTranList (cons item seqTranList)) + (setq seqList (cdr seqList)))))))))) + (if (eql (length seqTranList) 1) + (car seqTranList) + (cons 'seq (nreverse seqTranList))))))) + +@ + +\defun{loopIters2Sex}{Convert a loop node to an S-expression} +\tpdhere{rewrite using dsetq} +\begin{verbatim} +;loopIters2Sex iterList == +; result := nil +; for iter in iterList repeat +; sex := pf2Sex1 iter +; sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => +; result := [ ['STEP, var, i, incr], :result] +; sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => +; result := [ ['STEP, var, i, incr, j], :result] +; sex is ['IN, var, ['SEGMENT, i, j]] => +; result := [ ['STEP, var, i, 1, j], :result] +; result := [sex, :result] +; nreverse result +\end{verbatim} +\calls{loopIters2Sex}{pf2Sex1} +<>= +(DEFUN |loopIters2Sex| (|iterList|) + (PROG (|ISTMP#8| |j| |incr| |ISTMP#7| |ISTMP#6| |ISTMP#5| |i| + |ISTMP#4| |ISTMP#3| |ISTMP#2| |var| |ISTMP#1| |sex| + |result|) + (RETURN + (PROGN + (SETQ |result| NIL) + ((LAMBDA (|bfVar#27| |iter|) + (LOOP + (COND + ((OR (ATOM |bfVar#27|) + (PROGN (SETQ |iter| (CAR |bfVar#27|)) NIL)) + (RETURN NIL)) + ('T + (PROGN + (SETQ |sex| (|pf2Sex1| |iter|)) + (COND + ((AND (CONSP |sex|) (EQ (CAR |sex|) 'IN) + (PROGN + (SETQ |ISTMP#1| (CDR |sex|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |var| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |ISTMP#3| (CAR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CAR |ISTMP#3|) 'SEGMENT) + (PROGN + (SETQ |ISTMP#4| + (CDR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (PROGN + (SETQ |i| (CAR |ISTMP#4|)) + (SETQ |ISTMP#5| + (CDR |ISTMP#4|)) + (AND (CONSP |ISTMP#5|) + (EQ (CDR |ISTMP#5|) NIL) + (PROGN + (SETQ |ISTMP#6| + (CAR |ISTMP#5|)) + (AND (CONSP |ISTMP#6|) + (EQ (CAR |ISTMP#6|) + 'BY) + (PROGN + (SETQ |ISTMP#7| + (CDR |ISTMP#6|)) + (AND + (CONSP |ISTMP#7|) + (EQ (CDR |ISTMP#7|) + NIL) + (PROGN + (SETQ |incr| + (CAR |ISTMP#7|)) + 'T)))))))))))))))) + (SETQ |result| + (CONS (LIST 'STEP |var| |i| |incr|) + |result|))) + ((AND (CONSP |sex|) (EQ (CAR |sex|) 'IN) + (PROGN + (SETQ |ISTMP#1| (CDR |sex|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |var| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |ISTMP#3| (CAR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CAR |ISTMP#3|) 'BY) + (PROGN + (SETQ |ISTMP#4| + (CDR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (PROGN + (SETQ |ISTMP#5| + (CAR |ISTMP#4|)) + (AND (CONSP |ISTMP#5|) + (EQ (CAR |ISTMP#5|) + 'SEGMENT) + (PROGN + (SETQ |ISTMP#6| + (CDR |ISTMP#5|)) + (AND (CONSP |ISTMP#6|) + (PROGN + (SETQ |i| + (CAR |ISTMP#6|)) + (SETQ |ISTMP#7| + (CDR |ISTMP#6|)) + (AND + (CONSP |ISTMP#7|) + (EQ (CDR |ISTMP#7|) + NIL) + (PROGN + (SETQ |j| + (CAR |ISTMP#7|)) + 'T))))))) + (PROGN + (SETQ |ISTMP#8| + (CDR |ISTMP#4|)) + (AND (CONSP |ISTMP#8|) + (EQ (CDR |ISTMP#8|) NIL) + (PROGN + (SETQ |incr| + (CAR |ISTMP#8|)) + 'T)))))))))))) + (SETQ |result| + (CONS (LIST 'STEP |var| |i| |incr| |j|) + |result|))) + ((AND (CONSP |sex|) (EQ (CAR |sex|) 'IN) + (PROGN + (SETQ |ISTMP#1| (CDR |sex|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |var| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN + (SETQ |ISTMP#3| (CAR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CAR |ISTMP#3|) 'SEGMENT) + (PROGN + (SETQ |ISTMP#4| + (CDR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (PROGN + (SETQ |i| (CAR |ISTMP#4|)) + (SETQ |ISTMP#5| + (CDR |ISTMP#4|)) + (AND (CONSP |ISTMP#5|) + (EQ (CDR |ISTMP#5|) NIL) + (PROGN + (SETQ |j| + (CAR |ISTMP#5|)) + 'T)))))))))))) + (SETQ |result| + (CONS (LIST 'STEP |var| |i| 1 |j|) |result|))) + ('T (SETQ |result| (CONS |sex| |result|))))))) + (SETQ |bfVar#27| (CDR |bfVar#27|)))) + |iterList| NIL) + (NREVERSE |result|))))) +;(defun |loopIters2Sex| (iterList) +; (let (j incr i var sex result tmp1 tmp2 tmp3 tmp4 tmp5 tmp6 tmp7 tmp8) +; (dolist (iter iterList (nreverse result)) +; (setq sex (|pf2Sex1| iter)) +; (cond +; ((and (consp sex) +; (eq (car sex) 'in) +; (progn +; (setq tmp1 (cdr sex)) +; (and (consp tmp1) +; (progn +; (setq var (car tmp1)) +; (setq tmp2 (cdr tmp1)) +; (and (consp tmp2) +; (eq (cdr tmp2) nil) +; (progn +; (setq tmp3 (car tmp2)) +; (and (consp tmp3) +; (eq (car tmp3) 'segment) +; (progn +; (setq tmp4 (cdr tmp3)) +; (and (consp tmp4) +; (progn +; (setq i (car tmp4)) +; (setq tmp5 (cdr tmp4)) +; (and (consp tmp5) +; (eq (cdr tmp5) nil) +; (progn +; (setq tmp6 (car tmp5)) +; (and (consp tmp6) +; (eq (car tmp6) 'by) +; (progn +; (setq tmp7 (cdr tmp6)) +; (and (consp tmp7) +; (eq (cdr tmp7) nil) +; (progn +; (setq incr (car tmp7)) +; t)))))))))))))))) +; (setq result (cons (list 'step var i incr) result))) +; ((and (consp sex) +; (eq (car sex) 'in) +; (progn +; (setq tmp1 (cdr sex)) +; (and (consp tmp1) +; (progn +; (setq var (car tmp1)) +; (setq tmp2 (cdr tmp1)) +; (and (consp tmp2) +; (eq (cdr tmp2) nil) +; (progn +; (setq tmp3 (car tmp2)) +; (and (consp tmp3) +; (eq (car tmp3) 'by) +; (progn +; (setq tmp4 (cdr tmp3)) +; (and (consp tmp4) +; (progn +; (setq tmp5 (car tmp4)) +; (and (consp tmp5) +; (eq (car tmp5) 'segment) +; (progn +; (setq tmp6 (cdr tmp5)) +; (and (consp tmp6) +; (progn +; (setq i (car tmp6)) +; (setq tmp7 (cdr tmp6)) +; (and (consp tmp7) +; (eq (cdr tmp7) nil) +; (progn +; (setq j (car tmp7)) +; t))))))) +; (progn +; (setq tmp8 (cdr tmp4)) +; (and (consp tmp8) +; (eq (cdr tmp8) nil) +; (progn +; (setq incr (car tmp8)) +; t)))))))))))) +; (setq result (cons (list 'step var i incr j) result))) +; ((and (consp sex) +; (eq (car sex) 'in) +; (progn +; (setq tmp1 (cdr sex)) +; (and (consp tmp1) +; (progn +; (setq var (car tmp1)) +; (setq tmp2 (cdr tmp1)) +; (and (consp tmp2) +; (eq (cdr tmp2) nil) +; (progn +; (setq tmp3 (car tmp2)) +; (and (consp tmp3) +; (eq (car tmp3) 'segment) +; (progn +; (setq tmp4 (cdr tmp3)) +; (and (consp tmp4) +; (progn +; (setq i (car tmp4)) +; (setq tmp5 (cdr tmp4)) +; (and (consp tmp5) +; (eq (cdr tmp5) nil) +; (progn +; (setq j (car tmp5)) +; t)))))))))))) +; (setq result (cons (list 'step var i 1 j) result))) +; (t (setq result (cons sex result))))))) + +@ + +\defun{opTran}{Translate ops into internal symbols} +\usesdollar{opTran}{dotdot} +<>= +(defun |opTran| (op) + (declare (special |$dotdot|)) + (cond + ((equal op |$dotdot|) 'segment) + ((eq op '[]) '|construct|) + ((eq op '{}) '|braceFromCurly|) + ((eq op 'is) '|is|) + (t op))) + +@ + \chapter{Keyed Message Handling} Throughout the interpreter there are messages printed using a symbol for a database lookup. This was done to enable translation of these @@ -14101,8 +15044,8 @@ environment to \verb|$HistList| and \verb|$HistRecord|. (setq |$HistListLen| 20) (setq |$HistList| (list nil)) (setq li |$HistList|) - (do ((|i| 1 (qsadd1 |i|))) - ((qsgreaterp |i| |$HistListLen|) nil) + (do ((i 1 (qsadd1 i))) + ((qsgreaterp i |$HistListLen|) nil) (setq li (cons nil li))) (rplacd |$HistList| li) (setq |$HistListAct| 0) @@ -14285,11 +15228,11 @@ file and then write the in-memory history to a new file (cond ((nequal |$IOindex| 0) (setq l (length (rkeyids (|histFileName|)))) - (do ((|i| 1 (qsadd1 |i|))) - ((qsgreaterp |i| l) nil) - (setq vec (unwind-protect (|readHiFi| |i|) (|disableHist|))) + (do ((i 1 (qsadd1 i))) + ((qsgreaterp i l) nil) + (setq vec (unwind-protect (|readHiFi| i) (|disableHist|))) (setq |$internalHistoryTable| - (cons (cons |i| vec) |$internalHistoryTable|))) + (cons (cons i vec) |$internalHistoryTable|))) (|histFileErase| (|histFileName|)))) (setq |$useInternalHistoryTable| t) (|sayKeyedMsg| 'S2IH0032 nil)) ; use memory history @@ -14360,18 +15303,18 @@ Also used in the output routines. (setq maxn 72) (setq breakChars (cons '| | (cons '+ nil))) (do ((tmp0 (spaddifference |$IOindex| 1)) - (|i| initial (+ |i| 1))) - ((> |i| tmp0) nil) - (setq vecl (car (|readHiFi| |i|))) + (i initial (+ i 1))) + ((> i tmp0) nil) + (setq vecl (car (|readHiFi| i))) (when (stringp vecl) (setq vecl (cons vecl nil))) (dolist (vec vecl) (setq n (size vec)) (do () ((null (> n maxn)) nil) (setq done nil) - (do ((|j| 1 (qsadd1 |j|))) - ((or (qsgreaterp |j| maxn) (null (null done))) nil) - (setq k (spaddifference (1+ maxn) |j|)) + (do ((j 1 (qsadd1 j))) + ((or (qsgreaterp j maxn) (null (null done))) nil) + (setq k (spaddifference (1+ maxn) j)) (when (memq (elt vec k) breakChars) (setq svec (concat (substring vec 0 (1+ k)) underbar)) (setq lineList (cons svec lineList)) @@ -14405,8 +15348,8 @@ Also used in the output routines. (defun |resetInCoreHist| () (declare (special |$HistListAct| |$HistListLen| |$HistList|)) (setq |$HistListAct| 0) - (do ((|i| 1 (qsadd1 |i|))) - ((qsgreaterp |i| |$HistListLen|) nil) + (do ((i 1 (qsadd1 i))) + ((qsgreaterp i |$HistListLen|) nil) (setq |$HistList| (cdr |$HistList|)) (rplaca |$HistList| nil))) @@ -14429,13 +15372,13 @@ Also used in the output routines. (setq l (cdr |$HistList|)) (cond ((> dif 0) - (do ((|i| 1 (qsadd1 |i|))) - ((qsgreaterp |i| dif) nil) + (do ((i 1 (qsadd1 i))) + ((qsgreaterp i dif) nil) (setq l (cons nil l)))) ((minusp dif) (do ((tmp0 (spaddifference dif)) - (|i| 1 (qsadd1 |i|))) - ((qsgreaterp |i| tmp0) nil) + (i 1 (qsadd1 i))) + ((qsgreaterp i tmp0) nil) (setq l (cdr l))) (cond ((> |$HistListAct| n) (setq |$HistListAct| n)) @@ -14651,10 +15594,10 @@ Also used in the output routines. (when |$HiFiAccess| (|recordNewValue| x prop val)) (rplacd p nil)))))))))) - (do ((|i| 1 (qsadd1 |i|))) - ((qsgreaterp |i| n) nil) + (do ((i 1 (qsadd1 i))) + ((qsgreaterp i n) nil) (setq vec - (unwind-protect (cdr (|readHiFi| |i|)) (|disableHist|))) + (unwind-protect (cdr (|readHiFi| i)) (|disableHist|))) (do ((tmp3 vec (cdr tmp3)) (p1 nil)) ((or (atom tmp3) (progn (setq p1 (car tmp3)) nil)) nil) (setq x (car p1)) @@ -14793,12 +15736,12 @@ Also used in the output routines. (setq oldInternal |$useInternalHistoryTable|) (setq |$useInternalHistoryTable| nil) (when oldInternal (setq |$internalHistoryTable| nil)) - (do ((|i| 1 (qsadd1 |i|))) - ((qsgreaterp |i| l) nil) - (setq vec (unwind-protect (|readHiFi| |i|) (|disableHist|))) + (do ((i 1 (qsadd1 i))) + ((qsgreaterp i l) nil) + (setq vec (unwind-protect (|readHiFi| i) (|disableHist|))) (when oldInternal (setq |$internalHistoryTable| - (cons (cons |i| vec) |$internalHistoryTable|))) + (cons (cons i vec) |$internalHistoryTable|))) (setq line (car vec)) (dolist (p1 (cdr vec)) (setq x (car p1)) @@ -15228,9 +16171,9 @@ back. (setq nob (make-array (1+ n))) (hput |$seen| ob nob) (hput |$seen| nob nob) - (do ((|i| 0 (qsadd1 |i|))) - ((qsgreaterp |i| n) nil) - (qsetvelt nob |i| (|writify,writifyInner| (qvelt ob |i|)))) + (do ((i 0 (qsadd1 i))) + ((qsgreaterp i n) nil) + (qsetvelt nob i (|writify,writifyInner| (qvelt ob i)))) (exit nob)))) (when (eq ob 'writified!!) (exit @@ -15488,12 +16431,12 @@ back. (setq nob (make-array (1+ n))) (hput |$seen| ob nob) (hput |$seen| nob nob) - (do ((|i| 0 (qsadd1 |i|))) - ((qsgreaterp |i| n) nil) + (do ((i 0 (qsadd1 i))) + ((qsgreaterp i n) nil) (seq (exit - (qsetvelt nob |i| - (|dewritify,dewritifyInner| (qvelt ob |i|)))))) + (qsetvelt nob i + (|dewritify,dewritifyInner| (qvelt ob i)))))) (exit nob)))) (exit ob))))) @@ -15536,9 +16479,9 @@ back. (|ScanOrPairVec,ScanOrInner| f (qcdr ob))) (when (vecp ob) (hput |$seen| ob t) - (do ((tmp0 (spaddifference (|#| ob) 1)) (|i| 0 (qsadd1 |i|))) - ((qsgreaterp |i| tmp0) nil) - (|ScanOrPairVec,ScanOrInner| f (elt ob |i|)))) + (do ((tmp0 (spaddifference (|#| ob) 1)) (i 0 (qsadd1 i))) + ((qsgreaterp i tmp0) nil) + (|ScanOrPairVec,ScanOrInner| f (elt ob i)))) (when (funcall f ob) (throw '|ScanOrPairVecAnswer| t)) nil) @@ -15570,9 +16513,9 @@ back. (progn (setq p (pname g)) (setq n 0) - (do ((tmp0 (spaddifference (|#| p) 1)) (|i| 2 (qsadd1 |i|))) - ((qsgreaterp |i| tmp0) nil) - (setq n (+ (times 10 n) (|charDigitVal| (elt p |i|))))) + (do ((tmp0 (spaddifference (|#| p) 1)) (i 2 (qsadd1 i))) + ((qsgreaterp i tmp0) nil) + (setq n (+ (times 10 n) (|charDigitVal| (elt p i))))) n)))) @ @@ -15584,10 +16527,10 @@ back. (let (digits n) (setq digits "0123456789") (setq n (spaddifference 1)) - (do ((tmp0 (spaddifference (|#| digits) 1)) (|i| 0 (qsadd1 |i|))) - ((or (qsgreaterp |i| tmp0) (null (minusp n))) nil) - (if (char= c (elt digits |i|)) - (setq n |i|) + (do ((tmp0 (spaddifference (|#| digits) 1)) (i 0 (qsadd1 i))) + ((or (qsgreaterp i tmp0) (null (minusp n))) nil) + (if (char= c (elt digits i)) + (setq n i) nil)) (if (minusp n) (|error| "Character is not a digit") @@ -23637,21 +24580,21 @@ synonyms at the current user level. (setq |line| (|dropLeadingBlanks| |line|)) (setq |mx| (maxindex |line|)) (exit - (do ((|i| 0 (qsadd1 |i|))) - ((qsgreaterp |i| |mx|) nil) + (do ((i 0 (qsadd1 i))) + ((qsgreaterp i |mx|) nil) (seq (exit - (if (char= (elt |line| |i|) #\space) + (if (char= (elt |line| i) #\space) (exit (return - (do ((|j| (PLUS |i| 1) (+ |j| 1))) - ((> |j| |mx|) nil) + (do ((j (PLUS i 1) (+ j 1))) + ((> j |mx|) nil) (seq (exit - (if (char\= (elt |line| |j|) #\space) + (if (char\= (elt |line| j) #\space) (exit (return - (substring |line| |j| nil)))))))))))))))))) + (substring |line| j nil)))))))))))))))))) @ @@ -27027,8 +27970,8 @@ Properties of r :: (|writeInputLines| '|redo| (spaddifference |$IOindex| m)) (|recordFrame| '|normal|) (setq env (copy (caar |$InteractiveFrame|))) - (do ((|i| 0 (qsadd1 |i|)) (framelist |$frameRecord| (cdr framelist))) - ((or (qsgreaterp |i| m) (atom framelist)) nil) + (do ((i 0 (qsadd1 i)) (framelist |$frameRecord| (cdr framelist))) + ((or (qsgreaterp i m) (atom framelist)) nil) (setq env (|undoSingleStep| (CAR framelist) env)) (if (and (pairp framelist) (progn @@ -32968,6 +33911,7 @@ This needs to work off the internal exposure list, not the file. <> <> <> +<> <> <> @@ -33086,6 +34030,7 @@ This needs to work off the internal exposure list, not the file. <> <> <> +<> <> <> @@ -33098,9 +34043,44 @@ This needs to work off the internal exposure list, not the file. <> <> <> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> <> <> <> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> <> <> <> diff --git a/changelog b/changelog index fe26a10..e6a5f09 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20100207 tpd src/axiom-website/patches.html 20100207.01.tpd.patch +20100207 tpd src/interp/ptrees.lisp treeshake +20100207 tpd src/interp/pf2sex.lisp treeshake +20100207 tpd books/bookvol5 treeshake ptrees, pf2sex 20100203 tpd src/axiom-website/patches.html 20100203.01.tpd.patch 20100203 tpd src/interp/Makefile remove monitor.lisp 20100203 tpd src/interp/monitor.lisp removed diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index cf65fd3..45d4281 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2439,5 +2439,7 @@ books/bookvol5 merge and remove compat.lisp
books/bookvol5 merge and remove intint.lisp
20100203.01.tpd.patch books/bookvol5 merge and remove monitor.lisp
+20100207.01.tpd.patch +books/bookvol5 treeshake ptrees, pf2sex
diff --git a/src/interp/pf2sex.lisp.pamphlet b/src/interp/pf2sex.lisp.pamphlet index 0ac0f49..78d08fa 100644 --- a/src/interp/pf2sex.lisp.pamphlet +++ b/src/interp/pf2sex.lisp.pamphlet @@ -64,402 +64,6 @@ Value = NIL (EVAL-WHEN (EVAL LOAD) (SETQ |$specificMsgTags| NIL)) -;-- 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 -; -;pf2Sex pf == -; intUnsetQuiet() -; $insideRule:local := false -; $insideApplication: local := false -; $insideSEQ: local := false -; pf2Sex1 pf - -(defun |pf2Sex| (|pf|) - (let (|$insideSEQ| |$insideApplication| |$insideRule|) - (declare (special |$insideSEQ| |$insideApplication| |$insideRule| - |$QuietCommand|)) - (setq |$QuietCommand| nil) - (setq |$insideRule| nil) - (setq |$insideApplication| nil) - (setq |$insideSEQ| nil) - (|pf2Sex1| |pf|))) - -;pf2Sex1 pf == -; pfNothing? pf => -; "noBranch" -; pfSymbol? pf => -; $insideRule = 'left => -; s := pfSymbolSymbol pf -; ["constant", ["QUOTE", s]] -; ["QUOTE", pfSymbolSymbol pf] -; pfLiteral? pf => -; pfLiteral2Sex pf -; pfId? pf => -; $insideRule => -; s := pfIdSymbol pf -; SymMemQ(s, '(%pi %e %i)) => s -; ["QUOTE", s] -; pfIdSymbol pf -; pfApplication? pf => -; pfApplication2Sex pf -; pfTuple? pf => -; ["Tuple", :[pf2Sex1 x for x in pf0TupleParts pf]] -; pfIf? pf => -; ['IF, pf2Sex1 pfIfCond pf, pf2Sex1 pfIfThen pf, pf2Sex1 pfIfElse pf] -; pfTagged? pf => -; tag := pfTaggedTag pf -; tagPart := -; pfTuple? tag => -; ['Tuple, :[pf2Sex1 arg for arg in pf0TupleParts tag]] -; pf2Sex1 tag -; [":", tagPart, pf2Sex1 pfTaggedExpr pf] -; pfCoerceto? pf => -; ["::", pf2Sex1 pfCoercetoExpr pf, pf2Sex1 pfCoercetoType pf] -; pfPretend? pf => -; ["pretend", pf2Sex1 pfPretendExpr pf, pf2Sex1 pfPretendType pf] -; pfFromdom? pf => -; op := opTran pf2Sex1 pfFromdomWhat pf -;-- if op = "braceFromCurly" then op := "brace" -; if op = "braceFromCurly" then op := "SEQ" -; ["$elt", pf2Sex1 pfFromdomDomain pf, op] -; pfSequence? pf => -; pfSequence2Sex pf -; pfExit? pf => -; $insideSEQ => ["exit", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf] -; ["IF", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf, "noBranch"] -; pfLoop? pf => -; ["REPEAT", :loopIters2Sex pf0LoopIterators pf] -; pfCollect? pf => -; pfCollect2Sex pf -; pfForin? pf => -; ["IN", :[pf2Sex1 x for x in pf0ForinLhs pf], pf2Sex1 pfForinWhole pf] -; pfWhile? pf => -; ["WHILE", pf2Sex1 pfWhileCond pf] -; pfSuchthat? pf => -; $insideRule = 'left => -; keyedSystemError('"S2GE0017", ['"pf2Sex1: pfSuchThat"]) -; ["|", pf2Sex1 pfSuchthatCond pf] -; pfDo? pf => -; pf2Sex1 pfDoBody pf -; pfTyped? pf => -; type := pfTypedType pf -; pfNothing? type => pf2Sex1 pfTypedId pf -; [":", pf2Sex1 pfTypedId pf, pf2Sex1 pfTypedType pf] -; pfAssign? pf => -; idList := [pf2Sex1 x for x in pf0AssignLhsItems pf] -; if #idList ^= 1 then idList := ['Tuple, :idList] -; else idList := first idList -; ["LET", idList, pf2Sex1 pfAssignRhs pf] -; pfDefinition? pf => -; pfDefinition2Sex pf -; pfLambda? pf => -; pfLambda2Sex pf -; pfMLambda? pf => -; "/throwAway" -; pfRestrict? pf => -; ["@", pf2Sex1 pfRestrictExpr pf, pf2Sex1 pfRestrictType pf] -; pfFree? pf => -; ['free, :[pf2Sex1 item for item in pf0FreeItems pf]] -; pfLocal? pf => -; ['local, :[pf2Sex1 item for item in pf0LocalItems pf]] -; pfWrong? pf => -; spadThrow() -; pfAnd? pf => -; ["and", pf2Sex1 pfAndLeft pf, pf2Sex1 pfAndRight pf] -; pfOr? pf => -; ["or", pf2Sex1 pfOrLeft pf, pf2Sex1 pfOrRight pf] -; pfNot? pf => -; ["not", pf2Sex1 pfNotArg pf] -; pfNovalue? pf => -; intSetQuiet() -; ["SEQ", pf2Sex1 pfNovalueExpr pf] -; pfRule? pf => -; pfRule2Sex pf -; pfBreak? pf => -; ["break", pfBreakFrom pf] -; pfMacro? pf => -; "/throwAway" -; pfReturn? pf => -; ["return", pf2Sex1 pfReturnExpr pf] -; pfIterate? pf => -; ["iterate"] -; pfWhere? pf => -; args := [pf2Sex1 p for p in pf0WhereContext pf] -; #args = 1 => -; ["where", pf2Sex1 pfWhereExpr pf, :args] -; ["where", pf2Sex1 pfWhereExpr pf, ["SEQ", :args]] -; -; -- under strange circumstances/piling, system commands can wind -; -- up in expressions. This just passes it through as a string for -; -- the user to figure out what happened. -; pfAbSynOp(pf) = "command" => tokPart(pf) -; -; keyedSystemError('"S2GE0017", ['"pf2Sex1"]) - -(DEFUN |pf2Sex1| (|pf|) - (PROG (|args| |idList| |type| |op| |tagPart| |tag| |s|) - (DECLARE (SPECIAL |$insideSEQ| |$insideRule| |$QuietCommand|)) - (RETURN - (COND - ((|pfNothing?| |pf|) '|noBranch|) - ((|pfSymbol?| |pf|) - (COND - ((EQ |$insideRule| '|left|) - (PROGN - (SETQ |s| (|pfSymbolSymbol| |pf|)) - (LIST '|constant| (LIST 'QUOTE |s|)))) - ('T (LIST 'QUOTE (|pfSymbolSymbol| |pf|))))) - ((|pfLiteral?| |pf|) (|pfLiteral2Sex| |pf|)) - ((|pfId?| |pf|) - (COND - (|$insideRule| - (PROGN - (SETQ |s| (|pfIdSymbol| |pf|)) - (COND - ((|SymMemQ| |s| '(|%pi| |%e| |%i|)) |s|) - ('T (LIST 'QUOTE |s|))))) - ('T (|pfIdSymbol| |pf|)))) - ((|pfApplication?| |pf|) (|pfApplication2Sex| |pf|)) - ((|pfTuple?| |pf|) - (CONS '|Tuple| - ((LAMBDA (|bfVar#2| |bfVar#1| |x|) - (LOOP - (COND - ((OR (ATOM |bfVar#1|) - (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)) - (RETURN (NREVERSE |bfVar#2|))) - ('T - (SETQ |bfVar#2| - (CONS (|pf2Sex1| |x|) |bfVar#2|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - NIL (|pf0TupleParts| |pf|) NIL))) - ((|pfIf?| |pf|) - (LIST 'IF (|pf2Sex1| (|pfIfCond| |pf|)) - (|pf2Sex1| (|pfIfThen| |pf|)) - (|pf2Sex1| (|pfIfElse| |pf|)))) - ((|pfTagged?| |pf|) - (PROGN - (SETQ |tag| (|pfTaggedTag| |pf|)) - (SETQ |tagPart| - (COND - ((|pfTuple?| |tag|) - (CONS '|Tuple| - ((LAMBDA (|bfVar#4| |bfVar#3| |arg|) - (LOOP - (COND - ((OR (ATOM |bfVar#3|) - (PROGN - (SETQ |arg| (CAR |bfVar#3|)) - NIL)) - (RETURN (NREVERSE |bfVar#4|))) - ('T - (SETQ |bfVar#4| - (CONS (|pf2Sex1| |arg|) - |bfVar#4|)))) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - NIL (|pf0TupleParts| |tag|) NIL))) - ('T (|pf2Sex1| |tag|)))) - (LIST '|:| |tagPart| (|pf2Sex1| (|pfTaggedExpr| |pf|))))) - ((|pfCoerceto?| |pf|) - (LIST '|::| (|pf2Sex1| (|pfCoercetoExpr| |pf|)) - (|pf2Sex1| (|pfCoercetoType| |pf|)))) - ((|pfPretend?| |pf|) - (LIST '|pretend| (|pf2Sex1| (|pfPretendExpr| |pf|)) - (|pf2Sex1| (|pfPretendType| |pf|)))) - ((|pfFromdom?| |pf|) - (PROGN - (SETQ |op| (|opTran| (|pf2Sex1| (|pfFromdomWhat| |pf|)))) - (COND ((EQ |op| '|braceFromCurly|) (SETQ |op| 'SEQ))) - (LIST '|$elt| (|pf2Sex1| (|pfFromdomDomain| |pf|)) |op|))) - ((|pfSequence?| |pf|) (|pfSequence2Sex| |pf|)) - ((|pfExit?| |pf|) - (COND - (|$insideSEQ| - (LIST '|exit| (|pf2Sex1| (|pfExitCond| |pf|)) - (|pf2Sex1| (|pfExitExpr| |pf|)))) - ('T - (LIST 'IF (|pf2Sex1| (|pfExitCond| |pf|)) - (|pf2Sex1| (|pfExitExpr| |pf|)) '|noBranch|)))) - ((|pfLoop?| |pf|) - (CONS 'REPEAT (|loopIters2Sex| (|pf0LoopIterators| |pf|)))) - ((|pfCollect?| |pf|) (|pfCollect2Sex| |pf|)) - ((|pfForin?| |pf|) - (CONS 'IN - (APPEND ((LAMBDA (|bfVar#6| |bfVar#5| |x|) - (LOOP - (COND - ((OR (ATOM |bfVar#5|) - (PROGN - (SETQ |x| (CAR |bfVar#5|)) - NIL)) - (RETURN (NREVERSE |bfVar#6|))) - ('T - (SETQ |bfVar#6| - (CONS (|pf2Sex1| |x|) |bfVar#6|)))) - (SETQ |bfVar#5| (CDR |bfVar#5|)))) - NIL (|pf0ForinLhs| |pf|) NIL) - (CONS (|pf2Sex1| (|pfForinWhole| |pf|)) NIL)))) - ((|pfWhile?| |pf|) - (LIST 'WHILE (|pf2Sex1| (|pfWhileCond| |pf|)))) - ((|pfSuchthat?| |pf|) - (COND - ((EQ |$insideRule| '|left|) - (|keyedSystemError| "S2GE0017" - (LIST "pf2Sex1: pfSuchThat"))) - ('T (LIST '|\|| (|pf2Sex1| (|pfSuchthatCond| |pf|)))))) - ((|pfDo?| |pf|) (|pf2Sex1| (|pfDoBody| |pf|))) - ((|pfTyped?| |pf|) - (PROGN - (SETQ |type| (|pfTypedType| |pf|)) - (COND - ((|pfNothing?| |type|) (|pf2Sex1| (|pfTypedId| |pf|))) - ('T - (LIST '|:| (|pf2Sex1| (|pfTypedId| |pf|)) - (|pf2Sex1| (|pfTypedType| |pf|))))))) - ((|pfAssign?| |pf|) - (PROGN - (SETQ |idList| - ((LAMBDA (|bfVar#8| |bfVar#7| |x|) - (LOOP - (COND - ((OR (ATOM |bfVar#7|) - (PROGN (SETQ |x| (CAR |bfVar#7|)) NIL)) - (RETURN (NREVERSE |bfVar#8|))) - ('T - (SETQ |bfVar#8| - (CONS (|pf2Sex1| |x|) |bfVar#8|)))) - (SETQ |bfVar#7| (CDR |bfVar#7|)))) - NIL (|pf0AssignLhsItems| |pf|) NIL)) - (COND - ((NOT (EQL (LENGTH |idList|) 1)) - (SETQ |idList| (CONS '|Tuple| |idList|))) - ('T (SETQ |idList| (CAR |idList|)))) - (LIST 'LET |idList| (|pf2Sex1| (|pfAssignRhs| |pf|))))) - ((|pfDefinition?| |pf|) (|pfDefinition2Sex| |pf|)) - ((|pfLambda?| |pf|) (|pfLambda2Sex| |pf|)) - ((|pfMLambda?| |pf|) '|/throwAway|) - ((|pfRestrict?| |pf|) - (LIST '@ (|pf2Sex1| (|pfRestrictExpr| |pf|)) - (|pf2Sex1| (|pfRestrictType| |pf|)))) - ((|pfFree?| |pf|) - (CONS '|free| - ((LAMBDA (|bfVar#10| |bfVar#9| |item|) - (LOOP - (COND - ((OR (ATOM |bfVar#9|) - (PROGN (SETQ |item| (CAR |bfVar#9|)) NIL)) - (RETURN (NREVERSE |bfVar#10|))) - ('T - (SETQ |bfVar#10| - (CONS (|pf2Sex1| |item|) |bfVar#10|)))) - (SETQ |bfVar#9| (CDR |bfVar#9|)))) - NIL (|pf0FreeItems| |pf|) NIL))) - ((|pfLocal?| |pf|) - (CONS '|local| - ((LAMBDA (|bfVar#12| |bfVar#11| |item|) - (LOOP - (COND - ((OR (ATOM |bfVar#11|) - (PROGN (SETQ |item| (CAR |bfVar#11|)) NIL)) - (RETURN (NREVERSE |bfVar#12|))) - ('T - (SETQ |bfVar#12| - (CONS (|pf2Sex1| |item|) |bfVar#12|)))) - (SETQ |bfVar#11| (CDR |bfVar#11|)))) - NIL (|pf0LocalItems| |pf|) NIL))) - ((|pfWrong?| |pf|) (|spadThrow|)) - ((|pfAnd?| |pf|) - (LIST '|and| (|pf2Sex1| (|pfAndLeft| |pf|)) - (|pf2Sex1| (|pfAndRight| |pf|)))) - ((|pfOr?| |pf|) - (LIST '|or| (|pf2Sex1| (|pfOrLeft| |pf|)) - (|pf2Sex1| (|pfOrRight| |pf|)))) - ((|pfNot?| |pf|) (LIST '|not| (|pf2Sex1| (|pfNotArg| |pf|)))) - ((|pfNovalue?| |pf|) - (PROGN - (setq |$QuietCommand| t) - (LIST 'SEQ (|pf2Sex1| (|pfNovalueExpr| |pf|))))) - ((|pfRule?| |pf|) (|pfRule2Sex| |pf|)) - ((|pfBreak?| |pf|) (LIST '|break| (|pfBreakFrom| |pf|))) - ((|pfMacro?| |pf|) '|/throwAway|) - ((|pfReturn?| |pf|) - (LIST '|return| (|pf2Sex1| (|pfReturnExpr| |pf|)))) - ((|pfIterate?| |pf|) (LIST '|iterate|)) - ((|pfWhere?| |pf|) - (PROGN - (SETQ |args| - ((LAMBDA (|bfVar#14| |bfVar#13| |p|) - (LOOP - (COND - ((OR (ATOM |bfVar#13|) - (PROGN (SETQ |p| (CAR |bfVar#13|)) NIL)) - (RETURN (NREVERSE |bfVar#14|))) - ('T - (SETQ |bfVar#14| - (CONS (|pf2Sex1| |p|) |bfVar#14|)))) - (SETQ |bfVar#13| (CDR |bfVar#13|)))) - NIL (|pf0WhereContext| |pf|) NIL)) - (COND - ((EQL (LENGTH |args|) 1) - (CONS '|where| - (CONS (|pf2Sex1| (|pfWhereExpr| |pf|)) |args|))) - ('T - (LIST '|where| (|pf2Sex1| (|pfWhereExpr| |pf|)) - (CONS 'SEQ |args|)))))) - ((EQ (|pfAbSynOp| |pf|) '|command|) (|tokPart| |pf|)) - ('T (|keyedSystemError| "S2GE0017" (LIST "pf2Sex1"))))))) - -;pfLiteral2Sex pf == -; type := pfLiteralClass pf -; type = 'integer => -; READ_-FROM_-STRING pfLiteralString pf -; type = 'string or type = 'char => -; pfLiteralString pf -; type = 'float => -; float2Sex pfLiteralString pf -; type = 'symbol => -; $insideRule => -; s := pfSymbolSymbol pf -; ["QUOTE", s] -; pfSymbolSymbol pf -; type = 'expression => -; ["QUOTE", pfLeafToken pf] -; keyedSystemError('"S2GE0017", ['"pfLiteral2Sex: unexpected form"]) - -(DEFUN |pfLiteral2Sex| (|pf|) - (PROG (|s| |type|) - (DECLARE (SPECIAL |$insideRule|)) - (RETURN - (PROGN - (SETQ |type| (|pfLiteralClass| |pf|)) - (COND - ((EQ |type| '|integer|) - (READ-FROM-STRING (|pfLiteralString| |pf|))) - ((OR (EQ |type| '|string|) (EQ |type| '|char|)) - (|pfLiteralString| |pf|)) - ((EQ |type| '|float|) (|float2Sex| (|pfLiteralString| |pf|))) - ((EQ |type| '|symbol|) - (COND - (|$insideRule| - (PROGN - (SETQ |s| (|pfSymbolSymbol| |pf|)) - (LIST 'QUOTE |s|))) - ('T (|pfSymbolSymbol| |pf|)))) - ((EQ |type| '|expression|) - (LIST 'QUOTE (|pfLeafToken| |pf|))) - ('T - (|keyedSystemError| "S2GE0017" - (LIST "pfLiteral2Sex: unexpected form")))))))) - -;symEqual(sym, sym2) == EQ(sym, sym2) - -(DEFUN |symEqual| (|sym| |sym2|) (PROG () (RETURN (EQ |sym| |sym2|)))) - -;SymMemQ(sy, l) == MEMQ(sy, l) - -(DEFUN |SymMemQ| (|sy| |l|) (PROG () (RETURN (MEMQ |sy| |l|)))) - ;pmDontQuote? sy == ; SymMemQ(sy, '(_+ _- _* _*_* _^ _/ log exp pi sqrt ei li erf ci si dilog _ ; sin cos tan cot sec csc asin acos atan acot asec acsc _ @@ -468,7 +72,7 @@ Value = NIL (DEFUN |pmDontQuote?| (|sy|) (PROG () (RETURN - (|SymMemQ| |sy| + (memq |sy| '(+ - * ** ^ / |log| |exp| |pi| |sqrt| |ei| |li| |erf| |ci| |si| |dilog| |sin| |cos| |tan| |cot| |sec| |csc| |asin| |acos| |atan| |acot| |asec| |acsc| |sinh| |cosh| |tanh| @@ -512,168 +116,12 @@ Value = NIL (PROGN (SETQ |$quotedOpList| (CONS |op| |$quotedOpList|)) |op|)))) - ((|symEqual| |realOp| '|\||) |realOp|) - ((|symEqual| |realOp| '|:|) |realOp|) - ((|symEqual| |realOp| '?) |realOp|) + ((eq |realOp| '|\||) |realOp|) + ((eq |realOp| '|:|) |realOp|) + ((eq |realOp| '?) |realOp|) ('T |op|))) ('T |op|)))))) -;pfApplication2Sex pf == -; $insideApplication: local := true -; op := pfOp2Sex pfApplicationOp pf -; op := opTran op -; op = "->" => -; args := pf0TupleParts pfApplicationArg pf -; if pfTuple? CAR args then -; typeList := [pf2Sex1 arg for arg in pf0TupleParts CAR args] -; else -; typeList := [pf2Sex1 CAR args] -; args := [pf2Sex1 CADR args, :typeList] -; ["Mapping", :args] -; symEqual(op, ":") and $insideRule = 'left => -; ["multiple", pf2Sex pfApplicationArg pf] -; symEqual(op, "?") and $insideRule = 'left => -; ["optional", pf2Sex pfApplicationArg pf] -; args := pfApplicationArg pf -; pfTuple? args => -; symEqual(op, "|") and $insideRule = 'left => -; pfSuchThat2Sex args -; argSex := rest pf2Sex1 args -; symEqual(op, ">") => -; ["<", CADR argSex, CAR argSex] -; symEqual(op, ">=") => -; ["not", ["<", CAR argSex, CADR argSex]] -; symEqual(op, "<=") => -; ["not", ["<", CADR argSex, CAR argSex]] -;-- symEqual(op, "reduce") and (#argSex) = 2 => -;-- ["REDUCE", first argSex, 0, CADR argSex] -; symEqual(op, "AND") => -; ["and", CAR argSex, CADR argSex] -; symEqual(op, "OR") => -; ["or", CAR argSex, CADR argSex] -; symEqual(op, "Iterate") => -; ["iterate"] -; symEqual(op, "by") => -; ["BY", :argSex] -; symEqual(op, "braceFromCurly") => -;-- ["brace", ["construct", :argSex]] -; argSex is ["SEQ",:.] => argSex -; ["SEQ", :argSex] -; op is [qt, realOp] and symEqual(qt, "QUOTE") => -; ["applyQuote", op, :argSex] -; val := hasOptArgs? argSex => [op, :val] -; [op, :argSex] -; op is [qt, realOp] and symEqual(qt, "QUOTE") => -; ["applyQuote", op, pf2Sex1 args] -; symEqual(op, "braceFromCurly") => -;-- ["brace", ["construct", pf2Sex1 args]] -; x := pf2Sex1 args -; x is ["SEQ", :.] => x -; ["SEQ", x] -; symEqual(op, "by") => -; ["BY", pf2Sex1 args] -; [op, pf2Sex1 args] - -(DEFUN |pfApplication2Sex| (|pf|) - (PROG (|$insideApplication| |x| |val| |realOp| |ISTMP#1| |qt| - |argSex| |typeList| |args| |op|) - (DECLARE (SPECIAL |$insideApplication| |$insideRule|)) - (RETURN - (PROGN - (SETQ |$insideApplication| T) - (SETQ |op| (|pfOp2Sex| (|pfApplicationOp| |pf|))) - (SETQ |op| (|opTran| |op|)) - (COND - ((EQ |op| '->) - (PROGN - (SETQ |args| (|pf0TupleParts| (|pfApplicationArg| |pf|))) - (COND - ((|pfTuple?| (CAR |args|)) - (SETQ |typeList| - ((LAMBDA (|bfVar#16| |bfVar#15| |arg|) - (LOOP - (COND - ((OR (ATOM |bfVar#15|) - (PROGN - (SETQ |arg| (CAR |bfVar#15|)) - NIL)) - (RETURN (NREVERSE |bfVar#16|))) - ('T - (SETQ |bfVar#16| - (CONS (|pf2Sex1| |arg|) |bfVar#16|)))) - (SETQ |bfVar#15| (CDR |bfVar#15|)))) - NIL (|pf0TupleParts| (CAR |args|)) NIL))) - ('T (SETQ |typeList| (LIST (|pf2Sex1| (CAR |args|)))))) - (SETQ |args| (CONS (|pf2Sex1| (CADR |args|)) |typeList|)) - (CONS '|Mapping| |args|))) - ((AND (|symEqual| |op| '|:|) (EQ |$insideRule| '|left|)) - (LIST '|multiple| (|pf2Sex| (|pfApplicationArg| |pf|)))) - ((AND (|symEqual| |op| '?) (EQ |$insideRule| '|left|)) - (LIST '|optional| (|pf2Sex| (|pfApplicationArg| |pf|)))) - ('T - (PROGN - (SETQ |args| (|pfApplicationArg| |pf|)) - (COND - ((|pfTuple?| |args|) - (COND - ((AND (|symEqual| |op| '|\||) - (EQ |$insideRule| '|left|)) - (|pfSuchThat2Sex| |args|)) - ('T - (PROGN - (SETQ |argSex| (CDR (|pf2Sex1| |args|))) - (COND - ((|symEqual| |op| '>) - (LIST '< (CADR |argSex|) (CAR |argSex|))) - ((|symEqual| |op| '>=) - (LIST '|not| - (LIST '< (CAR |argSex|) (CADR |argSex|)))) - ((|symEqual| |op| '<=) - (LIST '|not| - (LIST '< (CADR |argSex|) (CAR |argSex|)))) - ((|symEqual| |op| 'AND) - (LIST '|and| (CAR |argSex|) (CADR |argSex|))) - ((|symEqual| |op| 'OR) - (LIST '|or| (CAR |argSex|) (CADR |argSex|))) - ((|symEqual| |op| '|Iterate|) (LIST '|iterate|)) - ((|symEqual| |op| '|by|) (CONS 'BY |argSex|)) - ((|symEqual| |op| '|braceFromCurly|) - (COND - ((AND (CONSP |argSex|) - (EQ (CAR |argSex|) 'SEQ)) - |argSex|) - ('T (CONS 'SEQ |argSex|)))) - ((AND (CONSP |op|) - (PROGN - (SETQ |qt| (CAR |op|)) - (SETQ |ISTMP#1| (CDR |op|)) - (AND (CONSP |ISTMP#1|) - (EQ (CDR |ISTMP#1|) NIL) - (PROGN - (SETQ |realOp| (CAR |ISTMP#1|)) - 'T))) - (|symEqual| |qt| 'QUOTE)) - (CONS '|applyQuote| (CONS |op| |argSex|))) - ((SETQ |val| (|hasOptArgs?| |argSex|)) - (CONS |op| |val|)) - ('T (CONS |op| |argSex|))))))) - ((AND (CONSP |op|) - (PROGN - (SETQ |qt| (CAR |op|)) - (SETQ |ISTMP#1| (CDR |op|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |realOp| (CAR |ISTMP#1|)) 'T))) - (|symEqual| |qt| 'QUOTE)) - (LIST '|applyQuote| |op| (|pf2Sex1| |args|))) - ((|symEqual| |op| '|braceFromCurly|) - (PROGN - (SETQ |x| (|pf2Sex1| |args|)) - (COND - ((AND (CONSP |x|) (EQ (CAR |x|) 'SEQ)) |x|) - ('T (LIST 'SEQ |x|))))) - ((|symEqual| |op| '|by|) (LIST 'BY (|pf2Sex1| |args|))) - ('T (LIST |op| (|pf2Sex1| |args|))))))))))) - ;hasOptArgs? argSex == ; nonOpt := nil ; opt := nil @@ -908,119 +356,6 @@ Value = NIL ('T (CONS |id| |conds|))))) ('T (|pf2Sex1| |pf|)))))) -;opTran op == -; op = $dotdot => "SEGMENT" -; op = "[]" => "construct" -; op = "{}" => "braceFromCurly" -; op = "IS" => "is" -; op - -(DEFUN |opTran| (|op|) - (PROG () - (DECLARE (SPECIAL |$dotdot|)) - (RETURN - (COND - ((EQUAL |op| |$dotdot|) 'SEGMENT) - ((EQ |op| '[]) '|construct|) - ((EQ |op| '{}) '|braceFromCurly|) - ((EQ |op| 'IS) '|is|) - ('T |op|))))) - -;pfSequence2Sex pf == -; $insideSEQ:local := true -; seq := pfSequence2Sex0 [pf2Sex1 x for x in pf0SequenceArgs pf] -; seq is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => -; ["ruleset", ["construct", :ruleList]] -; seq - -(DEFUN |pfSequence2Sex| (|pf|) - (PROG (|$insideSEQ| |ISTMP#1| |ruleList| |seq|) - (DECLARE (SPECIAL |$insideSEQ|)) - (RETURN - (PROGN - (SETQ |$insideSEQ| T) - (SETQ |seq| - (|pfSequence2Sex0| - ((LAMBDA (|bfVar#26| |bfVar#25| |x|) - (LOOP - (COND - ((OR (ATOM |bfVar#25|) - (PROGN (SETQ |x| (CAR |bfVar#25|)) NIL)) - (RETURN (NREVERSE |bfVar#26|))) - ('T - (SETQ |bfVar#26| - (CONS (|pf2Sex1| |x|) |bfVar#26|)))) - (SETQ |bfVar#25| (CDR |bfVar#25|)))) - NIL (|pf0SequenceArgs| |pf|) NIL))) - (COND - ((AND (CONSP |seq|) (EQ (CAR |seq|) 'SEQ) - (PROGN (SETQ |ruleList| (CDR |seq|)) 'T) - (CONSP |ruleList|) - (PROGN - (SETQ |ISTMP#1| (CAR |ruleList|)) - (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) '|rule|)))) - (LIST '|ruleset| (CONS '|construct| |ruleList|))) - ('T |seq|)))))) - -;pfSequence2Sex0 seqList == -; null seqList => "noBranch" -; seqTranList := [] -; while seqList ^= nil repeat -; item := first seqList -; item is ["exit", cond, value] => -; item := ["IF", cond, value, pfSequence2Sex0 rest seqList] -; seqTranList := [item, :seqTranList] -; seqList := nil -; seqTranList := [item ,:seqTranList] -; seqList := rest seqList -; #seqTranList = 1 => first seqTranList -; ["SEQ", :nreverse seqTranList] - -(DEFUN |pfSequence2Sex0| (|seqList|) - (PROG (|value| |ISTMP#2| |cond| |ISTMP#1| |item| |seqTranList|) - (RETURN - (COND - ((NULL |seqList|) '|noBranch|) - ('T - (PROGN - (SETQ |seqTranList| NIL) - ((LAMBDA () - (LOOP - (COND - ((NOT |seqList|) (RETURN NIL)) - ('T - (PROGN - (SETQ |item| (CAR |seqList|)) - (COND - ((AND (CONSP |item|) (EQ (CAR |item|) '|exit|) - (PROGN - (SETQ |ISTMP#1| (CDR |item|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |cond| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (PROGN - (SETQ |value| (CAR |ISTMP#2|)) - 'T)))))) - (PROGN - (SETQ |item| - (LIST 'IF |cond| |value| - (|pfSequence2Sex0| - (CDR |seqList|)))) - (SETQ |seqTranList| - (CONS |item| |seqTranList|)) - (SETQ |seqList| NIL))) - ('T - (PROGN - (SETQ |seqTranList| - (CONS |item| |seqTranList|)) - (SETQ |seqList| (CDR |seqList|))))))))))) - (COND - ((EQL (LENGTH |seqTranList|) 1) (CAR |seqTranList|)) - ('T (CONS 'SEQ (NREVERSE |seqTranList|)))))))))) - ;float2Sex num == ; eIndex := SEARCH('"e", num) ; mantPart := @@ -1077,164 +412,6 @@ Value = NIL |exp| 10))) ('T |bfForm|)))))) -;loopIters2Sex iterList == -; result := nil -; for iter in iterList repeat -; sex := pf2Sex1 iter -; sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => -; result := [['STEP, var, i, incr], :result] -; sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => -; result := [['STEP, var, i, incr, j], :result] -; sex is ['IN, var, ['SEGMENT, i, j]] => -; result := [['STEP, var, i, 1, j], :result] -; result := [sex, :result] -; nreverse result - -(DEFUN |loopIters2Sex| (|iterList|) - (PROG (|ISTMP#8| |j| |incr| |ISTMP#7| |ISTMP#6| |ISTMP#5| |i| - |ISTMP#4| |ISTMP#3| |ISTMP#2| |var| |ISTMP#1| |sex| - |result|) - (RETURN - (PROGN - (SETQ |result| NIL) - ((LAMBDA (|bfVar#27| |iter|) - (LOOP - (COND - ((OR (ATOM |bfVar#27|) - (PROGN (SETQ |iter| (CAR |bfVar#27|)) NIL)) - (RETURN NIL)) - ('T - (PROGN - (SETQ |sex| (|pf2Sex1| |iter|)) - (COND - ((AND (CONSP |sex|) (EQ (CAR |sex|) 'IN) - (PROGN - (SETQ |ISTMP#1| (CDR |sex|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |var| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (PROGN - (SETQ |ISTMP#3| (CAR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CAR |ISTMP#3|) 'SEGMENT) - (PROGN - (SETQ |ISTMP#4| - (CDR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (PROGN - (SETQ |i| (CAR |ISTMP#4|)) - (SETQ |ISTMP#5| - (CDR |ISTMP#4|)) - (AND (CONSP |ISTMP#5|) - (EQ (CDR |ISTMP#5|) NIL) - (PROGN - (SETQ |ISTMP#6| - (CAR |ISTMP#5|)) - (AND (CONSP |ISTMP#6|) - (EQ (CAR |ISTMP#6|) - 'BY) - (PROGN - (SETQ |ISTMP#7| - (CDR |ISTMP#6|)) - (AND - (CONSP |ISTMP#7|) - (EQ (CDR |ISTMP#7|) - NIL) - (PROGN - (SETQ |incr| - (CAR |ISTMP#7|)) - 'T)))))))))))))))) - (SETQ |result| - (CONS (LIST 'STEP |var| |i| |incr|) - |result|))) - ((AND (CONSP |sex|) (EQ (CAR |sex|) 'IN) - (PROGN - (SETQ |ISTMP#1| (CDR |sex|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |var| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (PROGN - (SETQ |ISTMP#3| (CAR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CAR |ISTMP#3|) 'BY) - (PROGN - (SETQ |ISTMP#4| - (CDR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (PROGN - (SETQ |ISTMP#5| - (CAR |ISTMP#4|)) - (AND (CONSP |ISTMP#5|) - (EQ (CAR |ISTMP#5|) - 'SEGMENT) - (PROGN - (SETQ |ISTMP#6| - (CDR |ISTMP#5|)) - (AND (CONSP |ISTMP#6|) - (PROGN - (SETQ |i| - (CAR |ISTMP#6|)) - (SETQ |ISTMP#7| - (CDR |ISTMP#6|)) - (AND - (CONSP |ISTMP#7|) - (EQ (CDR |ISTMP#7|) - NIL) - (PROGN - (SETQ |j| - (CAR |ISTMP#7|)) - 'T))))))) - (PROGN - (SETQ |ISTMP#8| - (CDR |ISTMP#4|)) - (AND (CONSP |ISTMP#8|) - (EQ (CDR |ISTMP#8|) NIL) - (PROGN - (SETQ |incr| - (CAR |ISTMP#8|)) - 'T)))))))))))) - (SETQ |result| - (CONS (LIST 'STEP |var| |i| |incr| |j|) - |result|))) - ((AND (CONSP |sex|) (EQ (CAR |sex|) 'IN) - (PROGN - (SETQ |ISTMP#1| (CDR |sex|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |var| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (PROGN - (SETQ |ISTMP#3| (CAR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CAR |ISTMP#3|) 'SEGMENT) - (PROGN - (SETQ |ISTMP#4| - (CDR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (PROGN - (SETQ |i| (CAR |ISTMP#4|)) - (SETQ |ISTMP#5| - (CDR |ISTMP#4|)) - (AND (CONSP |ISTMP#5|) - (EQ (CDR |ISTMP#5|) NIL) - (PROGN - (SETQ |j| - (CAR |ISTMP#5|)) - 'T)))))))))))) - (SETQ |result| - (CONS (LIST 'STEP |var| |i| 1 |j|) |result|))) - ('T (SETQ |result| (CONS |sex| |result|))))))) - (SETQ |bfVar#27| (CDR |bfVar#27|)))) - |iterList| NIL) - (NREVERSE |result|))))) ;pfCollect2Sex pf == ; sex := ["COLLECT", :loopIters2Sex pfParts pfCollectIterators pf, @@ -1514,7 +691,7 @@ Value = NIL ((ATOM |expr|) (COND ((NULL (SYMBOLP |expr|)) |varList|) - ((|SymMemQ| |expr| |varList|) |varList|) + ((memq |expr| |varList|) |varList|) ('T (CONS |expr| |varList|)))) ((AND (CONSP |expr|) (PROGN diff --git a/src/interp/ptrees.lisp.pamphlet b/src/interp/ptrees.lisp.pamphlet index 40f1a39..c883fb3 100644 --- a/src/interp/ptrees.lisp.pamphlet +++ b/src/interp/ptrees.lisp.pamphlet @@ -82,11 +82,6 @@ (DEFUN |pfNothing| () (PROG () (RETURN (|pfTree| '|nothing| NIL)))) -;pfNothing? form == pfAbSynOp?(form, 'nothing) - -(DEFUN |pfNothing?| (|form|) - (PROG () (RETURN (|pfAbSynOp?| |form| '|nothing|)))) - ;-- SemiColon ; ;pfSemiColon(pfbody) == pfTree('SemiColon, [pfbody]) @@ -126,10 +121,6 @@ (DEFUN |pfSymbolVariable?| (|form|) (PROG () (RETURN (|pfAbSynOp?| |form| '|idsy|)))) -;pfIdSymbol form == tokPart form - -(DEFUN |pfIdSymbol| (|form|) (PROG () (RETURN (|tokPart| |form|)))) - ;--pfAmpersand(amptok,name) == name ; ;pfDocument strings == pfLeaf('Document, strings) @@ -147,17 +138,6 @@ (DEFUN |pfDocumentText| (|form|) (PROG () (RETURN (|tokPart| |form|)))) -;pfLiteral? form == -; MEMQ(pfAbSynOp form,'(integer symbol expression -; one zero char string float)) - -(DEFUN |pfLiteral?| (|form|) - (PROG () - (RETURN - (MEMQ (|pfAbSynOp| |form|) - '(|integer| |symbol| |expression| |one| |zero| |char| - |string| |float|))))) - ;pfLiteralClass form == pfAbSynOp form (DEFUN |pfLiteralClass| (|form|) @@ -203,16 +183,8 @@ (|pfSymbol| (|tokPart| |expr|) (IFCAR |optpos|))) ('T (|pfExpression| (|pfSexpr| |expr|) (IFCAR |optpos|))))))) -;pfSymbol? form == pfAbSynOp?(form, 'symbol) - -(DEFUN |pfSymbol?| (|form|) - (PROG () (RETURN (|pfAbSynOp?| |form| '|symbol|)))) - ;pfSymbolSymbol form == tokPart form -(DEFUN |pfSymbolSymbol| (|form|) - (PROG () (RETURN (|tokPart| |form|)))) - ;--% TREES ;-- parser interface functions ;-- these are potential sources of trouble in macro expansion @@ -788,11 +760,6 @@ (DEFUN |pfApplication| (|pfop| |pfarg|) (PROG () (RETURN (|pfTree| '|Application| (LIST |pfop| |pfarg|))))) -;pfApplication?(pf) == pfAbSynOp? (pf, 'Application) - -(DEFUN |pfApplication?| (|pf|) - (PROG () (RETURN (|pfAbSynOp?| |pf| '|Application|)))) - ;pfApplicationOp pf == CADR pf -- was ==> (DEFUN |pfApplicationOp| (|pf|) (PROG () (RETURN (CADR |pf|)))) @@ -813,20 +780,10 @@ (DEFUN |pfTuple| (|pfparts|) (PROG () (RETURN (|pfTree| '|Tuple| (LIST |pfparts|))))) -;pfTuple?(pf) == pfAbSynOp? (pf, 'Tuple) - -(DEFUN |pfTuple?| (|pf|) - (PROG () (RETURN (|pfAbSynOp?| |pf| '|Tuple|)))) - ;pfTupleParts pf == CADR pf -- was ==> (DEFUN |pfTupleParts| (|pf|) (PROG () (RETURN (CADR |pf|)))) -;pf0TupleParts pf == pfParts pfTupleParts pf - -(DEFUN |pf0TupleParts| (|pf|) - (PROG () (RETURN (|pfParts| (|pfTupleParts| |pf|))))) - ;-- Tagged := (Tag: Expr, Expr: Expr) ;pfTagged(pftag, pfexpr) == pfTree('Tagged, [pftag, pfexpr]) @@ -834,19 +791,6 @@ (DEFUN |pfTagged| (|pftag| |pfexpr|) (PROG () (RETURN (|pfTree| '|Tagged| (LIST |pftag| |pfexpr|))))) -;pfTagged?(pf) == pfAbSynOp? (pf, 'Tagged) - -(DEFUN |pfTagged?| (|pf|) - (PROG () (RETURN (|pfAbSynOp?| |pf| '|Tagged|)))) - -;pfTaggedTag pf == CADR pf -- was ==> - -(DEFUN |pfTaggedTag| (|pf|) (PROG () (RETURN (CADR |pf|)))) - -;pfTaggedExpr pf == CADDR pf -- was ==> - -(DEFUN |pfTaggedExpr| (|pf|) (PROG () (RETURN (CADDR |pf|)))) - ;-- Pretend := (Expr: Expr, Type: Type) ;pfPretend(pfexpr, pftype) == pfTree('Pretend, [pfexpr, pftype]) @@ -854,18 +798,6 @@ (DEFUN |pfPretend| (|pfexpr| |pftype|) (PROG () (RETURN (|pfTree| '|Pretend| (LIST |pfexpr| |pftype|))))) -;pfPretend?(pf) == pfAbSynOp? (pf, 'Pretend) - -(DEFUN |pfPretend?| (|pf|) - (PROG () (RETURN (|pfAbSynOp?| |pf| '|Pretend|)))) - -;pfPretendExpr pf == CADR pf -- was ==> - -(DEFUN |pfPretendExpr| (|pf|) (PROG () (RETURN (CADR |pf|)))) - -;pfPretendType pf == CADDR pf -- was ==> - -(DEFUN |pfPretendType| (|pf|) (PROG () (RETURN (CADDR |pf|)))) ;-- Restrict := (Expr: Expr, Type: Type) @@ -912,19 +844,6 @@ (DEFUN |pfCoerceto| (|pfexpr| |pftype|) (PROG () (RETURN (|pfTree| '|Coerceto| (LIST |pfexpr| |pftype|))))) -;pfCoerceto?(pf) == pfAbSynOp? (pf, 'Coerceto) - -(DEFUN |pfCoerceto?| (|pf|) - (PROG () (RETURN (|pfAbSynOp?| |pf| '|Coerceto|)))) - -;pfCoercetoExpr pf == CADR pf -- was ==> - -(DEFUN |pfCoercetoExpr| (|pf|) (PROG () (RETURN (CADR |pf|)))) - -;pfCoercetoType pf == CADDR pf -- was ==> - -(DEFUN |pfCoercetoType| (|pf|) (PROG () (RETURN (CADDR |pf|)))) - ;-- Fromdom := (What: Id, Domain: Type) ;pfFromdom(pfwhat, pfdomain) == pfTree('Fromdom, [pfwhat, pfdomain]) @@ -932,19 +851,6 @@ (DEFUN |pfFromdom| (|pfwhat| |pfdomain|) (PROG () (RETURN (|pfTree| '|Fromdom| (LIST |pfwhat| |pfdomain|))))) -;pfFromdom?(pf) == pfAbSynOp? (pf, 'Fromdom) - -(DEFUN |pfFromdom?| (|pf|) - (PROG () (RETURN (|pfAbSynOp?| |pf| '|Fromdom|)))) - -;pfFromdomWhat pf == CADR pf -- was ==> - -(DEFUN |pfFromdomWhat| (|pf|) (PROG () (RETURN (CADR |pf|)))) - -;pfFromdomDomain pf == CADDR pf -- was ==> - -(DEFUN |pfFromdomDomain| (|pf|) (PROG () (RETURN (CADDR |pf|)))) - ;-- Lambda := (Args: [Typed], Rets: ? Type, Body: Expr) ;pfLambda(pfargs, pfrets, pfbody) == pfTree('Lambda, [pfargs, pfrets, pfbody]) @@ -1068,22 +974,6 @@ (PROG () (RETURN (|pfTree| '|If| (LIST |pfcond| |pfthen| |pfelse|))))) -;pfIf?(pf) == pfAbSynOp? (pf, 'If) - -(DEFUN |pfIf?| (|pf|) (PROG () (RETURN (|pfAbSynOp?| |pf| '|If|)))) - -;pfIfCond pf == CADR pf -- was ==> - -(DEFUN |pfIfCond| (|pf|) (PROG () (RETURN (CADR |pf|)))) - -;pfIfThen pf == CADDR pf -- was ==> - -(DEFUN |pfIfThen| (|pf|) (PROG () (RETURN (CADDR |pf|)))) - -;pfIfElse pf == CADDDR pf -- was ==> - -(DEFUN |pfIfElse| (|pf|) (PROG () (RETURN (CADDDR |pf|)))) - ;-- Sequence := (Args: [Expr]) ;pfSequence(pfargs) == pfTree('Sequence, [pfargs]) @@ -1091,11 +981,6 @@ (DEFUN |pfSequence| (|pfargs|) (PROG () (RETURN (|pfTree| '|Sequence| (LIST |pfargs|))))) -;pfSequence?(pf) == pfAbSynOp? (pf, 'Sequence) - -(DEFUN |pfSequence?| (|pf|) - (PROG () (RETURN (|pfAbSynOp?| |pf| '|Sequence|)))) - ;pfSequenceArgs pf == CADR pf -- was ==> (DEFUN |pfSequenceArgs| (|pf|) (PROG () (RETURN (CADR |pf|)))) @@ -1128,11 +1013,6 @@ (DEFUN |pfLoop| (|pfiterators|) (PROG () (RETURN (|pfTree| '|Loop| (LIST |pfiterators|))))) -;pfLoop?(pf) == pfAbSynOp? (pf, 'Loop) - -(DEFUN |pfLoop?| (|pf|) - (PROG () (RETURN (|pfAbSynOp?| |pf| '|Loop|)))) - ;pfLoopIterators pf == CADR pf -- was ==> (DEFUN |pfLoopIterators| (|pf|) (PROG () (RETURN (CADR |pf|)))) @@ -1306,19 +1186,6 @@ (DEFUN |pfExit| (|pfcond| |pfexpr|) (PROG () (RETURN (|pfTree| '|Exit| (LIST |pfcond| |pfexpr|))))) -;pfExit?(pf) == pfAbSynOp? (pf, 'Exit) - -(DEFUN |pfExit?| (|pf|) - (PROG () (RETURN (|pfAbSynOp?| |pf| '|Exit|)))) - -;pfExitCond pf == CADR pf -- was ==> - -(DEFUN |pfExitCond| (|pf|) (PROG () (RETURN (CADR |pf|)))) - -;pfExitExpr pf == CADDR pf -- was ==> - -(DEFUN |pfExitExpr| (|pf|) (PROG () (RETURN (CADDR |pf|)))) - ;-- Macro := (Lhs: Id, Rhs: ExprorNot) ;pfMacro(pflhs, pfrhs) == pfTree('Macro, [pflhs, pfrhs])