diff --git a/src/boot/Makefile.pamphlet b/src/boot/Makefile.pamphlet deleted file mode 100644 index c5ebb48..0000000 --- a/src/boot/Makefile.pamphlet +++ /dev/null @@ -1,1951 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot Makefile} -\author{Timothy Daly \and Gabriel Dos~Reis} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{Boot} -Axiom is built in layers. The first layer is contructed into -an image called {\bf bootsys}. The {\bf bootsys} image is used -to translate boot code to common lisp code. Since a boot coded -interpreter is needed to translate the code for the boot coded -interpreter we have a "boot-strapping" problem. In order to get -the whole process to start we need certain files kept in -common lisp form. This directory contains those files. - -\section{Boot To Common Lisp Translater} -\subsection{Introduction} - -The Scratchpad language is implemented by using a mixture of Lisp and -a more convenient language for writing Lisp called "Boot". -This document contains a description of the Boot language, and some -details of the resulting Lisp programs. -The description of the translation -functions available are at the end of this file. - -The main difference between Lisp and Boot is in the syntax for -the application of a function to its argument. -The Lisp format (F X Y Z), means, when F is a function, -the application of F to its arguments X,Y, and Z, -is written in Boot as F(X,Y,Z). -When F is a special Lisp word it will be written -in Boot by using some other syntactic construction. - -Boot contains an easy method of writing expressions that denote lists, -and provides an analogous method of writing patterns containing variables -and constants which denote a particular class of lists. The pattern -is matched against a particular list at run time, -and if the list belongs to the class then its variables will -take on the values of components of the list. Similarly, Boot provides -an easy way of writing discriminated unions or algebraic types, and -pattern matching as found in ML. - - A second convenient feature provided by Boot is a method of -writing programs that iterate over the elements of one or more lists -and which either transform the state of the machine, or -produce some object from the list or lists. - -\section{Boot To Common Lisp Translaters} -\label{sec:boot-to-cl} - -The Boot to Common Lisp translation is organized in several -separate logical phases. At the moment, those phases are not -really separate; but from a logical point of view, it is better -to think of them that way. - -\subsection{The Boot Includer} -\label{sec:boot-to-cl:includer} - -The Boot Includer is the module that reads Boot codes from source files. -The details of the Includer, as well as the grammar of the include -files are to be found in btscan2.boot. - -\subsection{The Scanner} -\label{sec:boot-to-cl:scanner} - -The tokenization process is implemented in btscan2.boot. Further -details about keywords and reserved identifiers are available in -typrops.boot. - -\subsection{Piling} -\label{sec:boot-to-cl:piling} - -The Boot language uses layout to delimit blocks of expressions. After -the scanner pass, and before the parser pass is another pass called -\emph{piling}. The piling pass inserts tokens to unambiguously delimit -the boundaries of piles. This is implemented in btpile2.boot. - -\subsection{The Parser} -\label{sec:boot-to-cl:parsing} - -The Boot parser is implemented in typars.boot and tyextra.boot. -It is a hand-written recursive descent parser -based on \emph{parser combinators} methodology. Those files also -implicitly defines the grammar of the Boot language. - -\subsection{The Transformer} -\label{sec:boot-to-cl:transfo} - -As observed earlier, the Boot language was originally defined as a syntactic -sugar over Common Lisp. Consequently, it semantics is defined by -tranformation to Lisp. The transformers are defined in -tytree1.boot. - -\subsection{Utils} -\label{sec:boot-to-cl:utils} - -Finally, the file ptyout.boot is a pot-pourri of many utility -functions. It also contains the entry points to the Boot translater. - -\section{Boot} -\label{sec:boot} - -\subsection{Lines and Commands} - -If the first character of a line is a closing parenthesis the line -is treated as a command which controls the lines that will be -passed to the translater rather than being passed itself. -The command )include filename filemodifier will for example -be replaced by the lines in the file filename filemodifier. - -If a line starts with a closing parenthesis it will be called a command -line, otherwise it will be called a plain line. -The command lines are -\begin{verbatim} -name as written - -Include )include filename filemodifier -IncludeLisp )includelisp filename filemodifier -If )if bootexpression -Else )else -ElseIf )elseif bootexpression -EndIf )endif -Fin )fin -Say )say string -Eval )eval bootexpression -EvalStrings )evalstrings bootexpression -Package )package packagename - -SimpleLine::= PlainLine | Include | IncludeLisp | Say - | Eval | EvalStrings | Package -\end{verbatim} - -A PlainLine is delivered to the translater as is. - -An Include delivers the lines in the file filename.filemodifier, -treated as boot lines. - -An IncludeLisp delivers the lines in the specified file, treated as lisp -lines. The only comments allowed in lisp files that are included in -this way require that the semicolon is at the beginning of the line. - -A Say outputs the remainder of the line to the console, - delivering nothing to the translater. - -An Eval translates the reminder of the line, assumed to be - written in Boot, to Lisp, and evaluates it, delivering nothing to - the translater. - -An EvalStrings also translates and evaluates the rest of the line - but this time assumes that the Boot expression denotes a list - of strings which are then delivered to the translater - instead of the EvalString line. The strings are treated as Boot lines. - -It is also possible to include or exclude lines based upon some -condition which is the result of translating and evaluating -the boot expression that follows an )if or )elseif command. -This construction will be called a Conditional. A file will be -composed from SimpleLines and Conditionals. A file is either -terminated by the end of file or by a Fin line. -\begin{verbatim} -Components ::=(SimpleLine | Conditional)* - -File ::= Components ( Fin | empty) - -A conditional is bracketed by an If and an EndIf. - -Conditional ::= If Components Elselines EndIf -\end{verbatim} - -If the boot expression following the )if has value true then the -Components are delivered but not the ElseLines, -otherwise the Components are ignored ,and the ElseLines -are delivered to the translater. In any case the lines after -the EndIf are then processed. -\begin{verbatim} -ElseLines ::= Else Components | ElseIf Components ElseLines - | empty -\end{verbatim} - -When the Elselines of a Conditional is being included then if an -"Else Components" phrase is encountered then the following -Components are included -otherwise if an "ElseIf Components ElseLines" phrase is encountered then -the boot expression following the )elseif is evaluated and -if true the following Components are included, if false the -following ElseLines is included. - - -\subsection{Boot Syntax} - -\subsubsection{Identifiers} - -The standard identifiers start with a letter (a-z or A-Z) -dollar sign (\$), question mark (?), or the percent sign (%), and are -followed by any number of letters, digits, single quotes('), -question marks, or percent signs. -It is possible however, by using the -escape character (\_), to construct identifiers that contain any -characters except the blank or newline character. The rules in this case -are that an escape character followed by any non-blank character -will start an identifier with that character. Once an identifier -has been started either in this way or by a letter, \$, or \%, then -it may be continued either with a letter, digit, ' , ? or \%, or with -an escape character followed by any non-blank character. -Certain words having the form of identifiers are not classified as -such, but are reserved words. They are listed below. - -An identifier ends when a blank or end of line is encountered, or -an escape character followed by a blank or end of line, or a -character which is not a letter, digit, quote, question mark -or percent sign is found. Two identifiers are equal if the -strings produced by replacing each escape followed by a character -by that character are equal character by character. - - -\subsubsection{Numbers} - -Integers start with a digit (0-9) and are followed by any number -of digits. The syntax for floating point numbers is -\begin{verbatim} -<.I | I. | I.I> <+ | - | empty> I -\end{verbatim} -where I is an integer. - -\subsubsection{Strings} - -Strings of characters are enclosed by double quote signs. They cannot -span 2 or more lines and an escape character within a string will -include the next character regardless of its nature. -The meaning of a string depends somewhat on the context in which -it is found, but in general a bare string denotes the interned atom -making up its body whereas when it is preceded by a single quote (') -it denotes the string of characters enclosed. - -\subsubsection{S-expressions} - -An s-expression is preceded by a single quote and is followed by -a Lisp s-expression. -\begin{verbatim} -sexpression ::=identifier | integer | MINUS integer | float - | string | QUOTE sexpression - | parenthesized sexpression1 - -sexpression1 ::=sexpression (DOT sexpression | sexpression1) - | empty -\end{verbatim} - -There are two ways to quote a name either 'name or "name", which -both give rise to (QUOTE name). However a string that is a -component of an sexpression will denote the string unless it is the -sole component of the s-expression in which case it denotes a string -i.e. '"name" gives rise to "name" in Lisp rather than (QUOTE "name"). - - -\subsubsection{Keywords} - -The table of key words follows, each is given an upper case -name for use in the description of the syntax. -\begin{verbatim} - as written name - - and AND - by BY - case CASE - cross CROSS - else ELSE - for FOR - if IF - in IN - is IS - isnt ISNT - of OF - or OR - repeat REPEAT - return RETURN - then THEN - until UNTIL - where WHERE - while WHILE - . DOT - : COLON - , COMMA - ; SEMICOLON - * TIMES - ** POWER - / SLASH - + PLUS - - MINUS - < LT - > GT - <= LE - >= GE - = SHOEEQ - ^ NOT - ^= NE - .. SEG - # LENGTH - => EXIT - := BEC (becomes) - == DEF - ==> MDEF - ( OPAREN - ) CPAREN - (| OBRACK - |) CBRACK - [ OBRACK - ] CBRACK - | BAR - suchthat BAR - ' QUOTE - | BAR -\end{verbatim} - -\subsubsection{Primary} -\begin{verbatim} -constant::= integer | string | float | sexpression -\end{verbatim} - -The value of a constant does not depend on the context in which it -is found. -\begin{verbatim} -primary::= name | constant | construct | block | tuple | pile -\end{verbatim} - -The primaries are the simplest constituents of the language and -either denote some object or perform some transformation of the -machine state, or both. -The statements are the largest constituents and enclosing them -in parentheses converts them into a primary. - -An alternative method of grouping uses indentation to indicate the -parenthetical structure. -A number of lines whose first non-space characters are in the same -column will be called a "pile". The translater first tokenizes the -lines producing identifier, key word, integer, string or float tokens, -and then examines the pile structure of a Boot program -in order to add additional tokens called SETTAB, BACKTAB and BACKSET. -These tokens may be considered as commands for creating a pile. -The SETTAB starts a new line indented from the previous line and -pushes the resulting column number on to a stack of tab positions. -The BACKTAB will start a new line at the column position found -at the head of the stack and removes it from the stack. -The BACKSET has the same effect as a BACKTAB immediately followed -by a SETTAB. -The meaning of a sequence of tokens containing SETTAB -BACKTAB and BACKSET is the same the sequence in which each -SETTAB is replaced by OPAREN , each BACKTAB is replaced by -CPAREN, and each BACKSET is replaced by SEMICOLON. By -construction the BACKTABS and SETTABS are properly nested. -\begin{verbatim} -listof(p,s)== p | p s ... s p - -parenthesized s ::= OPAREN s CPAREN -piled s ::= SETTAB s BACKTAB - -blockof s ::= parenthesized (listof (s,SEMICOLON)) -pileof s ::= piled (listof (s,BACKSET )) -\end{verbatim} - -A pileof s has the same meaning as a blockof s. -There is however a slight difference because piling is weaker than -separation by semicolons. In other words the pile items -may be listof(s,SEMICOLON). -In other words if statements::= listof(statement,SEMICOLON) then -we can have a pileof statements which has the same meaning as -the flattened sequence formed by replacing -all BACKSET's by SEMICOLON's. - -A blockof statement is translated to a compound statement -e.g. in the absence of any exits, -(a;b;c;d) is translated to (PROGN a b c d). - -\subsubsection{Selectors} -\begin{verbatim} -selector::= leftassociative(primary, DOT) -\end{verbatim} - -A selector a.b denotes some component of a structure, and in -general is translated to (ELT a b). There are some special identifiers -that may be used in the b position to denote list components, of which -more later. -The DOT has a greater precedence than juxtaposition and is -left associative, For example -\begin{verbatim} -a.b.c is grouped as (a.b).c which is translated to - (ELT (ELT a b) c) - -application ::= selector selector ... selector - -\end{verbatim} - -Application of function to argument is denoted by juxtaposition. - -A sequence of selectors is right associative and so -f g h x is grouped as f(g(h x)). The applications f x and f(x) -mean the application of f to x and get translated to -the Lisp (f x). The application of a function to the empty list -is written f(), meaning the Lisp (f). f(x,y,z) gets translated to -the Lisp (f x y z). -Common Lisp does not permit a variable to occur in operator position, -so that when f is a variable its application has to be -put in argument position of a FUNCALL or APPLY. -f(x,y,z) has to be replaced by FUNCALL(f,x,y) which gets translated to -the Lisp (FUNCALL f x y z). -In Common Lisp each symbol might refer -to two objects a function and a non-function. In order to resolve -this ambiguity when a function symbol appears in a context other -than operator position it has to be preceded by the symbol FUNCTION. -Also it is possible to produce the function type symbol from the -non-function symbol by applying SYMBOL-FUNCTION to it. - -Certain reserved words called infixed operators namely -POWER, TIMES, SLASH, PLUS MINUS ,IS, -EQ , NE , GT , GE , LT , LE , IN , AND, OR, -indicate application by being placed between their 2 arguments. - -Infixed application may be either right- or left-associative. -\begin{verbatim} -rightassociative(p,o)::= p o p o p o ... o p - == p o (p o (p o ... o p))) - -leftassociative(p,o)::= p o p o p o ... o p - == (((p o p) o p) o ...) o p - - -exponent ::= rightassociative(application,POWER) - -reduction ::= (infixedoperator |string | thetaname ) - SLASH application -\end{verbatim} - -In a reduction the application denotes a list of items and -operator SLASH application accumulates the list elements from the -left using the operator -\begin{verbatim} -e.g. +/[a,b,c] means (((0+a)+b)+c) -\end{verbatim} - -Only certain operators are provided with values when the list is empty -they are and, or +, *, max, min, append, union. However any -function can be used as an operator by enclosing it in double -quotes. In this case the reduction is not applicable to an -empty list. -\begin{verbatim} -multiplication ::= rightassociative(exponent,TIMES|SLASH) - | reduction - -minus ::= MINUS multiplication | multiplication - -arith ::= leftasscociative(minus,PLUS | MINUS) - -is ::= arith | arith (IS | ISNT) pattern - -comparison ::= is (EQ | NE | GT | GE | LT | LE | IN) is | is - -and ::= leftassociative (comparison,AND) - -return ::= and | RETURN and - -expression ::= leftassociative(return,OR) -\end{verbatim} - -The infixed operators denote application of the function to its -two arguments. To summarize, -the infixed operators are, in order of decreasing precedence -strengths. -\begin{verbatim} - . - juxtaposition - ** - * / - + - - is - = ^= > >= < <= in - and - or -\end{verbatim} - -\subsubsection{Conditionals} -\begin{verbatim} -conditional ::= IF where THEN where | - IF where THEN where ELSE where - -IF a THEN b is translated to (COND (a b)) and -IF a THEN b else c is translated to (COND (a b) (T c)) - -statement::= conditional | loop | expression -\end{verbatim} - -\subsubsection{Loops} -\begin{verbatim} -loop ::= crossproduct REPEAT statement | REPEAT statement - -iterator ::= forin | suchthat | until | while - -iterators ::= iterator iterator ... iterator - -crossproduct ::=rightassociative(iterators,CROSS) - -suchthat ::= BAR where - -while ::= WHILE expression - -until ::= UNTIL expression - -forin ::= for variable IN segment | - for variable IN segment BY arith - -segment::= arith | arith SEG arith | arith SEG -\end{verbatim} - -A loop performs an iterated transformation of the state which is -specified by its statement component and its iterators. -The forin construction introduces a new variable which is assigned -the elements of the list which is the value of the segment in the order -in which they appear in the list . - -A segment of the form arith denotes a list, -and segments of the form "arith SEG arith" and -"arith SEG" denote terminating and non-terminating -arithmetic progressions. -The "BY arith" option is the step size, if omitted the step is 1. - -Two or more forin's may control a loop. -The associated lists are scanned in parallel and -a variable of one forin may not appear in the segment expression that -denotes the list in a second forin. -Such a variable may however occur in the conditions for filtering or -introduced by a suchthat, or for termination introduced by a -while iterator, and in the statement of the loop. -The forin variables are local to the statement, the conditions -that follow a while or suchthat in the same list of iterators and -have no meaning outside them. -The loop will be terminated when one of its forin lists is null, or -if the condition in a while is not satisfied. The list -elements are filtered by all the suchthat conditions. -The ordering of the iterators is irrelevant to the meaning, so it is -best to avoid side effects within the conditions for filtering and -termination. - -It is possible to control a loop by using a cross-product of iterators. -The iteration in the case iterators1 CROSS iterators2 is over -all pairs of list items one from the list denoted by -iterators1 and the other from the list denoted by iterators2. -In this case the variables introduced forin statements in iterators1 -may be used in iterators2. - -\subsubsection{Lists} - -Boot contains a simple way of specifying lists that are constructed -by CONS and APPEND, or by transforming one list to another in a -systematic manner. -\begin{verbatim} -construct ::= OBRACK construction CBRACK - -construction ::= comma | comma iteratortail - -iteratortail ::= REPEAT iterators | iterators -\end{verbatim} - -A construct expression denotes a list and may also have a list -of controlling iterators having the same syntax as a loop. In this -case the expression is enclosed in brackets and the iterators follow -the expression they qualify, rather than preceding it. - -In the case that there are no iterators the construct expression -denotes a list by listing its components separated by commas, or by -a comma followed by a colon. In the simple case in which there are no -colons the Boot expression [a,b,c,d] translates to the Lisp -(LIST a b c d) or (CONS a (CONS b (CONS c (CONS d NIL)))). - -When elements are separated by comma colon, however, the expression -that follows will be assumed to denote a list which will be appended -to the following list, rather than consed. An exception to this rule -is that a colon preceding the last expression is translated to -the expression itself. If it immediately preceded by a CONS -then it need not denote a list. - -For example: -\begin{verbatim} -[] is translated to the empty list NIL -[a] is translated to the 1-list (LIST a) or (CONS a NIL) -[:a] is translated to a -[a,b] is translated to the 2-list (LIST a b) or - (CONS a (CONS b NIL)) -[:a,b] is translated to (APPEND a (CONS b NIL)) -[a,:b] is translated to (CONS a b) -[:a,:b] is translated to (APPEND a b) -[:a,b,c] is translated to (APPEND a (CONS b (CONS c NIL))) -[a,:b,c] is translated to (CONS a (APPEND b (CONS c NIL))) -[a,b,:c] is translated to (CONS a (CONS b c)) -\end{verbatim} - -If the construct expression has iterators that control the production -of the list the resulting list depends on the form of the comma -expression. -i.e. -\begin{verbatim} -construction ::= comma iteratortail -\end{verbatim} - -If the comma expression is recognised as denoting a list -by either preceding it by a colon, or having commas at top level -as above, then the successive values are appended. If not then -the successive values are consed. -e.g. -\begin{verbatim} -[f i for i in x] denotes the list formed by applying f to each - member of the list x. - -[:f i for i in 0..n] denotes the list formed by appending the - lists f i for each i in 0..n. -\end{verbatim} - -\subsubsection{Patterns} -\begin{verbatim} -is ::= arith | arith IS pattern -\end{verbatim} - -The pattern in the proposition "arith IS pattern" has the same form -as the construct phrase without iterators. In this case, however it -denotes a class of lists rather than a list, and is composed -from identifiers rather than expressions. The proposition -is translated into a program that tests whether the arith expression -denotes a list that belongs to the class. If it does then the value -of the is expression is true and the identifiers in -the pattern are assigned the values of the corresponding -components of the list. If the list does not match the pattern -the value of the is expression is false and the values of the -identifier might be changed in some unknown way that reflects the -partial success of the matching. -Because of this uncertainty, -it is advisable to use the variables in a pattern -as new definitions rather than assigning to variables that are -defined elsewhere. -\begin{verbatim} -pattern::= identifier | constant | [ patternlist ] -\end{verbatim} - -The value of arith IS identifier is true and the value of arith -is assigned to the identifier. -(PROGN (SETQ identifier arith) T) -The expression arith IS constant is translated to (EQUAL constant arith). -The expression arith IS [ pattenlist ] -produces a program which tests whether arith denotes a list -of the right length and that each patternitem matches the corresponding -list component. - -\begin{verbatim} -patternitem ::= EQ application | DOT | pattern | name := pattern -\end{verbatim} - -If the patternitem is EQ application then the value is true if -the component is EQUAL to the value of the application expression. -If the patternitem is DOT then the value is true regardless of the -nature of the component. It is used as a place-holder to test -whether the component exists. -If the patternitem is pattern then the component is matched against -the pattern as above. -If the patternitem is name:=pattern then the component is matched against -the pattern as above, and if the value is true the component is assigned -to the name. This last provision enables both a component and -its components to be given names. -\begin{verbatim} -patternlist ::= listof(patternitem,COMMA)| - listof(patternitem,COMMA) COMMA patterntail - patterntail - -patterncolon ::= COLON patternitem - -patterntail ::= patterncolon | - patterncolon COMMA listof(patternitem,COMMA) -\end{verbatim} - -The patternlist may contain one colon to indicate that the following -patternitem can match a list of any length. In this case -the matching rule is to construct the expression -with CONS and APPEND from the pattern as shown above and then test -whether the list can be constructed in this way, and if so -deduce the components and assign them to identifiers. - -The effect of a pattern that occurs as a variable in a for iterator -is to filter the list by the pattern. -\begin{verbatim} -forin ::= for pattern IN segment -\end{verbatim} - -is translated to two iterators -\begin{verbatim} - for g IN segment | g IS pattern -\end{verbatim} -where g is an invented identifier. -\begin{verbatim} -forin ::= for (name:=pattern) IN segment -\end{verbatim} - -is translated to two iterators -\begin{verbatim} - for name IN segment BAR name IS pattern -\end{verbatim} - -in order to both filter the list elements, and name both elements and -their components. - -\subsubsection{Assignments} - -A pattern may also occur on the left hand side of an assignment -statement, and has a slightly different meaning. -The purpose in this case is to give names to the components -of the list which is the value of the right hand side. -In this case no checking -is done that the list matches the pattern precisely and the only -effect is to construct the selectors that correspond to -the identifiers in the pattern, apply them to the value of the -right hand side and assign the selected components -to the corresponding identifiers. -The effect of applying CAR or CDR to arguments to which they are not -applicable will depend on the underlying Lisp system. -\begin{verbatim} -assignment::= assignvariable BECOMES assignment| statement - -assignvariable := OBRACK patternlist CBRACK | assignlhs -\end{verbatim} - -The assignment having a pattern as its left hand side is reduced -as explained above to one or more assignments having an identifier -on the left hand side. -The meaning of the assignment depends on whether the identifier -starts with a dollar sign or not, if it is and whether it is followed by -:local or :fluid. -If the identifier does not start with a dollar sign it -is treated as local to the body of the function in which it -occurs, and -if it is not already an argument of the function, -a declaration to that effect is added to the Lisp code -by adding a PROG construction at top level within the body of the -function definition. - -If such an identifier assignment does not occur in the body -of a function but in a top level expression then -it is also treated as a local. The sole exception to this rule -is when the top level expression is an assignment to an identifier -in which case it is treated as global. - -If the left hand side of an assignment is an identifier that starts with -a dollar sign it will not be classified as a local but will -be treated as non-local. If it is also followed by :local then it -will be treated as a declaration of a FLUID (VMLisp) or SPECIAL -variable (Common Lisp) which will be given an initial value which is the -value of the right hand side of the assignment statement. -The FLUID or SPECIAL variables may be referred to or assigned to -by functions that are applied in the body of the declaration. - -If the left hand side of an assignment statement is -an identifier that does not start with a dollar sign followed -by :local then it will also be treated as a FLUID or SPECIAL -declaration, however it may only be assigned to in the body -of the function in which the assignment it occurs. -\begin{verbatim} -assignment::= assignvariable BECOMES assignment | statement - -assignvariable := OBRACK patternlist CBRACK | assignlhs - -assignlhs::= name | name COLON local | - name DOT primary DOT ... DOT primary -\end{verbatim} - -If the left hand side of an assignment has the form -\begin{verbatim} - name DOT primary DOT ... DOT primary -\end{verbatim} -the assignment statement will denote an updating of some component -of the value of name. In general name DOT primary := statement -will get translated to (SETELT name primary statement) or -(SETF (ELT name primary) statement) -There are however certain identifiers that denote components of -a list which will get translated to statements that update that -component (see appendix) e.g. -\begin{verbatim} -a.car:=b is translated to (SETF (CAR a) b) in Common Lisp. -\end{verbatim} -The iterated DOT is used to update components of components -and e.g - -\begin{verbatim} -a.b.c:=d is translated to (SETF (ELT (ELT a b)c) d) - -exit::= assignment | assignment EXIT where -\end{verbatim} - -The exit format "assignment EXIT where" is used to give a value to -a blockof or pileof statements in which it occurs at top level. - -The expression -\begin{verbatim} - (a =>b;c) will be translated to if a then b else c or - (COND (a b) (T c)) -\end{verbatim} - -If the exit is not a component of a blockof or pileof statements -then -\begin{verbatim} -a=>b will be translated to (COND (a b)) -\end{verbatim} - -\subsubsection{Definitions} - -Functions may be defined using the syntax -\begin{verbatim} -functiondefinition::= name DEF where | name variable DEF where - - -variable ::= parenthesized variablelist | pattern - -variableitem ::= - name| pattern | name BECOMES pattern | name IS pattern - -variablelist ::= variableitem | COLON name | - variableitem COMMA variablelist -\end{verbatim} - -Function definitions may only occur at to level or after a where. -The name is the name of the function being defined, and the -most frequently used form of the variable is either a single name -or a parenthesized list of names separated by commas. -In this case the translation to Lisp is straightforward, for example: -\begin{verbatim} -f x == E or f(x)==E is translated to (DEFUN f (x) TE) -f (x,y,z)==E is translated to (DEFUN f (x y z) TE) -f ()==E is translated to (DEFUN f () TE) -\end{verbatim} - -where TE is the translation of E. -At top level -\begin{verbatim} -f==E is translated to (DEFUN f () TE) -\end{verbatim} - -The function being defined is that which when applied to its arguments -produces the value of the body as result where the variables -in the body take on the values of its arguments. - -A pattern may also occur in the variable of a definition of a function -and serves the purpose, similar to the left hand side of assignments, -of naming the list components. -The phrase -\begin{verbatim} - name pattern DEF where -is translated to - name g DEF (pattern:=g;where) -\end{verbatim} - -similarly -\begin{verbatim} - name1 name2 := pattern DEF where or - name1 name2 is pattern DEF where - -are both translated to - name1 name2 DEF (pattern:=name2;where) -\end{verbatim} - -similarly for patterns that occur as components of a list of -variables. order -\begin{verbatim} -variablelist ::= - variableitem | COLON name | variableitem COMMA variablelist -\end{verbatim} - -The parenthesized variablelist that occurs as a variable of a function -definition can contain variables separated by commas but can also -have a comma colon as its last separator. - -This means that the function is applicable to lists of different -sizes and that only the first few elements corresponding to the -variables separated by commas are named, and -the last name after the colon denotes the rest of the list. - -Macros may be defined only at top level, and must always have a variable -\begin{verbatim} -macrodefinition::= name variable MDEF where -\end{verbatim} - -The effect of a macrodefinition is to produce a Lisp macro -which is applied to arguments that are treated as expressions, rather -than their values, and whose result if formed by first substituting -the expressions for occurrences of the variables within the body -and then evaluating the resulting expression. - -\subsubsection{Where Clauses} - -Expressions may be qualified by one or more function definitions -using the syntax -\begin{verbatim} -where ::= exit | exit WHERE qualifier - -qualifier ::= functiondefinition | - pileof (functiondefinition) | blockof functiondefinition -\end{verbatim} - -The functions may only be used within the expression that is qualified. -This feature has to be used with some care, however, because -a where clause may only occur within a function body, and -the component functions are extruded, so to speak, from their contexts -renamed, and made into top level function definitions. -As a result the variables of the outer function cannot be referred to -within the inner function. -If a qualifying function has the format "name DEF where" then -the where phrase is substituted for all occurences of the name -within the expression qualified. -If an expression is qualified by a phrase that is not a -function definition then the result will be a compound statement -in which the qualifying phrase is followed by the qualified phrase. - -\subsubsection{Tuples} - -Although a tuple may appear syntactically -in any position occupied by a primary -it will only be given meaning when it is the argument to a function. -To denote a list it has to be enclosed in brackets rather than -parentheses. A tuple at top level is treated as if its components -appeared at top level in the order of the list. -\begin{verbatim} -tuple::= parenthesized (listof (where,COMMA)) -\end{verbatim} - -\subsubsection{Blocks and Piles} - -\begin{verbatim} -block::= parenthesized (listof (where,SEMICOLON)) -pile::= piled (listof (listof(where,SEMICOLON),BACKSET)) -A block or a pile get translated to a compound statement or PROGN -\end{verbatim} - -\subsubsection{Top Level} - -\begin{verbatim} -toplevel ::= functiondefinition | macrodefinition | primary -\end{verbatim} - -\subsubsection{Translation Functions} - -\begin{verbatim} -(boottocl "filename") -translates the file "filename.boot" to -the common lisp file "filename.clisp" -\end{verbatim} - -\begin{verbatim} -(bootclam "filename") -translates the file "filename.boot" to -the common lisp file "filename.clisp" -\end{verbatim} - -producing, for each function a -hash table to store previously computed values indexed by argument -list. The function first looks in the hash table for the result -if there returns it, if not computes the result and stores it in the -table. - -\begin{verbatim} -(boottoclc "filename") -translates the file "filename.boot" to -the common lisp file "filename.oclisp" -with the original boot code as comments -\end{verbatim} - -\begin{verbatim} -(boot "filename") -translates the file "filename.boot" to -the common lisp file "filename.clisp", -compiles it to the file "filename.bbin" -and loads the bbin file. -\end{verbatim} - -\begin{verbatim} -(bo "filename") -translates the file "filename.boot" -and prints the result at the console -\end{verbatim} - -\begin{verbatim} -(stout "string") translates the string "string" -and prints the result at the console -\end{verbatim} - -\begin{verbatim} -(sttomc "string") translates the string "string" -to common lisp, and compiles the result. -\end{verbatim} - -\begin{verbatim} -(fc "functionname" "filename") -attempts to find the boot function -functionname in the file filename, -if found it translates it to common -lisp, compiles and loads it. -\end{verbatim} - -\begin{verbatim} -BOOT_-COMPILE_-DEFINITION_-FROM_-FILE(fn,symbol) - is similar to fc, fn is the file name but symbol is the symbol - of the function name rather than the string. -(fn,symbol) -\end{verbatim} - -\begin{verbatim} -BOOT_-EVAL_-DEFINITION_-FROM_-FILE(fn,symbol) -attempts to find the definition of symbol in file fn, -but this time translation is followed by EVAL rather -than COMPILE -\end{verbatim} - -\begin{verbatim} -(defuse "filename") -Translates the file filename, and writes a report of the -functions defined and not used, and used and not defined in the -file filename.defuse -\end{verbatim} - -\begin{verbatim} -(xref "filename") -Translates the file filename, and writes a report of the -names used, and where used to the file filename.xref -\end{verbatim} - -\section{The Makefile} -There is a directory called IN that contains the boot, clisp and lisp -code. This code gets copied into the intermediate directory [[${INT}/boot]] -so that the compiler has a writeable directory to change. This intermediate -code is then compiled into the current build directory -then, when all of the native object files are produced we construct a -lisp image that contains the boot translator, called [[bootsys]], which -lives in the [[${MNT}/${SYS}/bin]] directory. This [[bootsys]] image -is critical for the rest of the makefiles to succeed. - -code is then compiled into the [[${OUT}]] directory (which is in the object -directory for the type of machine code we are constructing (rt, ps2, rios)) -then, when all of the .o files are produced we construct a lisp image that -contains the boot translator, called bootsys, which lives in the mnt/sys/bin -directory. this bootsys image is critical for the rest of the makefiles to -succeed. - -There are two halves of this file. the first half compiles the .lisp files -that live in the src/boot directory. the second half compiles the .clisp -files (which are generated from the .boot files). It is important that -the .clisp files are kept in the src/boot directory for the boot translator -as they cannot be recreated without a boot translator (a bootstrap problem). - -An important subtlety is that files in the boot translator depend on the -file npextras. there are 3 macros in npextras that must be in the lisp -workspace (\verb$|shoeOpenInputFile| |shoeOpenOutputFile| memq$). - -\subsection{Directories} -<>= -IN=${SRC}/boot -MID=${INT}/boot -OUT=${OBJ}/${SYS}/boot -DOC=${MNT}/${SYS}/doc/src/boot - -@ -\subsection{Environment} -\subsubsection{Lisp Images} -We will use create and use several lisp images during the build -process. We name them here for convenience. - -The {\bf LISPSYS} -image we will use to compile the common lisp -code to machine code. - -The {\bf BOOTSYS} image we need to run to translate boot files -to common lisp files. - -The {\bf LOADSYS} image is a clean lisp image that we load -with compiled files to be saved. - -The {\bf SAVESYS} image is the final name we will use as the -result of this Makefile. - -Since this is a boot-strapping process we are in one of two -possible states. Either {\bf BOOTSYS} exists and we can use -it immediately or we need to construct it and then use it. -You'll notice that {\bf BOOTSYS} and {\bf SAVESYS} correspond -to these two cases. - -<>= -LISPSYS= ${OBJ}/${SYS}/bin/lisp -BOOTSYS= ${OBJ}/${SYS}/bin/bootsys -LOADSYS= ${OBJ}/${SYS}/bin/lisp -SAVESYS= ${OBJ}/${SYS}/bin/bootsys - -@ -\subsection{The list of files} -This is a list of all of the files that must be loaded to construct the -boot translator image. Note that the order is important as earlier files -will contain code needed by later files. - -Note that the {\bf OBJS1} list differs from the {\bf OBJS} list only -in that the first has each name surrounded by quotes. The {\bf OBJS1} -list is fed to lisp and the {\bf OBJS} list is used by make. Keep these -exactly in sync, including ordering, unless you have a {\sl very} good -reason. -<>= -OBJS1= "${OUT}/boothdr.${O}" "${OUT}/exports.${O}" \ - "${OUT}/npextras.${O}" "${OUT}/ptyout.${O}" \ - "${OUT}/btincl2.${O}" "${OUT}/btscan2.${O}" \ - "${OUT}/typrops.${O}" "${OUT}/btpile2.${O}" \ - "${OUT}/typars.${O}" "${OUT}/tyextra.${O}" \ - "${OUT}/tytree1.${O}" -OBJS= ${OUT}/boothdr.${O} ${OUT}/exports.${O} \ - ${OUT}/npextras.${O} ${OUT}/ptyout.${O} \ - ${OUT}/btincl2.${O} ${OUT}/btscan2.${O} \ - ${OUT}/typrops.${O} ${OUT}/btpile2.${O} \ - ${OUT}/typars.${O} ${OUT}/tyextra.${O} \ - ${OUT}/tytree1.${O} - -@ - -\subsubsection{The Bootstrap files} - -{\bf BOOTS} is a list of the boot file targets. If you modify a -boot file you'll have to explicitly build the clisp files and -merge the generated code back into the pamphlet by hand. The -assumption is that if you know enough to change the fundamental -bootstrap files you know how to migrate the changes back. -This process, by design, does not occur automatically (though it -could). - -The files in the {\bf BOOTS} list are needed to bootstrap the boot -parser. They are written in boot. Invoking this Makefile with -\begin{verbatim} - make boot BOOTSYS=(path to bootsys) BYE=(lisp exit fn) -\end{verbatim} -will run notangle on the pamphlet files to create the raw boot files. -The raw boot files are translated in a {\bf bootsys} image using the -{\bf boottocl} function to create the raw clisp files. - -<>= -BOOTS=ptyout.boot btincl2.boot typrops.boot btpile2.boot \ - typars.boot tyextra.boot trtree1.boot -@ -\section{Proclaim optimization} -GCL, and possibly other common lisps, can generate much better -code if the function argument types and return values are proclaimed. - -In theory what we should do is scan all of the functions in the system -and create a file of proclaim definitions. These proclaim definitions -should be loaded into the image before we do any compiles so they can -allow the compiler to optimize function calling. - -GCL has an approximation to this scanning which we use here. - -The first step is to build a version of GCL that includes gcl\_collectfn. -This file contains code that enhances the lisp compiler and creates a -hash table of structs. Each struct in the hash table describes information -that about the types of the function being compiled and the types of its -arguments. At the end of the compile-file this hash table is written out -to a ".fn" file. - -The second step is to build axiom images (depsys, interpsys, AXIOMsys) -which contain the gcl\_collectfn code. - -The third step is to build the system. This generates a .fn file for -each lisp file that gets compiled. - -The fourth step is to build the proclaims.lisp files. There is one -proclaims.lisp file for -boot (boot-proclaims.lisp), -interp (interp-proclaims.lisp), and -algebra (algebra-proclaims.lisp). - -To build the proclaims file (e.g. for interp) we: -\begin{verbatim} -(a) cd to obj/linux/interp -(b) (yourpath)/axiom/obj/linux/bin/lisp -(c) (load "sys-pkg.lsp") -(d) (mapcar #'load (directory "*.fn")) -(e) (with-open-file - (out "interp-proclaims.lisp" :direction :output) - (compiler::make-proclaims out)) -\end{verbatim} -Note that step (c) is only used for interp, not for boot. - -The fifth step is to copy the newly constructed proclaims file back -into the src/interp diretory (or boot, algebra). - -In order for this information to be used during compiles we define -<>= -PROCLAIMS=(load "${IN}/boot-proclaims.lisp") - -@ - -\section{Special Commands} -We are working in a build environment that combines Makefile -technology with Lisp technology. Instead of invoking a command -like {\bf gcc} and giving it arguments we will be creating -Lisp S-expressions and piping them into a Lisp image. The -Lisp image starts, reads the S-expression from standard input, -evaluates it, and finding an end-of-stream on standard input, exits. - -There are two special S-expressions that we collect here. The first, -{\bf DEPS} will load all of the macros and functions -needed to compile a common lisp file that was translated from boot. -These are collected into the {\bf npextras.lisp} \cite{6}) file. - -Note that the [[']] symbol should not appear in this S-expression -because the {\bf DEPS} command will be expanded into a shell -echo command and it will be surrounded by single quotes at the -expansion. Adding a single quote symbol will break this expansion. - -<>= -DEPS= (load (quote $(patsubst %, "%", ${MID}/npextras.lisp))) - -@ - -The {\bf CMD0} S-expression is the command line we use to create -the final {\bf SAVESYS} image. This S-expression will be given to -a clean lisp image, loaded with the compiled files, and saved. - -Note that the [[']] symbol should not appear in this S-expression -because the {\bf CMD0} command will be expanded into a shell -echo command and it will be surrounded by single quotes at the -expansion. Adding a single quote symbol will break this expansion. - -The environment variable used to read: -\begin{verbatim} -CMD0= (progn \ - (mapcar \ - (function (lambda (x) (load x))) \ - (quote (${OBJS1}))) \ - (system::save-system "${SAVESYS}")) -\end{verbatim} -but has been changed to allow dynamic linking. The issue is that -some versions of the loader on some systems cannot save dynamically -loaded code. The new [[CMD0]] string is rumored to work with both -loaders. - -In fact, the new [[CMD0]] reads: -\begin{verbatim} -CMD0=(compiler::link (quote (${OBJS1})) "${SAVESYS}" \ - (format nil \ - "(let ((*load-path* (cons ~S *load-path*)) \ - (si::*load-types* ~S)) \ - (compiler::emit-fn t)) \ - (when (fboundp (quote si::sgc-on)) (si::sgc-on t)) \ - (setq compiler::*default-system-p* t)" \ - si::*system-directory* (quote (list ".lsp")))) -\end{verbatim} -and it does not work. The failure is a series of messages: -\begin{verbatim} -/home/axiom33/obj/linux/boot/exports.o(.text+0x0): - In function `init_code': - : multiple definition of `init_code' -/home/axiom33/obj/linux/boot/boothdr.o(.text+0x0): - first defined here -\end{verbatim} -and the problem appears to be that each [[.o]] file has [[init_code]]. - -Until this is fixed we need to continue to use the old scheme. -<>= -CMD0=(progn \ - (mapcar (function (lambda (x) (load x))) (quote (${OBJS1}))) \ - (system::save-system "${SAVESYS}")) - -@ -\subsection{boothdr.lisp \cite{1}} - -<>= -${OUT}/boothdr.${O}: ${MID}/boothdr.lisp - @ echo 1 making ${OUT}/boothdr.${O} from ${MID}/boothdr.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn ${PROCLAIMS}' \ - '(compile-file "boothdr.lisp" :output-file "${OUT}/boothdr.${O}")' \ - '(${BYE}))' | ${LISPSYS} ; \ - else \ - echo '(progn ${PROCLAIMS}' \ - '(compile-file "boothdr.lisp" :output-file "${OUT}/boothdr.${O}")' \ - '(${BYE}))' | ${LISPSYS} >${TMP}/trace ; \ - fi ) - -@ - -<>= -${MID}/boothdr.lisp: ${IN}/boothdr.lisp.pamphlet - @echo 2 making ${MID}/boothdr.lisp from ${IN}/boothdr.lisp.pamphlet - @${TANGLE} boothdr.lisp.pamphlet >${MID}/boothdr.lisp - -@ - -<>= -${DOC}/boothdr.lisp.dvi: ${IN}/boothdr.lisp.pamphlet - @echo 3 making ${DOC}/boothdr.lisp.dvi from ${IN}/boothdr.lisp.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/boothdr.lisp.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} boothdr.lisp ; \ - rm -f ${DOC}/boothdr.lisp.pamphlet ; \ - rm -f ${DOC}/boothdr.lisp.tex ; \ - rm -f ${DOC}/boothdr.lisp ) - -@ - -\subsection{btincl2.lisp \cite{2}} - -Notice that the progn special form that wraps the compile-file -function call executes {\bf DEPS} first. The {\bf DEPS} variable -expands into an s-expression that will load {\bf npextras.lisp}. -This file contains macros needed at compile time. - -<>= -${OUT}/btincl2.${O}: ${MID}/btincl2.lisp - @ echo 4 making ${OUT}/btincl2.${O} from ${MID}/btincl2.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "btincl2.lisp" :output-file "${OUT}/btincl2.${O}")' \ - '(${BYE}))' | ${LISPSYS} ; \ - else \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "btincl2.lisp" :output-file "${OUT}/btincl2.${O}")' \ - '(${BYE}))' | ${LISPSYS} >${TMP}/trace ; \ - fi ) - -@ - -<>= -${MID}/btincl2.lisp: ${IN}/btincl2.boot.pamphlet - @echo 5 making ${MID}/btincl2.lisp from ${IN}/btincl2.boot.pamphlet - @${TANGLE} -Rbtincl2.clisp btincl2.boot.pamphlet >${MID}/btincl2.lisp - -@ - -<>= -${DOC}/btincl2.boot.dvi: ${IN}/btincl2.boot.pamphlet - @echo 6 making ${DOC}/btincl2.lisp.dvi from \ - ${IN}/btincl2.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/btincl2.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} btincl2.boot ; \ - rm -f ${DOC}/btincl2.boot.pamphlet ; \ - rm -f ${DOC}/btincl2.boot.tex ; \ - rm -f ${DOC}/btincl2.boot ) - -@ - -<>= -btincl2.boot: btincl2.boot.pamphlet - @echo 7 making btincl2.boot from btincl2.boot.pamphlet - @( ${TANGLE} btincl2.boot.pamphlet >btincl2.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "btincl2.boot") (${BYE}))' \ - | ${BOOTSYS} ; \ - else \ - echo '(progn (boottran::boottocl "btincl2.boot") (${BYE}))' \ - | ${BOOTSYS} >${TMP}/trace ; \ - fi ) - -@ - -\subsection{btpile2.boot \cite{3}} - -Notice that the progn special form that wraps the compile-file -function call executes {\bf DEPS} first. The {\bf DEPS} variable -expands into an s-expression that will load {\bf npextras.lisp}. -This file contains macros needed at compile time. - -<>= -${OUT}/btpile2.${O}: ${MID}/btpile2.lisp - @ echo 8 making ${OUT}/btpile2.${O} from ${MID}/btpile2.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "btpile2.lisp" :output-file "${OUT}/btpile2.${O}")' \ - '(${BYE}))' | ${LISPSYS} ; \ - else \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "btpile2.lisp" :output-file "${OUT}/btpile2.${O}")' \ - '(${BYE}))' | ${LISPSYS} >${TMP}/trace ; \ - fi ) - -@ - -<>= -${MID}/btpile2.lisp: ${IN}/btpile2.boot.pamphlet - @echo 9 making ${MID}/btpile2.lisp from ${IN}/btpile2.boot.pamphlet - @${TANGLE} -Rbtpile2.clisp btpile2.boot.pamphlet >${MID}/btpile2.lisp - -@ - -<>= -${DOC}/btpile2.boot.dvi: ${IN}/btpile2.boot.pamphlet - @echo 10 making ${DOC}/btpile2.boot.dvi from \ - ${IN}/btpile2.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/btpile2.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} btpile2.boot ; \ - rm -f ${DOC}/btpile2.boot.pamphlet ; \ - rm -f ${DOC}/btpile2.boot.tex ; \ - rm -f ${DOC}/btpile2.boot ) - -@ - -<>= -btpile2.boot: btpile2.boot.pamphlet - @echo 11 making btpile2.boot from btpile2.boot.pamphlet - @( ${TANGLE} btpile2.boot.pamphlet >btpile2.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "btpile2.boot") (${BYE}))' \ - | ${BOOTSYS} ; \ - else \ - echo '(progn (boottran::boottocl "btpile2.boot") (${BYE}))' \ - | ${BOOTSYS} >${TMP}/trace ; \ - fi ) - -@ - -\subsection{btscan2.boot \cite{4}} - -Notice that the progn special form that wraps the compile-file -function call executes {\bf DEPS} first. The {\bf DEPS} variable -expands into an s-expression that will load {\bf npextras.lisp}. -This file contains macros needed at compile time. - -<>= -${OUT}/btscan2.${O}: ${MID}/btscan2.lisp - @ echo 12 making ${OUT}/btscan2.${O} from ${MID}/btscan2.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "btscan2.lisp" :output-file "${OUT}/btscan2.${O}")' \ - '(${BYE}))' | ${LISPSYS} ; \ - else \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "btscan2.lisp" :output-file "${OUT}/btscan2.${O}")' \ - '(${BYE}))' | ${LISPSYS} >${TMP}/trace ; \ - fi ) - -@ - -<>= -${MID}/btscan2.lisp: ${IN}/btscan2.boot.pamphlet - @echo 13 making ${MID}/btscan2.lisp from ${IN}/btscan2.boot.pamphlet - @${TANGLE} -Rbtscan2.clisp btscan2.boot.pamphlet >${MID}/btscan2.lisp - -@ - -<>= -${DOC}/btscan2.boot.dvi: ${IN}/btscan2.boot.pamphlet - @echo 14 making ${DOC}/btscan2.boot.dvi from \ - ${IN}/btscan2.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/btscan2.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} btscan2.boot ; \ - rm -f ${DOC}/btscan2.boot.pamphlet ; \ - rm -f ${DOC}/btscan2.boot.tex ; \ - rm -f ${DOC}/btscan2.boot ) - -@ - -<>= -btscan2.boot: btscan2.boot.pamphlet - @echo 15 making btscan2.boot from btscan2.boot.pamphlet - @( ${TANGLE} btscan2.boot.pamphlet >btscan2.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "btscan2.boot") (${BYE}))' \ - | ${BOOTSYS} ; \ - else \ - echo '(progn (boottran::boottocl "btscan2.boot") (${BYE}))' \ - | ${BOOTSYS} >${TMP}/trace ; \ - fi ) - -@ - -\subsection{exports.lisp \cite{5}} - -<>= -${OUT}/exports.${O}: ${MID}/exports.lisp - @ echo 16 making ${OUT}/exports.${O} from ${MID}/exports.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn ${PROCLAIMS}' \ - '(compile-file "exports.lisp" :output-file "${OUT}/exports.${O}")' \ - '(${BYE}))' | ${LISPSYS} ; \ - else \ - echo '(progn ${PROCLAIMS}' \ - '(compile-file "exports.lisp" :output-file "${OUT}/exports.${O}")' \ - '(${BYE}))' | ${LISPSYS} >${TMP}/trace ; \ - fi ) - -@ - -<>= -${MID}/exports.lisp: ${IN}/exports.lisp.pamphlet - @echo 17 making ${MID}/exports.lisp from ${IN}/exports.lisp.pamphlet - @${TANGLE} exports.lisp.pamphlet >${MID}/exports.lisp - -@ - -<>= -${DOC}/exports.lisp.dvi: ${IN}/exports.lisp.pamphlet - @echo 18 making ${DOC}/exports.lisp.dvi from \ - ${IN}/exports.lisp.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/exports.lisp.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} exports.lisp ; \ - rm -f ${DOC}/exports.lisp.pamphlet ; \ - rm -f ${DOC}/exports.lisp.tex ; \ - rm -f ${DOC}/exports.lisp ) - -@ - -\subsection{npextras.lisp \cite{6}} - -<>= -${OUT}/npextras.${O}: ${MID}/npextras.lisp - @ echo 19 making ${OUT}/npextras.${O} from ${MID}/npextras.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn ${PROCLAIMS}' \ - '(compile-file "npextras.lisp" :output-file "${OUT}/npextras.${O}")' \ - '(${BYE}))' | ${LISPSYS} ; \ - else \ - echo '(progn ${PROCLAIMS}' \ - '(compile-file "npextras.lisp" :output-file "${OUT}/npextras.${O}")' \ - '(${BYE}))' | ${LISPSYS} >${TMP}/trace ; \ - fi ) - -@ - -<>= -${MID}/npextras.lisp: ${IN}/npextras.lisp.pamphlet - @echo 20 making ${MID}/npextras.lisp from ${IN}/npextras.lisp.pamphlet - @${TANGLE} npextras.lisp.pamphlet >${MID}/npextras.lisp - -@ - -<>= -${DOC}/npextras.lisp.dvi: ${IN}/npextras.lisp.pamphlet - @echo 21 making ${DOC}/npextras.lisp.dvi from \ - ${IN}/npextras.lisp.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/npextras.lisp.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} npextras.lisp ; \ - rm -f ${DOC}/npextras.lisp.pamphlet ; \ - rm -f ${DOC}/npextras.lisp.tex ; \ - rm -f ${DOC}/npextras.lisp ) - -@ - -\subsection{ptyout.lisp \cite{7}} - -Notice that the progn special form that wraps the compile-file -function call executes {\bf DEPS} first. The {\bf DEPS} variable -expands into an s-expression that will load {\bf npextras.lisp}. -This file contains macros needed at compile time. - -<>= -${OUT}/ptyout.${O}: ${MID}/ptyout.lisp - @ echo 22 making ${OUT}/ptyout.${O} from ${MID}/ptyout.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "ptyout.lisp" :output-file "${OUT}/ptyout.${O}")' \ - '(${BYE}))' | ${LISPSYS} ; \ - else \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "ptyout.lisp" :output-file "${OUT}/ptyout.${O}")' \ - '(${BYE}))' | ${LISPSYS} >${TMP}/trace ; \ - fi ) - -@ - -<>= -${MID}/ptyout.lisp: ${IN}/ptyout.boot.pamphlet - @echo 23 making ${MID}/ptyout.lisp from ${IN}/ptyout.boot.pamphlet - @${TANGLE} -Rptyout.clisp ptyout.boot.pamphlet >${MID}/ptyout.lisp - -@ - -<>= -${DOC}/ptyout.boot.dvi: ${IN}/ptyout.boot.pamphlet - @echo 24 making ${DOC}/ptyout.boot.dvi from ${IN}/ptyout.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/ptyout.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} ptyout.boot ; \ - rm -f ${DOC}/ptyout.boot.pamphlet ; \ - rm -f ${DOC}/ptyout.boot.tex ; \ - rm -f ${DOC}/ptyout.boot ) - -@ - -<>= -ptyout.boot: ptyout.boot.pamphlet - @echo 25 making ptyout.boot from ptyout.boot.pamphlet - @( ${TANGLE} ptyout.boot.pamphlet >ptyout.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "ptyout.boot") (${BYE}))' \ - | ${BOOTSYS} ; \ - else \ - echo '(progn (boottran::boottocl "ptyout.boot") (${BYE}))' \ - | ${BOOTSYS} >${TMP}/trace ; \ - fi ) - -@ - -\subsection{tyextra.lisp \cite{8}} - -Notice that the progn special form that wraps the compile-file -function call executes {\bf DEPS} first. The {\bf DEPS} variable -expands into an s-expression that will load {\bf npextras.lisp}. -This file contains macros needed at compile time. - -<>= -${OUT}/tyextra.${O}: ${MID}/tyextra.lisp - @ echo 26 making ${OUT}/tyextra.${O} from ${MID}/tyextra.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "tyextra.lisp" :output-file "${OUT}/tyextra.${O}")' \ - '(${BYE}))' | ${LISPSYS} ; \ - else \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "tyextra.lisp" :output-file "${OUT}/tyextra.${O}")' \ - '(${BYE}))' | ${LISPSYS} >${TMP}/trace ; \ - fi ) - -@ - -<>= -${MID}/tyextra.lisp: ${IN}/tyextra.boot.pamphlet - @echo 27 making ${MID}/tyextra.lisp from ${IN}/tyextra.boot.pamphlet - @${TANGLE} -Rtyextra.clisp tyextra.boot.pamphlet >${MID}/tyextra.lisp - -@ - -<>= -${DOC}/tyextra.boot.dvi: ${IN}/tyextra.boot.pamphlet - @echo 28 making ${DOC}/tyextra.boot.dvi from \ - ${IN}/tyextra.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/tyextra.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} tyextra.boot ; \ - rm -f ${DOC}/tyextra.boot.pamphlet ; \ - rm -f ${DOC}/tyextra.boot.tex ; \ - rm -f ${DOC}/tyextra.boot ) - -@ - -<>= -tyextra.boot: tyextra.boot.pamphlet - @echo 29 making tyextra.boot from tyextra.boot.pamphlet - @( ${TANGLE} tyextra.boot.pamphlet >tyextra.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "tyextra.boot") (${BYE}))' \ - | ${BOOTSYS} ; \ - else \ - echo '(progn (boottran::boottocl "tyextra.boot") (${BYE}))' \ - | ${BOOTSYS} >${TMP}/trace ; \ - fi ) - -@ - -\subsection{typars.lisp \cite{9}} - -Notice that the progn special form that wraps the compile-file -function call executes {\bf DEPS} first. The {\bf DEPS} variable -expands into an s-expression that will load {\bf npextras.lisp}. -This file contains macros needed at compile time. - -<>= -${OUT}/typars.${O}: ${MID}/typars.lisp - @ echo 30 making ${OUT}/typars.${O} from ${MID}/typars.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "typars.lisp" :output-file "${OUT}/typars.${O}")' \ - '(${BYE}))' | ${LISPSYS} ; \ - else \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "typars.lisp" :output-file "${OUT}/typars.${O}")' \ - '(${BYE}))' | ${LISPSYS} >${TMP}/trace ; \ - fi ) - -@ - -<>= -${MID}/typars.lisp: ${IN}/typars.boot.pamphlet - @echo 31 making ${MID}/typars.lisp from ${IN}/typars.boot.pamphlet - @${TANGLE} -Rtypars.clisp typars.boot.pamphlet >${MID}/typars.lisp - -@ - -<>= -${DOC}/typars.boot.dvi: ${IN}/typars.boot.pamphlet - @echo 32 making ${DOC}/typars.boot.dvi from ${IN}/typars.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/typars.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} typars.boot ; \ - rm -f ${DOC}/typars.boot.pamphlet ; \ - rm -f ${DOC}/typars.boot.tex ; \ - rm -f ${DOC}/typars.boot ) - -@ - -<>= -typars.boot: typars.boot.pamphlet - @echo 33 making typars.boot from typars.boot.pamphlet - @( ${TANGLE} typars.lisp.pamphlet >typars.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "typars.boot") (${BYE}))' \ - | ${BOOTSYS} ; \ - else \ - echo '(progn (boottran::boottocl "typars.boot") (${BYE}))' \ - | ${BOOTSYS} >${TMP}/trace ; \ - fi ) - -@ - -\subsection{typrops.lisp \cite{10}} - -Notice that the progn special form that wraps the compile-file -function call executes {\bf DEPS} first. The {\bf DEPS} variable -expands into an s-expression that will load {\bf npextras.lisp}. -This file contains macros needed at compile time. - -<>= -${OUT}/typrops.${O}: ${MID}/typrops.lisp - @ echo 34 making ${OUT}/typrops.${O} from ${MID}/typrops.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "typrops.lisp" :output-file "${OUT}/typrops.${O}")' \ - '(${BYE}))' | ${LISPSYS} ; \ - else \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "typrops.lisp" :output-file "${OUT}/typrops.${O}")' \ - '(${BYE}))' | ${LISPSYS} >${TMP}/trace ; \ - fi ) - -@ - -<>= -${MID}/typrops.lisp: ${IN}/typrops.boot.pamphlet - @echo 35 making ${MID}/typrops.lisp from ${IN}/typrops.boot.pamphlet - @${TANGLE} -Rtyprops.clisp typrops.boot.pamphlet >${MID}/typrops.lisp - -@ - -<>= -${DOC}/typrops.boot.dvi: ${IN}/typrops.boot.pamphlet - @echo 36 making ${DOC}/typrops.boot.dvi from \ - ${IN}/typrops.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/typrops.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} typrops.boot ; \ - rm -f ${DOC}/typrops.boot.pamphlet ; \ - rm -f ${DOC}/typrops.boot.tex ; \ - rm -f ${DOC}/typrops.boot ) - -@ - -<>= -typrops.boot: typrops.boot.pamphlet - @echo 37 making typrops.boot from typrops.boot.pamphlet - @( ${TANGLE} typrops.boot.pamphlet >typrops.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "typrops.boot") (${BYE}))' \ - | ${BOOTSYS} ; \ - else \ - echo '(progn (boottran::boottocl "typrops.boot") (${BYE}))' \ - | ${BOOTSYS} >${TMP}/trace ; \ - fi ) - -@ - -\subsection{tytree1.lisp \cite{11}} - -Notice that the progn special form that wraps the compile-file -function call executes {\bf DEPS} first. The {\bf DEPS} variable -expands into an s-expression that will load {\bf npextras.lisp}. -This file contains macros needed at compile time. - -<>= -${OUT}/tytree1.${O}: ${MID}/tytree1.lisp - @ echo 38 making ${OUT}/tytree1.${O} from ${MID}/tytree1.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "tytree1.lisp" :output-file "${OUT}/tytree1.${O}")' \ - '(${BYE}))' | ${LISPSYS} ; \ - else \ - echo '(progn ${PROCLAIMS} ${DEPS}' \ - '(compile-file "tytree1.lisp" :output-file "${OUT}/tytree1.${O}")' \ - '(${BYE}))' | ${LISPSYS} >${TMP}/trace ; \ - fi ) - -@ - -<>= -${MID}/tytree1.lisp: ${IN}/tytree1.boot.pamphlet - @echo 39 making ${MID}/tytree1.lisp from ${IN}/tytree1.boot.pamphlet - @${TANGLE} -Rtytree1.clisp tytree1.boot.pamphlet >${MID}/tytree1.lisp - -@ - -<>= -${DOC}/tytree1.boot.dvi: ${IN}/tytree1.boot.pamphlet - @echo 40 making ${DOC}/tytree1.boot.dvi from \ - ${IN}/tytree1.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/tytree1.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} tytree1.boot ; \ - rm -f ${DOC}/tytree1.boot.pamphlet ; \ - rm -f ${DOC}/tytree1.boot.tex ; \ - rm -f ${DOC}/tytree1.boot ) - -@ - -<>= -tytree1.boot: tytree1.boot.pamphlet - @echo 41 making tytree1.boot from tytree1.boot.pamphlet - @( ${TANGLE} tytree1.boot.pamphlet >tytree1.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "tytree1.boot") (${BYE}))' \ - | ${BOOTSYS} ; \ - else \ - echo '(progn (boottran::boottocl "tytree1.boot") (${BYE}))' \ - | ${BOOTSYS} >${TMP}/trace ; \ - fi ) - -@ -\section{Making the documentation} -<>= -DOCFILES=${DOC}/boothdr.lisp.dvi ${DOC}/btincl2.boot.dvi \ - ${DOC}/btpile2.boot.dvi ${DOC}/btscan2.boot.dvi \ - ${DOC}/exports.lisp.dvi ${DOC}/npextras.lisp.dvi \ - ${DOC}/ptyout.boot.dvi ${DOC}/tyextra.boot.dvi \ - ${DOC}/typars.boot.dvi ${DOC}/typrops.boot.dvi \ - ${DOC}/tytree1.boot.dvi - -@ - -<>= -document: ${DOCFILES} - @ echo 42 making tex and dvi files in ${DOC} - -@ -\section{Cleanup} -<>= -clean: - @echo 43 cleaning ${OUT} - @rm -rf ${OUT} - -@ -\section{The Makefile} -<<*>>= -<> -<> - -# this stanza will create the final bootsys image - -${SAVESYS}: ${OBJS} ${LOADSYS} ${DOCFILES} - @ echo 44 invoking make in `pwd` with parms: - @ echo SYS= ${SYS} - @ echo LSP= ${LSP} - @ echo PART= ${PART} - @ echo SPAD= ${SPAD} - @ echo SRC= ${SRC} - @ echo INT= ${INT} - @ echo OBJ= ${OBJ} - @ echo MNT= ${MNT} - @ (cd ${OBJ}/${SYS}/bin ; echo '${CMD0}' | ${LOADSYS} >${TMP}/console ) - @ echo 45 ${SAVESYS} created - -boot: ${BOOTS} - -<> -<> -<> - -<> -<> -<> - -<> -<> -<> - -<> -<> -<> -<> - -<> -<> -<> -<> - -<> -<> -<> -<> - -<> -<> -<> -<> - -<> -<> -<> -<> - -<> -<> -<> -<> - -<> -<> -<> -<> - -<> -<> -<> -<> - -<> -<> -@ - -\eject -\begin{thebibliography}{99} -\bibitem{1} \$SPAD/src/boot/boothdr.lisp.pamphlet -\bibitem{2} \$SPAD/src/boot/btincl2.boot.pamphlet -\bibitem{3} \$SPAD/src/boot/btpile2.boot.pamphlet -\bibitem{4} \$SPAD/src/boot/btscan2.boot.pamphlet -\bibitem{5} \$SPAD/src/boot/exports.lisp.pamphlet -\bibitem{6} \$SPAD/src/boot/npextras.lisp.pamphlet -\bibitem{7} \$SPAD/src/boot/ptyout.boot.pamphlet -\bibitem{8} \$SPAD/src/boot/tyextra.boot.pamphlet -\bibitem{9} \$SPAD/src/boot/typars.boot.pamphlet -\bibitem{10} \$SPAD/src/boot/typrops.boot.pamphlet -\bibitem{11} \$SPAD/src/boot/tytree1.boot.pamphlet -\end{thebibliography} -\end{document} diff --git a/src/boot/boot-proclaims.lisp b/src/boot/boot-proclaims.lisp deleted file mode 100644 index 996cd46..0000000 --- a/src/boot/boot-proclaims.lisp +++ /dev/null @@ -1,561 +0,0 @@ -(make-package "BOOT" :USE '("LISP")) - -(make-package "BOOTTRAN" :USE '("LISP")) - -(IN-PACKAGE "BOOT") - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T) (*)) - BOOTTRAN::STRINGIMAGE))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T *) (VALUES T T)) - BOOTTRAN::|shoeread-line|))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T T) FIXNUM) - BOOTTRAN::QENUM))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T T T) *) - BOOTTRAN::|shoeGeneralFC|))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T T T T) T) - BOOTTRAN::STRPOSL - BOOTTRAN::|shoeLAM| - BOOTTRAN::|shoeClLines| - BOOTTRAN::|bfMDef| - BOOTTRAN::|shoeClCLines| - BOOTTRAN::|bfOpReduce| - BOOTTRAN::|bfSTEP| - BOOTTRAN::|bfDef| - BOOTTRAN::STRPOS - BOOTTRAN::|shoeConstructToken| - BOOTTRAN::|shoePackageStartsAt|))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T T T) T) - BOOTTRAN::|bfIf| - BOOTTRAN::SUBSTRING - BOOTTRAN::|shoeElse1| - BOOTTRAN::|shoeFindName2| - BOOTTRAN::|bfForInBy| - BOOTTRAN::|bfMDefinition2| - BOOTTRAN::|shoeSubStringMatch| - BOOTTRAN::|shoeFindLines| - BOOTTRAN::|bpListofFun| - BOOTTRAN::|shoeElse| - BOOTTRAN::|shoeLeafFloat| - BOOTTRAN::|shoeThen| - BOOTTRAN::|bpList| - BOOTTRAN::|bfCompHash| - BOOTTRAN::|bfCI| - BOOTTRAN::|bfListReduce| - BOOTTRAN::|shoeThen1| - BOOTTRAN::|bfLp2| - BOOTTRAN::|bfFor| - BOOTTRAN::|bpListof| - BOOTTRAN::|bfPosn| - BOOTTRAN::|shoePileForests| - BOOTTRAN::|bfISApplication| - BOOTTRAN::|bfSetelt| - BOOTTRAN::|defSETELT| - BOOTTRAN::|shoeTokConstruct| - BOOTTRAN::|bootOutLines| - BOOTTRAN::BVEC-SETELT - BOOTTRAN::|bpAndOr| - BOOTTRAN::|bfForTree| - BOOTTRAN::HPUT - BOOTTRAN::|bfDefinition2| - BOOTTRAN::|stripm| - BOOTTRAN::VEC-SETELT - BOOTTRAN::|shoeFindName| - BOOTTRAN::|bfInfApplication|))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION NIL T) - BOOTTRAN::|shoeNegComment| - BOOTTRAN::|bpSeg| - BOOTTRAN::|bpIs| - BOOTTRAN::|shoeStartsNegComment| - BOOTTRAN::|bpDef| - BOOTTRAN::|shoeComment| - BOOTTRAN::|shoeStartsComment| - BOOTTRAN::|bpPrimary| - BOOTTRAN::|bpPrimary1| - BOOTTRAN::|bpPileItems| - BOOTTRAN::|bpCrossBackSet| - BOOTTRAN::|bpDefinition| - BOOTTRAN::|bpExpt| - BOOTTRAN::|bpExit| - BOOTTRAN::|bpState| - BOOTTRAN::|bpPatternColon| - BOOTTRAN::|bpPop3| - BOOTTRAN::|bpDefinitionPileItems| - BOOTTRAN::|bpSexpKey| - BOOTTRAN::|bpExceptions| - BOOTTRAN::|bpSemiBackSet| - BOOTTRAN::|bpIterator| - BOOTTRAN::|shoeEsc| - BOOTTRAN::|bpUntil| - BOOTTRAN::|bpWhile| - BOOTTRAN::|bpForIn| - BOOTTRAN::|bpDConstruct| - BOOTTRAN::|shoeInteger| - BOOTTRAN::|shoeS| - BOOTTRAN::|bpReduceOperator| - BOOTTRAN::|bpAssignment| - BOOTTRAN::|bpAssign| - BOOTTRAN::|bpAssignVariable| - BOOTTRAN::|bpNextToken| - BOOTTRAN::BOOTLOOP - BOOTTRAN::|bpFirstToken| - BOOTTRAN::BOOTPO - BOOTTRAN::|bpStatement| - BOOTTRAN::|bpString| - BOOTTRAN::|bpInfixOperator| - BOOTTRAN::|bpAnyId| - BOOTTRAN::|bpSelector| - BOOTTRAN::|bpAssignLHS| - BOOTTRAN::|bpLoop| - BOOTTRAN::|bpLogical| - BOOTTRAN::|bfGenSymbol| - BOOTTRAN::|bpRegularList| - BOOTTRAN::|bpCaseItem| - BOOTTRAN::|bpPop2| - BOOTTRAN::|bpExpression| - BOOTTRAN::|bpWhere| - BOOTTRAN::|bpPattern| - BOOTTRAN::|bpTerm| - BOOTTRAN::|bpPatternList| - BOOTTRAN::|bpTypeList| - BOOTTRAN::|bpPatternTail| - BOOTTRAN::|bpRegularPatternItemL| - BOOTTRAN::|bpPiledCaseItems| - BOOTTRAN::|bpArith| - BOOTTRAN::|bpStruct| - BOOTTRAN::|bpChecknull| - BOOTTRAN::|bpName| - BOOTTRAN::|bpCase| - BOOTTRAN::|bpRegularBVItemL| - BOOTTRAN::|bpTypeItemList| - BOOTTRAN::|bpRegularBVItem| - BOOTTRAN::|bpCommaBackSet| - BOOTTRAN::|bpIdList| - BOOTTRAN::|bpTagged| - BOOTTRAN::|bpMinus| - BOOTTRAN::|bpBoundVariablelist| - BOOTTRAN::|bpCaseItemList| - BOOTTRAN::|bpPileTrap| - BOOTTRAN::|bpRegularPatternItem| - BOOTTRAN::|shoePunCons| - BOOTTRAN::|bpDot| - BOOTTRAN::|bpTimes| - BOOTTRAN::|bpReduce| - BOOTTRAN::|bpPatternL| - BOOTTRAN::|bpSuchThat| - BOOTTRAN::|bpDConstruction| - BOOTTRAN::|bpColonName| - BOOTTRAN::|shoeKeyTableCons| - BOOTTRAN::|bpBVString| - BOOTTRAN::|bpRecoverTrap| - BOOTTRAN::|bpReturn| - BOOTTRAN::|bpConstruction| - BOOTTRAN::|bpAnd| - BOOTTRAN::|bpPDefinitionItems| - BOOTTRAN::|bpIteratorTail| - BOOTTRAN::|bpVariable| - BOOTTRAN::|bpIterators| - BOOTTRAN::|bpBDefinitionPileItems| - BOOTTRAN::|bpSemiColon| - BOOTTRAN::|bpThetaName| - BOOTTRAN::|bpNext| - BOOTTRAN::|bpPushId| - BOOTTRAN::|bpCancel| - BOOTTRAN::|bpDDef| - BOOTTRAN::|shoeDictCons| - BOOTTRAN::|bpDefTail| - BOOTTRAN::|bpIteratorList| - BOOTTRAN::|bpDefinitionItem| - BOOTTRAN::|bpSexp1| - BOOTTRAN::|bpGeneralErrorHere| - BOOTTRAN::|bpSexp| - BOOTTRAN::|bpOperator| - BOOTTRAN::|shoeToken| - BOOTTRAN::|bpOutItem| - BOOTTRAN::|bpFirstTok| - BOOTTRAN::|bpBacksetElse| - BOOTTRAN::|shoeError| - BOOTTRAN::|bpBPileDefinition| - BOOTTRAN::|bpMdef| - BOOTTRAN::|shoeEscape| - BOOTTRAN::|bpMDefTail| - BOOTTRAN::|bpPDefinition| - BOOTTRAN::|shoeNumber| - BOOTTRAN::|bpStoreName| - BOOTTRAN::|bpConstruct| - BOOTTRAN::|bpEqual| - BOOTTRAN::|shoeString| - BOOTTRAN::|bfDot| - BOOTTRAN::|shoeSpace| - BOOTTRAN::|bpConstTok| - BOOTTRAN::|bpSemiColonDefinition| - BOOTTRAN::|bpApplication| - BOOTTRAN::|bpPop1| - BOOTTRAN::|shoePunct| - BOOTTRAN::|bpTrap| - BOOTTRAN::|bpPrefixOperator| - BOOTTRAN::|bpComma| - BOOTTRAN::|bpCompare| - BOOTTRAN::|shoeLispEscape|))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (*) T) - BOOTTRAN::|bAddLineNumber1| - BOOTTRAN::CONCAT - BOOTTRAN::|bMap1| - BOOTTRAN::|bAppend1| - BOOTTRAN::|bIgen1| - BOOTTRAN::|bRgen1| - COMPILER::CMPNOTE))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T) *) - BOOTTRAN::|shoePCompile| - BOOTTRAN::|shoeCompile| - BOOTTRAN::STTOMC - BOOTTRAN::|shoeInputFile| - BOOTTRAN::|shoeCOMPILE-FILE| - BOOTTRAN::EVAL-BOOT-FILE - BOOTTRAN::BOOT - BOOTTRAN::COMPILE-BOOT-FILE))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T) STRING) - BOOTTRAN::MAKE-CVEC))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T) T) - BOOTTRAN::|bpInfKey| - BOOTTRAN::|shoePlainLine?| - BOOTTRAN::|shoeInclude?| - BOOTTRAN::|shoeReport| - BOOTTRAN::|bfSegment1| - BOOTTRAN::|shoeFileInput| - BOOTTRAN::|bfCompDef| - BOOTTRAN::|shoeDefUse| - BOOTTRAN::BOCLAM - BOOTTRAN::|shoeLeafLisp| - BOOTTRAN::|bfReadLisp| - BOOTTRAN::|shoeLineFileInput| - BOOTTRAN::|shoeLeafLine| - BOOTTRAN::|bpAnyNo| - BOOTTRAN::|dqToList| - BOOTTRAN::|bfSequence| - BOOTTRAN::|shoeLeafNegComment| - BOOTTRAN::DUMMY1 - BOOTTRAN::|bfTupleIf| - BOOTTRAN::|shoeLineToks| - BOOTTRAN::|bpRestore| - BOOTTRAN::|shoeKeyTr| - BOOTTRAN::|bpEqPeek| - BOOTTRAN::|lineCharacter| - BOOTTRAN::|shoeLeafKey| - BOOTTRAN::|shoeIncludeFunction?| - BOOTTRAN::|shoeSpaces| - BOOTTRAN::|shoePossFloat| - BOOTTRAN::|lineString| - BOOTTRAN::|shoeCloser| - BOOTTRAN::|shoePackage?| - BOOTTRAN::|lineNo| - BOOTTRAN::|shoeKeyWord| - BOOTTRAN::|shoeFin?| - BOOTTRAN::|shoeTransform2| - BOOTTRAN::|shoeFunctionFileInput| - BOOTTRAN::|bfDefSequence| - BOOTTRAN::|shoeInclude| - BOOTTRAN::|bfColon| - BOOTTRAN::|shoeItem| - BOOTTRAN::|bIgen| - BOOTTRAN::|shoeW| - BOOTTRAN::|bfBeginsDollar| - BOOTTRAN::|shoeTreeConstruct| - BOOTTRAN::|shoeLeafSpaces| - BOOTTRAN::|shoeLeafError| - BOOTTRAN::|shoePrefixLisp| - BOOTTRAN::|bpBracket| - BOOTTRAN::|shoeInteger1| - BOOTTRAN::|shoeIncludeLisp?| - BOOTTRAN::|bfListOf| - BOOTTRAN::BOOTTOMC - BOOTTRAN::|bPremStreamNil| - BOOTTRAN::BOOTTOCLC - BOOTTRAN::|shoeLeafId| - BOOTTRAN::|shoeConsole| - BOOTTRAN::|shoeLeafComment| - BOOTTRAN::|bPremStreamNull| - BOOTTRAN::|bfSuchthat| - BOOTTRAN::PSTOUT - BOOTTRAN::|bStreamNull| - BOOTTRAN::|bfSep| - BOOTTRAN::|shoeCompileTrees| - BOOTTRAN::|shoeInclude1| - BOOTTRAN::STOUT - BOOTTRAN::SIZE - BOOTTRAN::|shoeIdChar| - BOOTTRAN::|bfINON| - BOOTTRAN::|shoeSimpleLine| - BOOTTRAN::|bpParenTrap| - BOOTTRAN::DEFUSE - BOOTTRAN::DUMMY2 - BOOTTRAN::|shoeIf?| - BOOTTRAN::|defQuoteId| - BOOTTRAN::|shoeEndIf?| - BOOTTRAN::|shoeSay?| - BOOTTRAN::|bpEqKeyNextTok| - BOOTTRAN::|shoePLACEP| - BOOTTRAN::|shoePrefixLine| - BOOTTRAN::BOOTCLAM - BOOTTRAN::|shoeIncludeLines?| - BOOTTRAN::|bfSmintable| - BOOTTRAN::|bfAND| - BOOTTRAN::|bfSuffixDot| - BOOTTRAN::XREF - BOOTTRAN::|bRgen| - BOOTTRAN::|shoeCLOSE| - BOOTTRAN::|bfOR| - BOOTTRAN::|bfNOT| - BOOTTRAN::|shoeFnFileName| - BOOTTRAN::|bpBracketConstruct| - BOOTTRAN::|shoeFileName| - BOOTTRAN::|last| - BOOTTRAN::|shoeBiteOff| - BOOTTRAN::|bfLoop1| - BOOTTRAN::|bfDs| - BOOTTRAN::|shoeLine?| - BOOTTRAN::|shoeElseIf?| - BOOTTRAN::|bfCreateDef| - BOOTTRAN::IDENTP - BOOTTRAN::|shoeLisp?| - BOOTTRAN::|shoeElse?| - BOOTTRAN::|bpCompMissing| - BOOTTRAN::|char| - BOOTTRAN::|bfTuple| - PNAME - BOOTTRAN::|bpOneOrMore| - BOOTTRAN::|shoeLastTokPosn| - BOOTTRAN::|shoeTokPosn| - BOOTTRAN::|bfTupleP| - BOOTTRAN::|bpConditional| - BOOTTRAN::|bpEqKey| - BOOTTRAN::|bfMakeCons| - BOOTTRAN::BOOTTOCL - BOOTTRAN::|shoePileColumn| - BOOTTRAN::|shoeFluids| - BOOTTRAN::|bpPileBracketed| - BOOTTRAN::|shoeRemovebootIfNec| - BOOTTRAN::|shoeAddbootIfNec| - BOOTTRAN::|shoeATOMs| - BOOTTRAN::|shoeConsoleItem| - DOUBLE - BOOTTRAN::|shoePileInsert| - BOOTTRAN::|shoeCompTran1| - BOOTTRAN::|shoeParseTrees| - BOOTTRAN::|shoeTokType| - BOOTTRAN::|shoeDQlines| - BOOTTRAN::|shoeConsoleLines| - BOOTTRAN::|shoeSeparatePiles| - BOOTTRAN::|compFluid| - BOOTTRAN::|bpMissing| - BOOTTRAN::|shoeOutParse| - BOOTTRAN::|dqConcat| - BOOTTRAN::|bfReName| - BOOTTRAN::|bfNameOnly| - BOOTTRAN::|bfDef1| - BOOTTRAN::|bpBrackTrap| - BOOTTRAN::|shoeAddComment| - BOOTTRAN::|dqUnit| - BOOTTRAN::|shoeComps| - BOOTTRAN::|bfBracket| - BOOTTRAN::|bpParenthesized| - BOOTTRAN::|shoeTransformStream| - BOOTTRAN::|shoeEnPile| - BOOTTRAN::|shoeComp| - BOOTTRAN::|shoeFirstTokPosn| - BOOTTRAN::|bfGargl| - BOOTTRAN::|bpListAndRecover| - BOOTTRAN::|shoeNotFound| - BOOTTRAN::|bpTuple| - BOOTTRAN::|bfAppend| - BOOTTRAN::|shoeTokPart| - BOOTTRAN::|bfMKPROGN| - BOOTTRAN::|compFluidize| - BOOTTRAN::|bfWhile| - BOOTTRAN::PSTTOMC - BOOTTRAN::|shoePileCforest| - BOOTTRAN::|bfFlattenSeq| - BOOTTRAN::|shoePCompileTrees| - BOOTTRAN::|shoeTransformString| - BOOTTRAN::|bfCross| - BOOTTRAN::|bfPile| - BOOTTRAN::|shoeXReport| - BOOTTRAN::|shoeStartsId| - BOOTTRAN::|bpMoveTo| - BOOTTRAN::|defSheepAndGoatsList| - BOOTTRAN::SSORT - BOOTTRAN::MAKE-BVEC - BOOTTRAN::|defSheepAndGoats| - BOOTTRAN::HKEYS - BOOTTRAN::|bfDTuple| - BOOTTRAN::|shoeConsoleTrees| - BOOTTRAN::|shoeTransformToConsole| - BOOTTRAN::|bfUntil| - BOOTTRAN::BO - BOOTTRAN::MAKE-HASHTABLE - BOOTTRAN::|shoeLeafString| - BOOTTRAN::|bfReturnNoName| - BOOTTRAN::|bfTupleConstruct| - BOOTTRAN::|defSeparate| - BOOTTRAN::|shoeNextLine| - BOOTTRAN::|unfluidlist| - BOOTTRAN::|shoeLeafLispExp| - BOOTTRAN::|defusebuiltin| - BOOTTRAN::|shoeKeyWordP| - BOOTTRAN::|shoeIntValue| - BOOTTRAN::|shoeOrdToNum| - BOOTTRAN::|bfConstruct| - BOOTTRAN::|bStreamPackageNull| - BOOTTRAN::|shoeLeafInteger| - BOOTTRAN::|shoeTransform| - BOOTTRAN::|bpAddTokens| - BOOTTRAN::STEVAL - BOOTTRAN::|bpSpecificErrorHere| - BOOTTRAN::|bfIterators| - BOOTTRAN::MAKE-VEC - BOOTTRAN::|bpIndentParenthesized| - BOOTTRAN::|bpInfGeneric| - BOOTTRAN::|shoeDigit| - BOOTTRAN::|bpPush| - BOOTTRAN::|bfEqual| - BOOTTRAN::|shoeCompTran| - BOOTTRAN::|bfSymbol| - BOOTTRAN::|shoeEVALANDFILEACTQ| - BOOTTRAN::|shoeWord| - BOOTTRAN::|shoeLispFileInput| - BOOTTRAN::|bpElse| - BOOTTRAN::|shoePunctuation| - BOOTTRAN::|shoeLineSyntaxError| - BOOTTRAN::|shoeEval?|))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T *) STRING) - BOOTTRAN::MAKE-FULL-CVEC))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T *) T) - BOOTTRAN::SHOEPRETTYPRIN1 - BOOTTRAN::REALLYPRETTYPRINT - BOOTTRAN::SHOEPRETTYPRIN0 - BOOTTRAN::SHOENOTPRETTYPRINT))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T T) *) - BOOTTRAN::FBO - BOOTTRAN::FEV))) - -(PROCLAIM (QUOTE (FTYPE (FUNCTION (T T) T) - BOOTTRAN::|bootOut| - BOOTTRAN::|bfSegment2| - BOOTTRAN::|bfWhere| - BOOTTRAN::|bFileNext| - BOOTTRAN::|shoeLispToken| - BOOTTRAN::|bfApplication| - BOOTTRAN::|bpRightAssoc| - BOOTTRAN::|bNext| - BOOTTRAN::|bpIgnoredFromTo| - BOOTTRAN::|bfForin| - BOOTTRAN::|shoePrefix?| - BOOTTRAN::|shoeMatch| - BOOTTRAN::BOOTTOCLLINES - BOOTTRAN::|bAddLineNumber| - BOOTTRAN::|shoeIdEnd| - BOOTTRAN::|bFileNext1| - BOOTTRAN::|bfLET1| - BOOTTRAN::|shoeFileLines| - BOOTTRAN::|SoftShoeError| - BOOTTRAN::|bfLetForm| - BOOTTRAN::|bNext1| - BOOTTRAN::|bfLET2| - BOOTTRAN::|shoeMc| - BOOTTRAN::|shoeExponent| - BOOTTRAN::|bfCONTAINED| - BOOTTRAN::|bDelay| - BOOTTRAN::|bfReduce| - BOOTTRAN::|bfDrop| - BOOTTRAN::BOOTTOCLCLINES - BOOTTRAN::|bfReduceCollect| - BOOTTRAN::|bfIS| - BOOTTRAN::|shoeReadLispString| - BOOTTRAN::|bfIS1| - BOOTTRAN::|bfAssign| - BOOTTRAN::|bfInsertLet| - BOOTTRAN::|bAppend| - BOOTTRAN::|bfInsertLet1| - BOOTTRAN::|bfIN| - BOOTTRAN::|shoeDfu| - BOOTTRAN::|bfON| - BOOTTRAN::|bfTake| - BOOTTRAN::|bfLessp| - BOOTTRAN::BOOTCLAMLINES - BOOTTRAN::|bfQ| - BOOTTRAN::BVEC-MAKE-FULL - BOOTTRAN::|shoeXref| - BOOTTRAN::CHARMEM - BOOTTRAN::|shoeFileMap| - BOOTTRAN::|bfElt| - BOOTTRAN::|bMap| - BOOTTRAN::|bfCaseItem| - BOOTTRAN::SHOEGREATERP - BOOTTRAN::|bfMain| - BOOTTRAN::|bf0COLLECT| - BOOTTRAN::|bfCARCDR| - BOOTTRAN::SETDIFFERENCE - BOOTTRAN::|bf0APPEND| - BOOTTRAN::|bfLp| - BOOTTRAN::|bfISReverse| - BOOTTRAN::|bfStruct| - BOOTTRAN::|addCARorCDR| - BOOTTRAN::|bfPosition| - BOOTTRAN::|shoeReadLisp| - BOOTTRAN::|shoePileTree| - BOOTTRAN::|bfFlatten| - BOOTTRAN::|eqshoePileTree| - BOOTTRAN::|shoePROG| - BOOTTRAN::|shoePileForest1| - BOOTTRAN::|bfCase| - BOOTTRAN::|shoePileForest| - BOOTTRAN::|bfLocal| - BOOTTRAN::|bpMissingMate| - BOOTTRAN::|streamTake| - BOOTTRAN::|bfNameArgs| - BOOTTRAN::|shoeFileTrees| - BOOTTRAN::|shoeFileLine| - BOOTTRAN::|shoePileCoagulate| - BOOTTRAN::|bfLpCross| - BOOTTRAN::EQCAR - BOOTTRAN::|bfLp1| - BOOTTRAN::CLESSP - BOOTTRAN::|dqAppend| - BOOTTRAN::|bfTagged| - BOOTTRAN::|bfCaseItems| - BOOTTRAN::|shoeRemoveStringIfNec| - BOOTTRAN::|shoeAddStringIfNec| - BOOTTRAN::|shoePileCtree| - BOOTTRAN::|bfLET| - BOOTTRAN::|bfColonAppend| - BOOTTRAN::|bfSUBLIS1| - BOOTTRAN::|bfSUBLIS| - BOOTTRAN::|shoeTransformToFile| - BOOTTRAN::|bpLeftAssoc| - BOOTTRAN::|shoeToConsole| - BOOTTRAN::|bfDCollect| - BOOTTRAN::|shoeAccumulateLines| - BOOTTRAN::|bfCollect| - BOOTTRAN::|defuse1| - BOOTTRAN::|bfDefinition1| - BOOTTRAN::|bpSemiListing| - BOOTTRAN::|shoeInsert| - BOOTTRAN::|bpSpecificErrorAtToken| - BOOTTRAN::|defuse| - BOOTTRAN::FC - BOOTTRAN::|bfExit| - BOOTTRAN::|shoePPtoFile| - BOOTTRAN::|bfIfThenOnly|))) - diff --git a/src/boot/boothdr.lisp.pamphlet b/src/boot/boothdr.lisp.pamphlet deleted file mode 100644 index bac13c4..0000000 --- a/src/boot/boothdr.lisp.pamphlet +++ /dev/null @@ -1,67 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot boothdr.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - - -#+:CCL -(make-package 'BOOTTRAN) - -(PROVIDE 'BOOTTRAN) -(in-package 'BOOTTRAN :USE '(LISP USER SYSTEM)) - -;## need the conditional here so it appears in boottran -#+:ieee-floating-point (setq $ieee t) -#-:ieee-floating-point (setq $ieee nil) - -;## For Rios C compiler -(defun dummy1 (x) x) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/bootload.lisp.pamphlet b/src/boot/bootload.lisp.pamphlet deleted file mode 100644 index 0b7eaa5..0000000 --- a/src/boot/bootload.lisp.pamphlet +++ /dev/null @@ -1,67 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot bootload.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -(unuse-package '(boot lisp vmlisp) 'boottran) - -(load "/spad/obj/rios/boot/boothdr.o") -(load "/spad/obj/rios/boot/exports.o") -(load "/spad/obj/rios/boot/npextras.o") -(load "/spad/obj/rios/boot/ptyout.o") -(load "/spad/obj/rios/boot/btincl2.o") -(load "/spad/obj/rios/boot/btscan2.o") -(load "/spad/obj/rios/boot/typrops.o") -(load "/spad/obj/rios/boot/btpile2.o") -(load "/spad/obj/rios/boot/typars.o") -(load "/spad/obj/rios/boot/tyextra.o") -(load "/spad/obj/rios/boot/tytree1.o") -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/btincl2.boot.pamphlet b/src/boot/btincl2.boot.pamphlet deleted file mode 100644 index e659865..0000000 --- a/src/boot/btincl2.boot.pamphlet +++ /dev/null @@ -1,560 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot btincl2.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package 'BOOTTRAN --- BOOT INCLUDER - --- Line syntax is --- --- Include ::= (SimpleLine | If )* | ( )fin | empty) --- --- SimpleLine::= --- PlainLine | includes the line --- )say line | outputs line to console --- )eval line | evaluates the boot line --- nothing included --- )line line | line is reproduced as is in lisp output --- )lisp line | line is read by lisp READ --- )package line | produces (IN-PACKAGE line) in lisp --- output --- )include filename | includes the file as boot code --- )includelisp filename | includes the file as lisp code --- read by lisp READ --- )includelines filename | includes the file as is --- in lisp output --- --- If ::= )if SimpleLine* ElseLines )endif --- --- ElseLines ::= )else SimpleLine* | )elseif SimpleLine* ElseLines | empty -bStreamNil:=["nullstream"] - -shoeFileMap(f, fn)== - a:=shoeInputFile fn - null a => - shoeConsole CONCAT(fn,'" NOT FOUND") - bStreamNil - shoeConsole CONCAT('"READING ",fn) - shoeInclude bAddLineNumber(bMap(f,bRgen a),bIgen 0) - -shoeFileInput fn==shoeFileMap(function IDENTITY,fn) - -shoePrefixLisp x== CONCAT('")lisp",x) -shoeLispFileInput fn== shoeFileMap(function shoePrefixLisp,fn) - -shoePrefixLine x== CONCAT('")line",x) -shoeLineFileInput fn== shoeFileMap(function shoePrefixLine,fn) - -shoePrefix?(prefix,whole) == - #prefix > #whole => false - good:=true - for i in 0..#prefix-1 for j in 0.. while good repeat - good:= prefix.i = whole.j - if good then SUBSTRING(whole,#prefix,nil) else good - -shoePlainLine?(s) == - #s = 0 => true - s.0 ^= char ")" - -shoeSay? s == shoePrefix?('")say", s) -shoeEval? s == shoePrefix?('")eval", s) -shoeInclude? s == shoePrefix?('")include", s) -shoeFin? s == shoePrefix?('")fin", s) -shoeIf? s == shoePrefix?('")if", s) -shoeEndIf? s == shoePrefix?('")endif", s) -shoeElse? s == shoePrefix?('")else", s) -shoeElseIf? s == shoePrefix?('")elseif", s) -shoePackage? s == shoePrefix?('")package", s) -shoeLisp? s == shoePrefix?('")lisp", s) -shoeIncludeLisp? s == shoePrefix?('")includelisp" ,s) -shoeLine? s == shoePrefix?('")line", s) -shoeIncludeLines? s == shoePrefix?('")includelines",s) -shoeIncludeFunction? s == shoePrefix?('")includefunction",s) - -shoeBiteOff x== - n:=STRPOSL('" ",x,0,true) - null n => false - n1:=STRPOSL ('" ",x,n,nil) - null n1 => [SUBSTRING(x,n,nil),'""] - [SUBSTRING(x,n,n1-n),SUBSTRING(x,n1,nil)] - -shoeFileName x== - a:=shoeBiteOff x - null a => '"" - c:=shoeBiteOff CADR a - null c => CAR a - CONCAT(CAR a,'".",CAR c) - -shoeFnFileName x== - a:=shoeBiteOff x - null a => ['"",'""] - c:=shoeFileName CADR a - null c => [CAR a,'""] - [CAR a, c] - -shoeFunctionFileInput [fun,fn]== - shoeOpenInputFile (a,fn, - shoeInclude bAddLineNumber( shoeFindLines(fn,fun,a),bIgen 0)) - -shoeInclude s== bDelay(function shoeInclude1,[s]) -shoeInclude1 s== - bStreamNull s=> s - [h,:t] :=s - string :=CAR h - command :=shoeFin? string => bStreamNil - command :=shoeIf? string => shoeThen([true],[STTOMC command],t) - bAppend(shoeSimpleLine h,shoeInclude t) - -shoeSimpleLine(h) == - string :=CAR h - shoePlainLine? string=> [h] - command:=shoeLisp? string => [h] - command:=shoeIncludeLisp? string => - shoeLispFileInput shoeFileName command - command:=shoeIncludeFunction? string => - shoeFunctionFileInput shoeFnFileName command - command:=shoeLine? string => [h] - command:=shoeIncludeLines? string => - shoeLineFileInput shoeFileName command - command:=shoeInclude? string => shoeFileInput shoeFileName command - command:=shoePackage? string => [h] - command:=shoeSay? string => - shoeConsole command - nil - command:=shoeEval? string => - STTOMC command - nil - shoeLineSyntaxError(h) - nil - -shoeThen(keep,b,s)== bDelay(function shoeThen1,[keep,b,s]) -shoeThen1(keep,b,s)== - bPremStreamNull s=> s - [h,:t] :=s - string :=CAR h - command :=shoeFin? string => bPremStreamNil(h) - keep1:= car keep - b1 := car b - command :=shoeIf? string => - keep1 and b1=> shoeThen(cons(true,keep),cons(STTOMC command,b),t) - shoeThen(cons(false,keep),cons(false,b),t) - command :=shoeElseIf? string=> - keep1 and not b1=> - shoeThen(cons(true,rest keep),cons(STTOMC command,rest b),t) - shoeThen(cons(false,rest keep),cons(false,rest b),t) - command :=shoeElse? string => - keep1 and not b1=>shoeElse(cons(true,rest keep),cons(true,rest b),t) - shoeElse(cons(false,rest keep),cons(false,rest b),t) - command :=shoeEndIf? string=> - null cdr b=> shoeInclude t - shoeThen(rest keep,rest b,t) - keep1 and b1 => bAppend(shoeSimpleLine h,shoeThen(keep,b,t)) - shoeThen(keep,b,t) - -shoeElse(keep,b,s)== bDelay(function shoeElse1,[keep,b,s]) -shoeElse1(keep,b,s)== - bPremStreamNull s=> s - [h,:t] :=s - string :=CAR h - command :=shoeFin? string => bPremStreamNil(h) - b1:=car b - keep1:=car keep - command :=shoeIf? string=> - keep1 and b1=> shoeThen(cons(true,keep),cons(STTOMC command,b),t) - shoeThen(cons(false,keep),cons(false,b),t) - command :=shoeEndIf? string => - null cdr b=> shoeInclude t - shoeThen(rest keep,rest b,t) - keep1 and b1 => bAppend(shoeSimpleLine h,shoeElse(keep,b,t)) - shoeElse(keep,b,t) - -shoeLineSyntaxError(h)== - shoeConsole CONCAT('"INCLUSION SYNTAX ERROR IN LINE ", - STRINGIMAGE CDR h) - shoeConsole car h - shoeConsole '"LINE IGNORED" - -bPremStreamNil(h)== - shoeConsole CONCAT('"UNEXPECTED )fin IN LINE ",STRINGIMAGE CDR h) - shoeConsole car h - shoeConsole '"REST OF FILE IGNORED" - bStreamNil - -bPremStreamNull(s)== - if bStreamNull s - then - shoeConsole '"FILE TERMINATED BEFORE )endif" - true - else false -@ -<>= - -(IN-PACKAGE 'BOOTTRAN) - -(EVAL-WHEN (EVAL LOAD) (SETQ |bStreamNil| (LIST '|nullstream|))) - -(DEFUN |shoeFileMap| (|f| |fn|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|shoeInputFile| |fn|)) - (COND - ((NULL |a|) - (PROGN - (|shoeConsole| (CONCAT |fn| " NOT FOUND")) - |bStreamNil|)) - ('T - (PROGN - (|shoeConsole| (CONCAT "READING " |fn|)) - (|shoeInclude| - (|bAddLineNumber| (|bMap| |f| (|bRgen| |a|)) - (|bIgen| 0)))))))))) - -(DEFUN |shoeFileInput| (|fn|) - (PROG () (RETURN (|shoeFileMap| #'IDENTITY |fn|)))) - -(DEFUN |shoePrefixLisp| (|x|) (PROG () (RETURN (CONCAT ")lisp" |x|)))) - -(DEFUN |shoeLispFileInput| (|fn|) - (PROG () (RETURN (|shoeFileMap| #'|shoePrefixLisp| |fn|)))) - -(DEFUN |shoePrefixLine| (|x|) (PROG () (RETURN (CONCAT ")line" |x|)))) - -(DEFUN |shoeLineFileInput| (|fn|) - (PROG () (RETURN (|shoeFileMap| #'|shoePrefixLine| |fn|)))) - -(DEFUN |shoePrefix?| (|prefix| |whole|) - (PROG (|good|) - (RETURN - (COND - ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL) - ('T - (PROGN - (SETQ |good| T) - ((LAMBDA (|bfVar#1| |i| |j|) - (LOOP - (COND - ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL)) - ('T - (SETQ |good| - (EQUAL (ELT |prefix| |i|) (ELT |whole| |j|))))) - (SETQ |i| (+ |i| 1)) - (SETQ |j| (+ |j| 1)))) - (- (LENGTH |prefix|) 1) 0 0) - (COND - (|good| (SUBSTRING |whole| (LENGTH |prefix|) NIL)) - ('T |good|)))))))) - -(DEFUN |shoePlainLine?| (|s|) - (PROG () - (RETURN - (COND - ((EQL (LENGTH |s|) 0) T) - ('T (NOT (EQUAL (ELT |s| 0) (|char| '|)|))))))) -) -(DEFUN |shoeSay?| (|s|) (PROG () (RETURN (|shoePrefix?| ")say" |s|)))) - -(DEFUN |shoeEval?| (|s|) - (PROG () (RETURN (|shoePrefix?| ")eval" |s|)))) - -(DEFUN |shoeInclude?| (|s|) - (PROG () (RETURN (|shoePrefix?| ")include" |s|)))) - -(DEFUN |shoeFin?| (|s|) (PROG () (RETURN (|shoePrefix?| ")fin" |s|)))) - -(DEFUN |shoeIf?| (|s|) (PROG () (RETURN (|shoePrefix?| ")if" |s|)))) - -(DEFUN |shoeEndIf?| (|s|) - (PROG () (RETURN (|shoePrefix?| ")endif" |s|)))) - -(DEFUN |shoeElse?| (|s|) - (PROG () (RETURN (|shoePrefix?| ")else" |s|)))) - -(DEFUN |shoeElseIf?| (|s|) - (PROG () (RETURN (|shoePrefix?| ")elseif" |s|)))) - -(DEFUN |shoePackage?| (|s|) - (PROG () (RETURN (|shoePrefix?| ")package" |s|)))) - -(DEFUN |shoeLisp?| (|s|) - (PROG () (RETURN (|shoePrefix?| ")lisp" |s|)))) - -(DEFUN |shoeIncludeLisp?| (|s|) - (PROG () (RETURN (|shoePrefix?| ")includelisp" |s|)))) - -(DEFUN |shoeLine?| (|s|) - (PROG () (RETURN (|shoePrefix?| ")line" |s|)))) - -(DEFUN |shoeIncludeLines?| (|s|) - (PROG () (RETURN (|shoePrefix?| ")includelines" |s|)))) - -(DEFUN |shoeIncludeFunction?| (|s|) - (PROG () (RETURN (|shoePrefix?| ")includefunction" |s|)))) - -(DEFUN |shoeBiteOff| (|x|) - (PROG (|n1| |n|) - (RETURN - (PROGN - (SETQ |n| (STRPOSL " " |x| 0 T)) - (COND - ((NULL |n|) NIL) - ('T - (PROGN - (SETQ |n1| (STRPOSL " " |x| |n| NIL)) - (COND - ((NULL |n1|) (LIST (SUBSTRING |x| |n| NIL) "")) - ('T - (LIST (SUBSTRING |x| |n| (- |n1| |n|)) - (SUBSTRING |x| |n1| NIL))))))))))) - -(DEFUN |shoeFileName| (|x|) - (PROG (|c| |a|) - (RETURN - (PROGN - (SETQ |a| (|shoeBiteOff| |x|)) - (COND - ((NULL |a|) "") - ('T - (PROGN - (SETQ |c| (|shoeBiteOff| (CADR |a|))) - (COND - ((NULL |c|) (CAR |a|)) - ('T (CONCAT (CAR |a|) "." (CAR |c|))))))))))) - -(DEFUN |shoeFnFileName| (|x|) - (PROG (|c| |a|) - (RETURN - (PROGN - (SETQ |a| (|shoeBiteOff| |x|)) - (COND - ((NULL |a|) (LIST "" "")) - ('T - (PROGN - (SETQ |c| (|shoeFileName| (CADR |a|))) - (COND - ((NULL |c|) (LIST (CAR |a|) "")) - ('T (LIST (CAR |a|) |c|)))))))))) - -(DEFUN |shoeFunctionFileInput| (|bfVar#2|) - (PROG (|fn| |fun|) - (RETURN - (PROGN - (SETQ |fun| (CAR |bfVar#2|)) - (SETQ |fn| (CADR |bfVar#2|)) - (|shoeOpenInputFile| |a| |fn| - (|shoeInclude| - (|bAddLineNumber| (|shoeFindLines| |fn| |fun| |a|) - (|bIgen| 0)))))))) - -(DEFUN |shoeInclude| (|s|) - (PROG () (RETURN (|bDelay| #'|shoeInclude1| (LIST |s|))))) - -(DEFUN |shoeInclude1| (|s|) - (PROG (|command| |string| |t| |h|) - (RETURN - (COND - ((|bStreamNull| |s|) |s|) - ('T - (PROGN - (SETQ |h| (CAR |s|)) - (SETQ |t| (CDR |s|)) - (SETQ |string| (CAR |h|)) - (COND - ((SETQ |command| (|shoeFin?| |string|)) |bStreamNil|) - ((SETQ |command| (|shoeIf?| |string|)) - (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|)) - ('T - (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|)))))))))) - -(DEFUN |shoeSimpleLine| (|h|) - (PROG (|command| |string|) - (RETURN - (PROGN - (SETQ |string| (CAR |h|)) - (COND - ((|shoePlainLine?| |string|) (LIST |h|)) - ((SETQ |command| (|shoeLisp?| |string|)) (LIST |h|)) - ((SETQ |command| (|shoeIncludeLisp?| |string|)) - (|shoeLispFileInput| (|shoeFileName| |command|))) - ((SETQ |command| (|shoeIncludeFunction?| |string|)) - (|shoeFunctionFileInput| (|shoeFnFileName| |command|))) - ((SETQ |command| (|shoeLine?| |string|)) (LIST |h|)) - ((SETQ |command| (|shoeIncludeLines?| |string|)) - (|shoeLineFileInput| (|shoeFileName| |command|))) - ((SETQ |command| (|shoeInclude?| |string|)) - (|shoeFileInput| (|shoeFileName| |command|))) - ((SETQ |command| (|shoePackage?| |string|)) (LIST |h|)) - ((SETQ |command| (|shoeSay?| |string|)) - (PROGN (|shoeConsole| |command|) NIL)) - ((SETQ |command| (|shoeEval?| |string|)) - (PROGN (STTOMC |command|) NIL)) - ('T (PROGN (|shoeLineSyntaxError| |h|) NIL))))))) - -(DEFUN |shoeThen| (|keep| |b| |s|) - (PROG () (RETURN (|bDelay| #'|shoeThen1| (LIST |keep| |b| |s|))))) - -(DEFUN |shoeThen1| (|keep| |b| |s|) - (PROG (|b1| |keep1| |command| |string| |t| |h|) - (RETURN - (COND - ((|bPremStreamNull| |s|) |s|) - ('T - (PROGN - (SETQ |h| (CAR |s|)) - (SETQ |t| (CDR |s|)) - (SETQ |string| (CAR |h|)) - (COND - ((SETQ |command| (|shoeFin?| |string|)) - (|bPremStreamNil| |h|)) - ('T - (PROGN - (SETQ |keep1| (CAR |keep|)) - (SETQ |b1| (CAR |b|)) - (COND - ((SETQ |command| (|shoeIf?| |string|)) - (COND - ((AND |keep1| |b1|) - (|shoeThen| (CONS T |keep|) - (CONS (STTOMC |command|) |b|) |t|)) - ('T - (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|)))) - ((SETQ |command| (|shoeElseIf?| |string|)) - (COND - ((AND |keep1| (NULL |b1|)) - (|shoeThen| (CONS T (CDR |keep|)) - (CONS (STTOMC |command|) (CDR |b|)) |t|)) - ('T - (|shoeThen| (CONS NIL (CDR |keep|)) - (CONS NIL (CDR |b|)) |t|)))) - ((SETQ |command| (|shoeElse?| |string|)) - (COND - ((AND |keep1| (NULL |b1|)) - (|shoeElse| (CONS T (CDR |keep|)) - (CONS T (CDR |b|)) |t|)) - ('T - (|shoeElse| (CONS NIL (CDR |keep|)) - (CONS NIL (CDR |b|)) |t|)))) - ((SETQ |command| (|shoeEndIf?| |string|)) - (COND - ((NULL (CDR |b|)) (|shoeInclude| |t|)) - ('T (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) - ((AND |keep1| |b1|) - (|bAppend| (|shoeSimpleLine| |h|) - (|shoeThen| |keep| |b| |t|))) - ('T (|shoeThen| |keep| |b| |t|)))))))))))) - -(DEFUN |shoeElse| (|keep| |b| |s|) - (PROG () (RETURN (|bDelay| #'|shoeElse1| (LIST |keep| |b| |s|))))) - -(DEFUN |shoeElse1| (|keep| |b| |s|) - (PROG (|keep1| |b1| |command| |string| |t| |h|) - (RETURN - (COND - ((|bPremStreamNull| |s|) |s|) - ('T - (PROGN - (SETQ |h| (CAR |s|)) - (SETQ |t| (CDR |s|)) - (SETQ |string| (CAR |h|)) - (COND - ((SETQ |command| (|shoeFin?| |string|)) - (|bPremStreamNil| |h|)) - ('T - (PROGN - (SETQ |b1| (CAR |b|)) - (SETQ |keep1| (CAR |keep|)) - (COND - ((SETQ |command| (|shoeIf?| |string|)) - (COND - ((AND |keep1| |b1|) - (|shoeThen| (CONS T |keep|) - (CONS (STTOMC |command|) |b|) |t|)) - ('T - (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|)))) - ((SETQ |command| (|shoeEndIf?| |string|)) - (COND - ((NULL (CDR |b|)) (|shoeInclude| |t|)) - ('T (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) - ((AND |keep1| |b1|) - (|bAppend| (|shoeSimpleLine| |h|) - (|shoeElse| |keep| |b| |t|))) - ('T (|shoeElse| |keep| |b| |t|)))))))))))) - -(DEFUN |shoeLineSyntaxError| (|h|) - (PROG () - (RETURN - (PROGN - (|shoeConsole| - (CONCAT "INCLUSION SYNTAX ERROR IN LINE " - (STRINGIMAGE (CDR |h|)))) - (|shoeConsole| (CAR |h|)) - (|shoeConsole| "LINE IGNORED"))))) - -(DEFUN |bPremStreamNil| (|h|) - (PROG () - (RETURN - (PROGN - (|shoeConsole| - (CONCAT "UNEXPECTED )fin IN LINE " (STRINGIMAGE (CDR |h|)))) - (|shoeConsole| (CAR |h|)) - (|shoeConsole| "REST OF FILE IGNORED") - |bStreamNil|)))) - -(DEFUN |bPremStreamNull| (|s|) - (PROG () - (RETURN - (COND - ((|bStreamNull| |s|) - (|shoeConsole| "FILE TERMINATED BEFORE )endif") T) - ('T NIL))))) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/btpile2.boot.pamphlet b/src/boot/btpile2.boot.pamphlet deleted file mode 100644 index 9ec44b8..0000000 --- a/src/boot/btpile2.boot.pamphlet +++ /dev/null @@ -1,315 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot btpile2.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - - -)package 'BOOTTRAN -shoeFirstTokPosn t== shoeTokPosn CAAR t -shoeLastTokPosn t== shoeTokPosn CADR t -shoePileColumn t==CDR shoeTokPosn CAAR t - --- s is a token-dq-stream - -shoePileInsert (s)== - if bStreamNull s - then cons([],s) - else - toktype:=shoeTokType CAAAR s - if toktype ="LISP" or toktype = "LINE" - then cons([car s],cdr s) - else - a:=shoePileTree(-1,s) - cons([a.2],a.3) - -shoePileTree(n,s)== - if bStreamNull s - then [false,n,[],s] - else - [h,t]:=[car s,cdr s] - hh:=shoePileColumn h - if hh > n - then shoePileForests(h,hh,t) - else [false,n,[],s] - -eqshoePileTree(n,s)== - if bStreamNull s - then [false,n,[],s] - else - [h,t]:=[car s,cdr s] - hh:=shoePileColumn h - if hh = n - then shoePileForests(h,hh,t) - else [false,n,[],s] - -shoePileForest(n,s)== - [b,hh,h,t]:= shoePileTree(n,s) - if b - then - [h1,t1]:=shoePileForest1(hh,t) - [cons(h,h1),t1] - else [[],s] - -shoePileForest1(n,s)== - [b,n1,h,t]:= eqshoePileTree(n,s) - if b - then - [h1,t1]:=shoePileForest1(n,t) - [cons(h,h1),t1] - else [[],s] - -shoePileForests(h,n,s)== - [h1,t1]:=shoePileForest(n,s) - if bStreamNull h1 - then [true,n,h,s] - else shoePileForests(shoePileCtree(h,h1),n,t1) - -shoePileCtree(x,y)==dqAppend(x,shoePileCforest y) - --- only enshoePiles forests with >=2 trees - -shoePileCforest x== - if null x - then [] - else if null cdr x - then car x - else - a:=car x - b:=shoePileCoagulate(a,rest x) - if null cdr b - then car b - else shoeEnPile shoeSeparatePiles b - -shoePileCoagulate(a,b)== - if null b - then [a] - else - c:=car b - if EQ(shoeTokPart CAAR c,"THEN") or EQ(shoeTokPart CAAR c,"ELSE") - then shoePileCoagulate (dqAppend(a,c),cdr b) - else - d:=CADR a - e:=shoeTokPart d - if EQCAR(d,"KEY") and - (GET(e,"SHOEINF") or EQ(e,"COMMA") or EQ(e,"SEMICOLON")) - then shoePileCoagulate(dqAppend(a,c),cdr b) - else cons(a,shoePileCoagulate(c,rest b)) - -shoeSeparatePiles x== - if null x - then [] - else if null cdr x - then car x - else - a:=car x - semicolon:=dqUnit - shoeTokConstruct("KEY", "BACKSET",shoeLastTokPosn a) - dqConcat [a,semicolon,shoeSeparatePiles cdr x] - -shoeEnPile x== - dqConcat [dqUnit shoeTokConstruct("KEY","SETTAB",shoeFirstTokPosn x), - x, _ - dqUnit shoeTokConstruct("KEY","BACKTAB",shoeLastTokPosn x)] - -@ -<>= - - -(IN-PACKAGE 'BOOTTRAN) - -(DEFUN |shoeFirstTokPosn| (|t|) - (PROG () (RETURN (|shoeTokPosn| (CAAR |t|))))) - -(DEFUN |shoeLastTokPosn| (|t|) - (PROG () (RETURN (|shoeTokPosn| (CADR |t|))))) - -(DEFUN |shoePileColumn| (|t|) - (PROG () (RETURN (CDR (|shoeTokPosn| (CAAR |t|)))))) - -(DEFUN |shoePileInsert| (|s|) - (PROG (|a| |toktype|) - (RETURN - (COND - ((|bStreamNull| |s|) (CONS NIL |s|)) - ('T (SETQ |toktype| (|shoeTokType| (CAAAR |s|))) - (COND - ((OR (EQ |toktype| 'LISP) (EQ |toktype| 'LINE)) - (CONS (LIST (CAR |s|)) (CDR |s|))) - ('T (SETQ |a| (|shoePileTree| (- 1) |s|)) - (CONS (LIST (ELT |a| 2)) (ELT |a| 3))))))))) - -(DEFUN |shoePileTree| (|n| |s|) - (PROG (|hh| |t| |h| |LETTMP#1|) - (RETURN - (COND - ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|)) - ('T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|))) - (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|)) - (SETQ |hh| (|shoePileColumn| |h|)) - (COND - ((< |n| |hh|) (|shoePileForests| |h| |hh| |t|)) - ('T (LIST NIL |n| NIL |s|)))))))) - -(DEFUN |eqshoePileTree| (|n| |s|) - (PROG (|hh| |t| |h| |LETTMP#1|) - (RETURN - (COND - ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|)) - ('T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|))) - (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|)) - (SETQ |hh| (|shoePileColumn| |h|)) - (COND - ((EQUAL |hh| |n|) (|shoePileForests| |h| |hh| |t|)) - ('T (LIST NIL |n| NIL |s|)))))))) - -(DEFUN |shoePileForest| (|n| |s|) - (PROG (|t1| |h1| |t| |h| |hh| |b| |LETTMP#1|) - (RETURN - (PROGN - (SETQ |LETTMP#1| (|shoePileTree| |n| |s|)) - (SETQ |b| (CAR |LETTMP#1|)) - (SETQ |hh| (CADR |LETTMP#1|)) - (SETQ |h| (CADDR |LETTMP#1|)) - (SETQ |t| (CADDDR |LETTMP#1|)) - (COND - (|b| (SETQ |LETTMP#1| (|shoePileForest1| |hh| |t|)) - (SETQ |h1| (CAR |LETTMP#1|)) - (SETQ |t1| (CADR |LETTMP#1|)) - (LIST (CONS |h| |h1|) |t1|)) - ('T (LIST NIL |s|))))))) - -(DEFUN |shoePileForest1| (|n| |s|) - (PROG (|t1| |h1| |t| |h| |n1| |b| |LETTMP#1|) - (RETURN - (PROGN - (SETQ |LETTMP#1| (|eqshoePileTree| |n| |s|)) - (SETQ |b| (CAR |LETTMP#1|)) - (SETQ |n1| (CADR |LETTMP#1|)) - (SETQ |h| (CADDR |LETTMP#1|)) - (SETQ |t| (CADDDR |LETTMP#1|)) - (COND - (|b| (SETQ |LETTMP#1| (|shoePileForest1| |n| |t|)) - (SETQ |h1| (CAR |LETTMP#1|)) - (SETQ |t1| (CADR |LETTMP#1|)) - (LIST (CONS |h| |h1|) |t1|)) - ('T (LIST NIL |s|))))))) - -(DEFUN |shoePileForests| (|h| |n| |s|) - (PROG (|t1| |h1| |LETTMP#1|) - (RETURN - (PROGN - (SETQ |LETTMP#1| (|shoePileForest| |n| |s|)) - (SETQ |h1| (CAR |LETTMP#1|)) - (SETQ |t1| (CADR |LETTMP#1|)) - (COND - ((|bStreamNull| |h1|) (LIST T |n| |h| |s|)) - ('T (|shoePileForests| (|shoePileCtree| |h| |h1|) |n| |t1|))))))) - -(DEFUN |shoePileCtree| (|x| |y|) - (PROG () (RETURN (|dqAppend| |x| (|shoePileCforest| |y|))))) - -(DEFUN |shoePileCforest| (|x|) - (PROG (|b| |a|) - (RETURN - (COND - ((NULL |x|) NIL) - ((NULL (CDR |x|)) (CAR |x|)) - ('T (SETQ |a| (CAR |x|)) - (SETQ |b| (|shoePileCoagulate| |a| (CDR |x|))) - (COND - ((NULL (CDR |b|)) (CAR |b|)) - ('T (|shoeEnPile| (|shoeSeparatePiles| |b|))))))))) - -(DEFUN |shoePileCoagulate| (|a| |b|) - (PROG (|e| |d| |c|) - (RETURN - (COND - ((NULL |b|) (LIST |a|)) - ('T (SETQ |c| (CAR |b|)) - (COND - ((OR (EQ (|shoeTokPart| (CAAR |c|)) 'THEN) - (EQ (|shoeTokPart| (CAAR |c|)) 'ELSE)) - (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) - ('T (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|)) - (COND - ((AND (EQCAR |d| 'KEY) - (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA) - (EQ |e| 'SEMICOLON))) - (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) - ('T (CONS |a| (|shoePileCoagulate| |c| (CDR |b|)))))))))))) - -(DEFUN |shoeSeparatePiles| (|x|) - (PROG (|semicolon| |a|) - (RETURN - (COND - ((NULL |x|) NIL) - ((NULL (CDR |x|)) (CAR |x|)) - ('T (SETQ |a| (CAR |x|)) - (SETQ |semicolon| - (|dqUnit| - (|shoeTokConstruct| 'KEY 'BACKSET - (|shoeLastTokPosn| |a|)))) - (|dqConcat| - (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|))))))))) - -(DEFUN |shoeEnPile| (|x|) - (PROG () - (RETURN - (|dqConcat| (LIST (|dqUnit| - (|shoeTokConstruct| 'KEY 'SETTAB - (|shoeFirstTokPosn| |x|))) - |x| - (|dqUnit| - (|shoeTokConstruct| 'KEY 'BACKTAB - (|shoeLastTokPosn| |x|)))))))) - -@ -\eject -\begin -{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/btscan2.boot.pamphlet b/src/boot/btscan2.boot.pamphlet deleted file mode 100644 index 29ebf52..0000000 --- a/src/boot/btscan2.boot.pamphlet +++ /dev/null @@ -1,1399 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot btscan2.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package 'BOOTTRAN -EQCAR(x,y)== CONSP x and EQ(CAR x,y) - -dqUnit s==(a:=[s];CONS(a,a)) - -dqAppend(x,y)== - if null x - then y - else if null y - then x - else - RPLACD (CDR x,CAR y) - RPLACD (x, CDR y) - x - -dqConcat ld== - if null ld - then nil - else if null rest ld - then first ld - else dqAppend(first ld,dqConcat rest ld) - -dqToList s==if null s then nil else CAR s - -shoeConstructToken(ln,lp,b,n)==[b.0,b.1,:cons(lp,n)] -shoeTokType x== CAR x -shoeTokPart x== CADR x -shoeTokPosn x== CDDR x -shoeTokConstruct(x,y,z)==[x,y,:z] - -shoeNextLine(s)== - if bStreamNull s - then false - else - $linepos:=s - $f:= CAR s - $r:= CDR s - $ln:=CAR $f - $n:=STRPOSL('" ",$ln,0,true) - $sz :=# $ln - null $n => true - QENUM($ln,$n)=shoeTAB => - a:=MAKE_-FULL_-CVEC (7-REM($n,8) ,'" ") - $ln.$n:='" ".0 - $ln:=CONCAT(a,$ln) - s1:=cons(cons($ln,CDR $f),$r) - shoeNextLine s1 - true - -shoeLineToks(s)== - $f: local:=nil - $r:local :=nil - $ln:local :=nil - $n:local:=nil - $sz:local := nil - $floatok:local:=true - $linepos:local:=s - not shoeNextLine s => CONS(nil,nil) - null $n => shoeLineToks $r - fst:=QENUM($ln,0) - EQL(fst,shoeCLOSEPAREN)=> - command:=shoeLine? $ln=> - dq:=dqUnit shoeConstructToken - ($ln,$linepos,shoeLeafLine command,0) - cons([dq],$r) - command:=shoeLisp? $ln=> shoeLispToken($r,command) - command:=shoePackage? $ln=> - -- z:=car shoeBiteOff command - a:=CONCAT('"(IN-PACKAGE ",command,'")") - dq:=dqUnit shoeConstructToken - ($ln,$linepos,shoeLeafLisp a,0) - cons([dq],$r) - shoeLineToks $r - toks:=[] - while $n<$sz repeat toks:=dqAppend(toks,shoeToken()) - null toks => shoeLineToks $r - cons([toks],$r) - -shoeLispToken(s,string)== - string:= - # string=0 or EQL(QENUM(string,0),QENUM('";",0))=> '"" - string - ln:=$ln - linepos:=$linepos - [r,:st]:=shoeAccumulateLines(s,string) - dq:=dqUnit shoeConstructToken(ln,linepos,shoeLeafLisp st,0) - cons([dq],r) - -shoeAccumulateLines(s,string)== - not shoeNextLine s => CONS(s,string) - null $n => shoeAccumulateLines($r,string) - # $ln=0 => shoeAccumulateLines($r,string) - fst:=QENUM($ln,0) - EQL(fst,shoeCLOSEPAREN)=> - command:=shoeLisp? $ln - command and #command>0 => - EQL(QENUM(command,0),QENUM('";",0))=> - shoeAccumulateLines($r,string) - a:=STRPOS('";",command,0,nil) - a=> - shoeAccumulateLines($r, - CONCAT(string,SUBSTRING(command,0,a-1))) - shoeAccumulateLines($r,CONCAT(string,command)) - shoeAccumulateLines($r,string) - CONS(s,string) - -shoeToken () == - ln:=$ln - c:=QENUM($ln,$n) - linepos:=$linepos - n:=$n - ch:=$ln.$n - b:= - shoeStartsComment() => - shoeComment() - [] - shoeStartsNegComment() => - shoeNegComment() - [] - c=shoeLispESCAPE => - shoeLispEscape() - shoePunctuation c => shoePunct () - shoeStartsId ch => shoeWord (false) - c=shoeSPACE => - shoeSpace () - [] - c = shoeSTRING_CHAR => shoeString () - shoeDigit ch => shoeNumber () - c=shoeESCAPE => shoeEscape() - c=shoeTAB => - $n:=$n+1 - [] - shoeError () - null b => nil - dqUnit shoeConstructToken(ln,linepos,b,n) - --- to pair badge and badgee -shoeLeafId x== ["ID",INTERN x] - -shoeLeafKey x==["KEY",shoeKeyWord x] - -shoeLeafInteger x==["INTEGER",shoeIntValue x] - -shoeLeafFloat(a,w,e)== - b:=shoeIntValue CONCAT(a,w) - c:=DOUBLE b * EXPT(DOUBLE 10, e-#w) - ["FLOAT",c] - -shoeLeafString x == ["STRING",x] - -shoeLeafLisp x == ["LISP",x] -shoeLeafLispExp x == ["LISPEXP",x] - -shoeLeafLine x == ["LINE",x] - -shoeLeafComment x == ["COMMENT", x] - -shoeLeafNegComment x== ["NEGCOMMENT", x] - -shoeLeafError x == ["ERROR",x] - -shoeLeafSpaces x == ["SPACES",x] - -shoeLispEscape()== - $n:=$n+1 - if $n>=$sz - then - SoftShoeError(cons($linepos,$n),'"lisp escape error") - shoeLeafError ($ln.$n) - else - a:=shoeReadLispString($ln,$n) - null a => - SoftShoeError(cons($linepos,$n),'"lisp escape error") - shoeLeafError ($ln.$n) - [exp,n]:=a - null n => - $n:= $sz - shoeLeafLispExp exp - $n:=n - shoeLeafLispExp exp -shoeEscape()== - $n:=$n+1 - a:=shoeEsc() - if a then shoeWord true else nil - -shoeEsc()== - if $n>=$sz - then if shoeNextLine($r) - then - while null $n repeat shoeNextLine($r) - shoeEsc() - false - else false - else - n1:=STRPOSL('" ",$ln,$n,true) - if null n1 - then - shoeNextLine($r) - while null $n repeat shoeNextLine($r) - shoeEsc() - false - else true - -shoeStartsComment()== - if $n<$sz - then - if QENUM($ln,$n)=shoePLUSCOMMENT - then - www:=$n+1 - if www>=$sz - then false - else QENUM($ln,www) = shoePLUSCOMMENT - else false - else false - -shoeStartsNegComment()== - if $n< $sz - then - if QENUM($ln,$n)=shoeMINUSCOMMENT - then - www:=$n+1 - if www>=$sz - then false - else QENUM($ln,www) = shoeMINUSCOMMENT - else false - else false - -shoeNegComment()== - n:=$n - $n:=$sz - shoeLeafNegComment SUBSTRING($ln,n,nil) - -shoeComment()== - n:=$n - $n:=$sz - shoeLeafComment SUBSTRING($ln,n,nil) - -shoePunct()== - sss:=shoeMatch($ln,$n) - $n:=$n+#sss - shoeKeyTr sss - -shoeKeyTr w== - if EQ(shoeKeyWord w,"DOT") - then if $floatok - then shoePossFloat(w) - else shoeLeafKey w - else - $floatok:=not shoeCloser w - shoeLeafKey w - -shoePossFloat (w)== - if $n>=$sz or not shoeDigit $ln.$n - then shoeLeafKey w - else - w:=shoeInteger() - shoeExponent('"0",w) - - -shoeSpace()== - n:=$n - $n:=STRPOSL('" ",$ln,$n,true) - $floatok:=true - if null $n - then - shoeLeafSpaces 0 - $n:= # $ln - else shoeLeafSpaces ($n-n) - -shoeString()== - $n:=$n+1 - $floatok:=false - shoeLeafString shoeS () - -shoeS()== - if $n>=$sz - then - SoftShoeError(cons($linepos,$n),'"quote added") - '"" - else - n:=$n - strsym :=STRPOS ('"_"",$ln,$n,nil) or $sz - escsym:=STRPOS ('"__" - ,$ln,$n,nil) or $sz - mn:=MIN(strsym,escsym) - if mn=$sz - then - $n:=$sz - SoftShoeError(cons($linepos,$n),'"quote added") - SUBSTRING($ln,n,nil) - else if mn=strsym - then - $n:=mn+1 - SUBSTRING($ln,n,mn-n) - else - str:=SUBSTRING($ln,n,mn-n) - $n:=mn+1 - a:=shoeEsc() - b:=if a - then - str:=CONCAT(str,$ln.$n) - $n:=$n+1 - shoeS() - else shoeS() - CONCAT(str,b) - - - - -shoeIdEnd(line,n)== - while n<#line and shoeIdChar line.n repeat n:=n+1 - n - - -shoeDigit x== DIGIT_-CHAR_-P x - -shoeW(b)== - n1:=$n - $n:=$n+1 - l:=$sz - endid:=shoeIdEnd($ln,$n) - if endid=l or QENUM($ln,endid)^=shoeESCAPE - then - $n:=endid - [b,SUBSTRING($ln,n1,endid-n1)] - else - str:=SUBSTRING($ln,n1,endid-n1) - $n:=endid+1 - a:=shoeEsc() - bb:=if a - then shoeW(true) - else [b,'""] -- escape finds space or newline - [bb.0 or b,CONCAT(str,bb.1)] - -shoeWord(esp) == - aaa:=shoeW(false) - w:=aaa.1 - $floatok:=false - if esp or aaa.0 - then shoeLeafId w - else if shoeKeyWordP w - then - $floatok:=true - shoeLeafKey w - else shoeLeafId w - -shoeInteger()==shoeInteger1(false) - -shoeInteger1(zro) == - n:=$n - l:= $sz - while $n=$sz - then shoeLeafInteger a - else - if $floatok and QENUM($ln,$n)=shoeDOT - then - n:=$n - $n:=$n+1 - if $n<$sz and QENUM($ln,$n)=shoeDOT - then - $n:=n - shoeLeafInteger a - else - w:=shoeInteger1(true) - shoeExponent(a,w) - else shoeLeafInteger a - -shoeExponent(a,w)== - if $n>=$sz - then shoeLeafFloat(a,w,0) - else - n:=$n - c:=QENUM($ln,$n) - if c=shoeEXPONENT1 or c=shoeEXPONENT2 - then - $n:=$n+1 - if $n>=$sz - then - $n:=n - shoeLeafFloat(a,w,0) - else if shoeDigit($ln.$n) - then - e:=shoeInteger() - e:=shoeIntValue e - shoeLeafFloat(a,w,e) - else - c1:=QENUM($ln,$n) - if c1=shoePLUSCOMMENT or c1=shoeMINUSCOMMENT - then - $n:=$n+1 - if $n>=$sz - then - $n:=n - shoeLeafFloat(a,w,0) - else - if shoeDigit($ln.$n) - then - e:=shoeInteger() - e:=shoeIntValue e - shoeLeafFloat(a,w, - (if c1=shoeMINUSCOMMENT then MINUS e else e)) - else - $n:=n - shoeLeafFloat(a,w,0) - else shoeLeafFloat(a,w,0) - -shoeError()== - n:=$n - $n:=$n+1 - SoftShoeError(cons($linepos,n), - CONCAT( '"The character whose number is ", - STRINGIMAGE QENUM($ln,n),'" is not a Boot character")) - shoeLeafError ($ln.n) - -shoeOrdToNum x== DIGIT_-CHAR_-P x - -shoeKeyWord st == GETHASH(st,shoeKeyTable) - -shoeKeyWordP st == not null GETHASH(st,shoeKeyTable) - -shoeInsert(s,d) == - l := #s - h := QENUM(s,0) - u := ELT(d,h) - n := #u - k:=0 - while l <= #(ELT(u,k)) repeat - k:=k+1 - v := MAKE_-VEC(n+1) - for i in 0..k-1 repeat VEC_-SETELT(v,i,ELT(u,i)) - VEC_-SETELT(v,k,s) - for i in k..n-1 repeat VEC_-SETELT(v,i+1,ELT(u,i)) - VEC_-SETELT(d,h,v) - s - -shoeMatch(l,i)==shoeSubStringMatch(l,shoeDict,i) - -shoeSubStringMatch (l,d,i)== - h:= QENUM(l, i) - u:=ELT(d,h) - ll:=SIZE l - done:=false - s1:='"" - for j in 0.. SIZE u - 1 while not done repeat - s:=ELT(u,j) - ls:=SIZE s - done:=if ls+i > ll - then false - else - eql:= true - for k in 1..ls-1 while eql repeat - eql:= EQL(QENUM(s,k),QENUM(l,k+i)) - if eql - then - s1:=s - true - else false - s1 - -shoePunctuation c== shoePun.c =1 - -shoeKeyTableCons()== - KeyTable:=MAKE_-HASHTABLE("CVEC") - for st in shoeKeyWords repeat - HPUT(KeyTable,CAR st,CADR st) - KeyTable - -shoeDictCons()== - l:= HKEYS shoeKeyTable - d := - a:=MAKE_-VEC(256) - b:=MAKE_-VEC(1) - VEC_-SETELT(b,0,MAKE_-CVEC 0) - for i in 0..255 repeat VEC_-SETELT(a,i,b) - a - for s in l repeat shoeInsert(s,d) - d - - -shoePunCons()== - listing := HKEYS shoeKeyTable - a:=MAKE_-BVEC 256 - for i in 0..255 repeat BVEC_-SETELT(a,i,0) - for k in listing repeat - if not shoeStartsId k.0 - then BVEC_-SETELT(a,QENUM(k,0),1) - a -@ -<>= - -(|IN-PACKAGE| (QUOTE BOOTTRAN)) - -(DEFUN EQCAR (|x| |y|) - (PROG NIL - (RETURN (AND (CONSP |x|) (EQ (CAR |x|) |y|))))) - -(DEFUN |dqUnit| (|s|) - (PROG (|a|) - (RETURN (PROGN (SETQ |a| (LIST |s|)) (CONS |a| |a|))))) - -(DEFUN |dqAppend| (|x| |y|) - (PROG NIL - (RETURN - (COND - ((NULL |x|) |y|) - ((NULL |y|) |x|) - ((QUOTE T) - (RPLACD (CDR |x|) (CAR |y|)) - (RPLACD |x| (CDR |y|)) |x|))))) - -(DEFUN |dqConcat| (|ld|) - (PROG NIL - (RETURN - (COND - ((NULL |ld|) NIL) - ((NULL (CDR |ld|)) (CAR |ld|)) - ((QUOTE T) (|dqAppend| (CAR |ld|) (|dqConcat| (CDR |ld|)))))))) - -(DEFUN |dqToList| (|s|) - (PROG NIL - (RETURN - (COND - ((NULL |s|) NIL) - ((QUOTE T) (CAR |s|)))))) - -(DEFUN |shoeConstructToken| (|ln| |lp| |b| |n|) - (PROG NIL - (RETURN (CONS (ELT |b| 0) (CONS (ELT |b| 1) (CONS |lp| |n|)))))) - -(DEFUN |shoeTokType| (|x|) - (PROG NIL - (RETURN (CAR |x|)))) - -(DEFUN |shoeTokPart| (|x|) - (PROG NIL - (RETURN (CADR |x|)))) - -(DEFUN |shoeTokPosn| (|x|) - (PROG NIL - (RETURN (CDDR |x|)))) - -(DEFUN |shoeTokConstruct| (|x| |y| |z|) - (PROG NIL - (RETURN (CONS |x| (CONS |y| |z|))))) - -(DEFUN |shoeNextLine| (|s|) - (PROG (|s1| |a|) - (DECLARE (SPECIAL |$sz| |$n| |$ln| |$r| |$f| |$linepos|)) - (RETURN - (COND - ((|bStreamNull| |s|) NIL) - ((QUOTE T) - (SETQ |$linepos| |s|) - (SETQ |$f| (CAR |s|)) - (SETQ |$r| (CDR |s|)) - (SETQ |$ln| (CAR |$f|)) - (SETQ |$n| (STRPOSL " " |$ln| 0 T)) - (SETQ |$sz| (LENGTH |$ln|)) - (COND - ((NULL |$n|) T) - ((EQUAL (QENUM |$ln| |$n|) |shoeTAB|) - (PROGN - (SETQ |a| (|MAKE-FULL-CVEC| (|-| 7 (REM |$n| 8)) " ")) - (SETF (ELT |$ln| |$n|) (ELT " " 0)) - (SETQ |$ln| (CONCAT |a| |$ln|)) - (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|)) - (|shoeNextLine| |s1|))) - ((QUOTE T) T))))))) - -(DEFUN |shoeLineToks| (|s|) - (PROG (|$linepos| |$floatok| |$sz| |$n| |$ln| |$r| - |$f| |toks| |a| |dq| |command| |fst|) - (DECLARE (SPECIAL |$f| |$floatok| |$sz| |$linepos| |$ln| |$r| |$n|)) - (RETURN - (PROGN - (SETQ |$f| NIL) - (SETQ |$r| NIL) - (SETQ |$ln| NIL) - (SETQ |$n| NIL) - (SETQ |$sz| NIL) - (SETQ |$floatok| T) - (SETQ |$linepos| |s|) - (COND - ((NULL (|shoeNextLine| |s|)) (CONS NIL NIL)) - ((NULL |$n|) (|shoeLineToks| |$r|)) - (#1=(QUOTE T) - (PROGN - (SETQ |fst| (QENUM |$ln| 0)) - (COND - ((EQL |fst| |shoeCLOSEPAREN|) - (COND - ((SETQ |command| (|shoeLine?| |$ln|)) - (PROGN - (SETQ |dq| - (|dqUnit| - (|shoeConstructToken| - |$ln| - |$linepos| - (|shoeLeafLine| |command|) - 0))) - (CONS (LIST |dq|) |$r|))) - ((SETQ |command| (|shoeLisp?| |$ln|)) - (|shoeLispToken| |$r| |command|)) - ((SETQ |command| (|shoePackage?| |$ln|)) - (PROGN - (SETQ |a| (CONCAT "(IN-PACKAGE " |command| ")")) - (SETQ |dq| - (|dqUnit| - (|shoeConstructToken| - |$ln| - |$linepos| - (|shoeLeafLisp| |a|) - 0))) - (CONS (LIST |dq|) |$r|))) - (#1# (|shoeLineToks| |$r|)))) - (#1# - (PROGN - (SETQ |toks| NIL) - ((LAMBDA NIL - (LOOP - (COND - ((NOT (|<| |$n| |$sz|)) (RETURN NIL)) - ((QUOTE T) - (SETQ |toks| - (|dqAppend| |toks| (|shoeToken|)))))))) - (COND - ((NULL |toks|) (|shoeLineToks| |$r|)) - (#1# (CONS (LIST |toks|) |$r|))))))))))))) - -(DEFUN |shoeLispToken| (|s| |string|) - (PROG (|dq| |st| |r| |LETTMP#1| |linepos| |ln|) - (DECLARE (SPECIAL |$linepos| |$ln|)) - (RETURN - (PROGN - (SETQ |string| - (COND - ((OR (EQL (LENGTH |string|) 0) - (EQL (QENUM |string| 0) (QENUM ";" 0))) "") - ((QUOTE T) |string|))) - (SETQ |ln| |$ln|) - (SETQ |linepos| |$linepos|) - (SETQ |LETTMP#1| (|shoeAccumulateLines| |s| |string|)) - (SETQ |r| (CAR |LETTMP#1|)) - (SETQ |st| (CDR |LETTMP#1|)) - (SETQ |dq| - (|dqUnit| - (|shoeConstructToken| |ln| |linepos| (|shoeLeafLisp| |st|) 0))) - (CONS (LIST |dq|) |r|))))) - -(DEFUN |shoeAccumulateLines| (|s| |string|) - (PROG (|a| |command| |fst|) - (DECLARE (SPECIAL |$ln| |$r| |$n|)) - (RETURN - (COND - ((NULL (|shoeNextLine| |s|)) (CONS |s| |string|)) - ((NULL |$n|) (|shoeAccumulateLines| |$r| |string|)) - ((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|)) - (#1=(QUOTE T) - (PROGN - (SETQ |fst| (QENUM |$ln| 0)) - (COND - ((EQL |fst| |shoeCLOSEPAREN|) - (PROGN - (SETQ |command| (|shoeLisp?| |$ln|)) - (COND - ((AND |command| (|<| 0 (LENGTH |command|))) - (COND - ((EQL (QENUM |command| 0) (QENUM ";" 0)) - (|shoeAccumulateLines| |$r| |string|)) - (#1# - (PROGN - (SETQ |a| (STRPOS ";" |command| 0 NIL)) - (COND - (|a| - (|shoeAccumulateLines| - |$r| - (CONCAT |string| - (SUBSTRING |command| 0 (|-| |a| 1))))) - (#1# - (|shoeAccumulateLines| - |$r| - (CONCAT |string| |command|)))))))) - (#1# (|shoeAccumulateLines| |$r| |string|))))) - (#1# (CONS |s| |string|))))))))) - -(DEFUN |shoeToken| NIL - (PROG (|b| |ch| |n| |linepos| |c| |ln|) - (DECLARE (SPECIAL |$linepos| |$n| |$ln|)) - (RETURN - (PROGN - (SETQ |ln| |$ln|) - (SETQ |c| (QENUM |$ln| |$n|)) - (SETQ |linepos| |$linepos|) - (SETQ |n| |$n|) - (SETQ |ch| (ELT |$ln| |$n|)) - (SETQ |b| - (COND - ((|shoeStartsComment|) (PROGN (|shoeComment|) NIL)) - ((|shoeStartsNegComment|) (PROGN (|shoeNegComment|) NIL)) - ((EQUAL |c| |shoeLispESCAPE|) (|shoeLispEscape|)) - ((|shoePunctuation| |c|) (|shoePunct|)) - ((|shoeStartsId| |ch|) (|shoeWord| NIL)) - ((EQUAL |c| |shoeSPACE|) (PROGN (|shoeSpace|) NIL)) - ((EQUAL |c| |shoeSTRINGCHAR|) (|shoeString|)) - ((|shoeDigit| |ch|) (|shoeNumber|)) - ((EQUAL |c| |shoeESCAPE|) (|shoeEscape|)) - ((EQUAL |c| |shoeTAB|) (PROGN (SETQ |$n| (|+| |$n| 1)) NIL)) - (#1=(QUOTE T) (|shoeError|)))) - (COND - ((NULL |b|) NIL) - (#1# (|dqUnit| (|shoeConstructToken| |ln| |linepos| |b| |n|)))))))) - -(DEFUN |shoeLeafId| (|x|) - (PROG NIL - (RETURN (LIST (QUOTE ID) (INTERN |x|))))) - -(DEFUN |shoeLeafKey| (|x|) - (PROG NIL - (RETURN (LIST (QUOTE KEY) (|shoeKeyWord| |x|))))) - -(DEFUN |shoeLeafInteger| (|x|) - (PROG NIL - (RETURN (LIST (QUOTE INTEGER) (|shoeIntValue| |x|))))) - -(DEFUN |shoeLeafFloat| (|a| |w| |e|) - (PROG (|c| |b|) - (RETURN - (PROGN - (SETQ |b| (|shoeIntValue| (CONCAT |a| |w|))) - (SETQ |c| (|*| (FLOAT |b|) (EXPT (FLOAT 10) (|-| |e| (LENGTH |w|))))) - (LIST (QUOTE FLOAT) |c|))))) - -(DEFUN |shoeLeafString| (|x|) - (PROG NIL - (RETURN (LIST (QUOTE STRING) |x|)))) - -(DEFUN |shoeLeafLisp| (|x|) - (PROG NIL - (RETURN (LIST (QUOTE LISP) |x|)))) - -(DEFUN |shoeLeafLispExp| (|x|) - (PROG NIL - (RETURN (LIST (QUOTE LISPEXP) |x|)))) - -(DEFUN |shoeLeafLine| (|x|) - (PROG NIL - (RETURN (LIST (QUOTE LINE) |x|)))) - -(DEFUN |shoeLeafComment| (|x|) - (PROG NIL - (RETURN (LIST (QUOTE COMMENT) |x|)))) - -(DEFUN |shoeLeafNegComment| (|x|) - (PROG NIL - (RETURN (LIST (QUOTE NEGCOMMENT) |x|)))) - -(DEFUN |shoeLeafError| (|x|) - (PROG NIL - (RETURN (LIST (QUOTE ERROR) |x|)))) - -(DEFUN |shoeLeafSpaces| (|x|) - (PROG NIL - (RETURN (LIST (QUOTE SPACES) |x|)))) - -(DEFUN |shoeLispEscape| NIL - (PROG (|n| |exp| |a|) - (DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |$n| (|+| |$n| 1)) - (COND - ((NOT (|<| |$n| |$sz|)) - (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error") - (|shoeLeafError| (ELT |$ln| |$n|))) - ((QUOTE T) - (SETQ |a| (|shoeReadLispString| |$ln| |$n|)) - (COND - ((NULL |a|) - (PROGN - (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error") - (|shoeLeafError| (ELT |$ln| |$n|)))) - (#1=(QUOTE T) - (PROGN - (SETQ |exp| (CAR |a|)) - (SETQ |n| (CADR |a|)) - (COND - ((NULL |n|) - (PROGN - (SETQ |$n| |$sz|) - (|shoeLeafLispExp| |exp|))) - (#1# - (PROGN - (SETQ |$n| |n|) - (|shoeLeafLispExp| |exp|))))))))))))) - -(DEFUN |shoeEscape| NIL - (PROG (|a|) - (DECLARE (SPECIAL |$n|)) - (RETURN - (PROGN - (SETQ |$n| (|+| |$n| 1)) - (SETQ |a| (|shoeEsc|)) - (COND - (|a| (|shoeWord| T)) - ((QUOTE T) NIL)))))) - -(DEFUN |shoeEsc| NIL - (PROG (|n1|) - (DECLARE (SPECIAL |$ln| |$r| |$sz| |$n|)) - (RETURN - (COND - ((NOT (|<| |$n| |$sz|)) - (COND - ((|shoeNextLine| |$r|) - ((LAMBDA NIL - (LOOP - (COND - (|$n| (RETURN NIL)) - (#1=(QUOTE T) (|shoeNextLine| |$r|)))))) - (|shoeEsc|) - NIL) - (#2=(QUOTE T) NIL))) - (#2# - (SETQ |n1| (STRPOSL " " |$ln| |$n| T)) - (COND - ((NULL |n1|) - (|shoeNextLine| |$r|) - ((LAMBDA NIL - (LOOP - (COND - (|$n| (RETURN NIL)) - (#1# (|shoeNextLine| |$r|)))))) - (|shoeEsc|) - NIL) - (#2# T))))))) - -(DEFUN |shoeStartsComment| NIL - (PROG (|www|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (COND - ((|<| |$n| |$sz|) - (COND - ((EQUAL (QENUM |$ln| |$n|) |shoePLUSCOMMENT|) - (SETQ |www| (|+| |$n| 1)) - (COND - ((NOT (|<| |www| |$sz|)) NIL) - (#1=(QUOTE T) - (EQUAL (QENUM |$ln| |www|) |shoePLUSCOMMENT|)))) - (#1# NIL))) - (#1# NIL))))) - -(DEFUN |shoeStartsNegComment| NIL - (PROG (|www|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (COND - ((|<| |$n| |$sz|) - (COND - ((EQUAL (QENUM |$ln| |$n|) |shoeMINUSCOMMENT|) - (SETQ |www| (|+| |$n| 1)) - (COND - ((NOT (|<| |www| |$sz|)) NIL) - (#1=(QUOTE T) - (EQUAL (QENUM |$ln| |www|) |shoeMINUSCOMMENT|)))) - (#1# NIL))) - (#1# NIL))))) - -(DEFUN |shoeNegComment| NIL - (PROG (|n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |$n| |$sz|) - (|shoeLeafNegComment| (SUBSTRING |$ln| |n| NIL)))))) - -(DEFUN |shoeComment| NIL - (PROG (|n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |$n| |$sz|) - (|shoeLeafComment| (SUBSTRING |$ln| |n| NIL)))))) - -(DEFUN |shoePunct| NIL - (PROG (|sss|) - (DECLARE (SPECIAL |$n| |$ln|)) - (RETURN - (PROGN - (SETQ |sss| (|shoeMatch| |$ln| |$n|)) - (SETQ |$n| (|+| |$n| (LENGTH |sss|))) - (|shoeKeyTr| |sss|))))) - -(DEFUN |shoeKeyTr| (|w|) - (PROG NIL - (DECLARE (SPECIAL |$floatok|)) - (RETURN - (COND - ((EQ (|shoeKeyWord| |w|) (QUOTE DOT)) - (COND - (|$floatok| (|shoePossFloat| |w|)) - (#1=(QUOTE T) (|shoeLeafKey| |w|)))) - (#1# - (SETQ |$floatok| (NULL (|shoeCloser| |w|))) - (|shoeLeafKey| |w|)))))) - -(DEFUN |shoePossFloat| (|w|) - (PROG NIL - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (COND - ((OR (NOT (|<| |$n| |$sz|)) (NULL (|shoeDigit| (ELT |$ln| |$n|)))) - (|shoeLeafKey| |w|)) - ((QUOTE T) - (SETQ |w| (|shoeInteger|)) (|shoeExponent| "0" |w|)))))) - -(DEFUN |shoeSpace| NIL - (PROG (|n|) - (DECLARE (SPECIAL |$floatok| |$ln| |$n|)) - (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |$n| (STRPOSL " " |$ln| |$n| T)) - (SETQ |$floatok| T) - (COND - ((NULL |$n|) (|shoeLeafSpaces| 0) (SETQ |$n| (LENGTH |$ln|))) - ((QUOTE T) (|shoeLeafSpaces| (|-| |$n| |n|)))))))) - -(DEFUN |shoeString| NIL - (PROG NIL - (DECLARE (SPECIAL |$floatok| |$n|)) - (RETURN - (PROGN - (SETQ |$n| (|+| |$n| 1)) - (SETQ |$floatok| NIL) - (|shoeLeafString| (|shoeS|)))))) - -(DEFUN |shoeS| NIL - (PROG (|b| |a| |str| |mn| |escsym| |strsym| |n|) - (DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|)) - (RETURN - (COND - ((NOT (|<| |$n| |$sz|)) - (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") "") - (#1=(QUOTE T) - (SETQ |n| |$n|) - (SETQ |strsym| (OR (STRPOS "\"" |$ln| |$n| NIL) |$sz|)) - (SETQ |escsym| (OR (STRPOS "_" |$ln| |$n| NIL) |$sz|)) - (SETQ |mn| (MIN |strsym| |escsym|)) - (COND - ((EQUAL |mn| |$sz|) - (SETQ |$n| |$sz|) - (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") - (SUBSTRING |$ln| |n| NIL)) - ((EQUAL |mn| |strsym|) - (SETQ |$n| (|+| |mn| 1)) - (SUBSTRING |$ln| |n| (|-| |mn| |n|))) - (#1# - (SETQ |str| (SUBSTRING |$ln| |n| (|-| |mn| |n|))) - (SETQ |$n| (|+| |mn| 1)) - (SETQ |a| (|shoeEsc|)) - (SETQ |b| - (COND - (|a| - (SETQ |str| (CONCAT |str| (ELT |$ln| |$n|))) - (SETQ |$n| (|+| |$n| 1)) - (|shoeS|)) - (#1# (|shoeS|)))) - (CONCAT |str| |b|)))))))) - -(DEFUN |shoeIdEnd| (|line| |n|) - (PROG NIL - (RETURN - (PROGN - ((LAMBDA NIL - (LOOP - (COND - ((NOT - (AND - (|<| |n| (LENGTH |line|)) - (|shoeIdChar| (ELT |line| |n|)))) - (RETURN NIL)) - ((QUOTE T) - (SETQ |n| (|+| |n| 1))))))) - |n|)))) - -(DEFUN |shoeDigit| (|x|) - (PROG NIL - (RETURN (|DIGIT-CHAR-P| |x|)))) - -(DEFUN |shoeW| (|b|) - (PROG (|bb| |a| |str| |endid| |l| |n1|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |n1| |$n|) - (SETQ |$n| (|+| |$n| 1)) - (SETQ |l| |$sz|) - (SETQ |endid| (|shoeIdEnd| |$ln| |$n|)) - (COND - ((OR - (EQUAL |endid| |l|) - (NOT (EQUAL (QENUM |$ln| |endid|) |shoeESCAPE|))) - (SETQ |$n| |endid|) - (LIST |b| (SUBSTRING |$ln| |n1| (|-| |endid| |n1|)))) - (#1=(QUOTE T) - (SETQ |str| (SUBSTRING |$ln| |n1| (|-| |endid| |n1|))) - (SETQ |$n| (|+| |endid| 1)) - (SETQ |a| (|shoeEsc|)) - (SETQ |bb| (COND (|a| (|shoeW| T)) (#1# (LIST |b| "")))) - (LIST (OR (ELT |bb| 0) |b|) (CONCAT |str| (ELT |bb| 1))))))))) - -(DEFUN |shoeWord| (|esp|) - (PROG (|w| |aaa|) - (DECLARE (SPECIAL |$floatok|)) - (RETURN - (PROGN - (SETQ |aaa| (|shoeW| NIL)) - (SETQ |w| (ELT |aaa| 1)) - (SETQ |$floatok| NIL) - (COND - ((OR |esp| (ELT |aaa| 0)) (|shoeLeafId| |w|)) - ((|shoeKeyWordP| |w|) (SETQ |$floatok| T) (|shoeLeafKey| |w|)) - ((QUOTE T) (|shoeLeafId| |w|))))))) - -(DEFUN |shoeInteger| NIL - (PROG NIL - (RETURN (|shoeInteger1| NIL)))) - -(DEFUN |shoeInteger1| (|zro|) - (PROG (|bb| |a| |str| |l| |n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |l| |$sz|) - ((LAMBDA NIL - (LOOP - (COND - ((NOT (AND (|<| |$n| |l|) (|shoeDigit| (ELT |$ln| |$n|)))) - (RETURN NIL)) - ((QUOTE T) (SETQ |$n| (|+| |$n| 1))))))) - (COND - ((OR (EQUAL |$n| |l|) (NOT (EQUAL (QENUM |$ln| |$n|) |shoeESCAPE|))) - (COND - ((AND (EQUAL |n| |$n|) |zro|) - "0") - (#1=(QUOTE T) - (SUBSTRING |$ln| |n| (|-| |$n| |n|))))) - (#1# - (SETQ |str| (SUBSTRING |$ln| |n| (|-| |$n| |n|))) - (SETQ |$n| (|+| |$n| 1)) - (SETQ |a| (|shoeEsc|)) - (SETQ |bb| (|shoeInteger1| |zro|)) - (CONCAT |str| |bb|))))))) - -(DEFUN |shoeIntValue| (|s|) - (PROG (|d| |ival| |ns|) - (RETURN - (PROGN - (SETQ |ns| (LENGTH |s|)) - (SETQ |ival| 0) - ((LAMBDA (|bfVar#1| |i|) - (LOOP - (COND - ((|>| |i| |bfVar#1|) (RETURN NIL)) - ((QUOTE T) - (PROGN - (SETQ |d| (|shoeOrdToNum| (ELT |s| |i|))) - (SETQ |ival| (|+| (|*| 10 |ival|) |d|))))) - (SETQ |i| (|+| |i| 1)))) - (|-| |ns| 1) 0) - |ival|)))) - -(DEFUN |shoeNumber| NIL - (PROG (|w| |n| |a|) - (DECLARE (SPECIAL |$ln| |$floatok| |$sz| |$n|)) - (RETURN - (PROGN - (SETQ |a| (|shoeInteger|)) - (COND - ((NOT (|<| |$n| |$sz|)) (|shoeLeafInteger| |a|)) - ((AND |$floatok| (EQUAL (QENUM |$ln| |$n|) |shoeDOT|)) - (SETQ |n| |$n|) - (SETQ |$n| (|+| |$n| 1)) - (COND - ((AND (|<| |$n| |$sz|) (EQUAL (QENUM |$ln| |$n|) |shoeDOT|)) - (SETQ |$n| |n|) - (|shoeLeafInteger| |a|)) - (#1=(QUOTE T) - (SETQ |w| (|shoeInteger1| T)) - (|shoeExponent| |a| |w|)))) - (#1# (|shoeLeafInteger| |a|))))))) - -(DEFUN |shoeExponent| (|a| |w|) - (PROG (|c1| |e| |c| |n|) - (DECLARE (SPECIAL |$ln| |$sz| |$n|)) - (RETURN - (COND - ((NOT (|<| |$n| |$sz|)) - (|shoeLeafFloat| |a| |w| 0)) - (#1=(QUOTE T) - (SETQ |n| |$n|) - (SETQ |c| (QENUM |$ln| |$n|)) - (COND - ((OR (EQUAL |c| |shoeEXPONENT1|) (EQUAL |c| |shoeEXPONENT2|)) - (SETQ |$n| (|+| |$n| 1)) - (COND - ((NOT (|<| |$n| |$sz|)) - (SETQ |$n| |n|) - (|shoeLeafFloat| |a| |w| 0)) - ((|shoeDigit| (ELT |$ln| |$n|)) - (SETQ |e| (|shoeInteger|)) - (SETQ |e| (|shoeIntValue| |e|)) - (|shoeLeafFloat| |a| |w| |e|)) - (#1# - (SETQ |c1| (QENUM |$ln| |$n|)) - (COND - ((OR - (EQUAL |c1| |shoePLUSCOMMENT|) - (EQUAL |c1| |shoeMINUSCOMMENT|)) - (SETQ |$n| (|+| |$n| 1)) - (COND - ((NOT (|<| |$n| |$sz|)) - (SETQ |$n| |n|) - (|shoeLeafFloat| |a| |w| 0)) - ((|shoeDigit| (ELT |$ln| |$n|)) - (SETQ |e| (|shoeInteger|)) - (SETQ |e| (|shoeIntValue| |e|)) - (|shoeLeafFloat| - |a| - |w| - (COND - ((EQUAL |c1| |shoeMINUSCOMMENT|) (|-| |e|)) - (#1# |e|)))) - (#1# - (SETQ |$n| |n|) (|shoeLeafFloat| |a| |w| 0)))))))) - (#1# (|shoeLeafFloat| |a| |w| 0)))))))) - -(DEFUN |shoeError| NIL - (PROG (|n|) - (DECLARE (SPECIAL |$ln| |$linepos| |$n|)) - (RETURN - (PROGN - (SETQ |n| |$n|) - (SETQ |$n| (|+| |$n| 1)) - (|SoftShoeError| - (CONS |$linepos| |n|) - (CONCAT - "The character whose number is " - (STRINGIMAGE (QENUM |$ln| |n|)) - " is not a Boot character")) - (|shoeLeafError| (ELT |$ln| |n|)))))) - -(DEFUN |shoeOrdToNum| (|x|) - (PROG NIL - (RETURN (|DIGIT-CHAR-P| |x|)))) - -(DEFUN |shoeKeyWord| (|st|) - (PROG NIL - (RETURN (GETHASH |st| |shoeKeyTable|)))) - -(DEFUN |shoeKeyWordP| (|st|) - (PROG NIL - (RETURN (NULL (NULL (GETHASH |st| |shoeKeyTable|)))))) - -(DEFUN |shoeInsert| (|s| |d|) - (PROG (|v| |k| |n| |u| |h| |l|) - (RETURN - (PROGN - (SETQ |l| (LENGTH |s|)) - (SETQ |h| (QENUM |s| 0)) - (SETQ |u| (ELT |d| |h|)) - (SETQ |n| (LENGTH |u|)) - (SETQ |k| 0) - ((LAMBDA NIL - (LOOP - (COND - ((|<| (LENGTH (ELT |u| |k|)) |l|) (RETURN NIL)) - (#1=(QUOTE T) (SETQ |k| (|+| |k| 1))))))) - (SETQ |v| (|MAKE-VEC| (|+| |n| 1))) - ((LAMBDA (|bfVar#2| |i|) - (LOOP - (COND - ((|>| |i| |bfVar#2|) (RETURN NIL)) - (#1# - (|VEC-SETELT| |v| |i| (ELT |u| |i|)))) - (SETQ |i| (|+| |i| 1)))) - (|-| |k| 1) 0) - (|VEC-SETELT| |v| |k| |s|) - ((LAMBDA (|bfVar#3| |i|) - (LOOP - (COND - ((|>| |i| |bfVar#3|) (RETURN NIL)) - (#1# (|VEC-SETELT| |v| (|+| |i| 1) (ELT |u| |i|)))) - (SETQ |i| (|+| |i| 1)))) - (|-| |n| 1) |k|) - (|VEC-SETELT| |d| |h| |v|) |s|)))) - -(DEFUN |shoeMatch| (|l| |i|) - (PROG NIL - (RETURN (|shoeSubStringMatch| |l| |shoeDict| |i|)))) - -(DEFUN |shoeSubStringMatch| (|l| |d| |i|) - (PROG (|eql| |ls| |s| |s1| |done| |ll| |u| |h|) - (RETURN - (PROGN - (SETQ |h| (QENUM |l| |i|)) - (SETQ |u| (ELT |d| |h|)) - (SETQ |ll| (SIZE |l|)) - (SETQ |done| NIL) - (SETQ |s1| "") - ((LAMBDA (|bfVar#4| |j|) - (LOOP - (COND - ((OR (|>| |j| |bfVar#4|) |done|) (RETURN NIL)) - (#1=(QUOTE T) - (PROGN - (SETQ |s| (ELT |u| |j|)) - (SETQ |ls| (SIZE |s|)) - (SETQ |done| - (COND - ((|<| |ll| (|+| |ls| |i|)) NIL) - (#2=(QUOTE T) - (SETQ |eql| T) - ((LAMBDA (|bfVar#5| |k|) - (LOOP - (COND - ((OR (|>| |k| |bfVar#5|) (NOT |eql|)) - (RETURN NIL)) - (#1# - (SETQ |eql| - (EQL - (QENUM |s| |k|) - (QENUM |l| (|+| |k| |i|)))))) - (SETQ |k| (|+| |k| 1)))) - (|-| |ls| 1) 1) - (COND - (|eql| (SETQ |s1| |s|) T) - (#2# NIL)))))))) - (SETQ |j| (|+| |j| 1)))) - (|-| (SIZE |u|) 1) 0) |s1|)))) - -(DEFUN |shoePunctuation| (|c|) - (PROG NIL - (RETURN (EQL (ELT |shoePun| |c|) 1)))) - -(DEFUN |shoeKeyTableCons| NIL - (PROG (|KeyTable|) - (RETURN - (PROGN - (SETQ |KeyTable| (|MAKE-HASHTABLE| (QUOTE CVEC))) - ((LAMBDA (|bfVar#6| |st|) - (LOOP - (COND - ((OR (ATOM |bfVar#6|) (PROGN (SETQ |st| (CAR |bfVar#6|)) NIL)) - (RETURN NIL)) - ((QUOTE T) - (HPUT |KeyTable| (CAR |st|) (CADR |st|)))) - (SETQ |bfVar#6| (CDR |bfVar#6|)))) - |shoeKeyWords| NIL) - |KeyTable|)))) - -(DEFUN |shoeDictCons| NIL - (PROG (|d| |b| |a| |l|) - (RETURN - (PROGN - (SETQ |l| (HKEYS |shoeKeyTable|)) - (SETQ |d| - (PROGN - (SETQ |a| (|MAKE-VEC| 256)) - (SETQ |b| (|MAKE-VEC| 1)) - (|VEC-SETELT| |b| 0 (|MAKE-CVEC| 0)) - ((LAMBDA (|i|) - (LOOP - (COND - ((|>| |i| 255) (RETURN NIL)) - (#1=(QUOTE T) - (|VEC-SETELT| |a| |i| |b|))) - (SETQ |i| (|+| |i| 1)))) - 0) - |a|)) - ((LAMBDA (|bfVar#7| |s|) - (LOOP - (COND - ((OR (ATOM |bfVar#7|) (PROGN (SETQ |s| (CAR |bfVar#7|)) NIL)) - (RETURN NIL)) - (#1# (|shoeInsert| |s| |d|))) - (SETQ |bfVar#7| (CDR |bfVar#7|)))) - |l| NIL) - |d|)))) - -(DEFUN |shoePunCons| NIL - (PROG (|a| |listing|) - (RETURN - (PROGN - (SETQ |listing| (HKEYS |shoeKeyTable|)) - (SETQ |a| (|MAKE-BVEC| 256)) - ((LAMBDA (|i|) - (LOOP - (COND - ((|>| |i| 255) (RETURN NIL)) - (#1=(QUOTE T) - (|BVEC-SETELT| |a| |i| 0))) - (SETQ |i| (|+| |i| 1)))) - 0) - ((LAMBDA (|bfVar#8| |k|) - (LOOP - (COND - ((OR (ATOM |bfVar#8|) (PROGN (SETQ |k| (CAR |bfVar#8|)) NIL)) - (RETURN NIL)) - (#1# - (COND - ((NULL (|shoeStartsId| (ELT |k| 0))) - (|BVEC-SETELT| |a| (QENUM |k| 0) 1))))) - (SETQ |bfVar#8| (CDR |bfVar#8|)))) - |listing| - NIL) - |a|)))) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/ccl-bootsys.lsp.pamphlet b/src/boot/ccl-bootsys.lsp.pamphlet deleted file mode 100644 index 2031c38..0000000 --- a/src/boot/ccl-bootsys.lsp.pamphlet +++ /dev/null @@ -1,33 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot ccl-bootsys.lsp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -<<*>>= -(defun in-package (name &rest ignored) (let ((p (find-package name))) (if p (setq *package* p) (error (format nil "Package ~S not found" name))))) - -(load "boothdr.lisp") -(load "exports.lisp") -(load "npextras.lisp") -(load "ptyout.clisp") -(load "btincl2.clisp") -(load "btscan2.clisp") -(load "typrops.clisp") -(load "btpile2.clisp") -(load "typars.clisp") -(load "tyextra.clisp") -(load "tytree1.clisp") - -(preserve) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/ccl-depsys.lsp.pamphlet b/src/boot/ccl-depsys.lsp.pamphlet deleted file mode 100644 index b0e91fc..0000000 --- a/src/boot/ccl-depsys.lsp.pamphlet +++ /dev/null @@ -1,88 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot/ccl-depsys.lsp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -<<*>>= -;; -;; This builds "depsys" on top of CCL. -;; - -(push :oldboot *features*) - -(load "try1.lsp") ;; Fix-ups for the Lisp package - -(in-package "LISP") -(setq *echo nil) -(setq *read-default-float-format* 'double-float) - -(load "sys-pkg.lisp") - -(in-package "VMLISP") -;; new divide of divide in ccl yields a dotted pair -(defun divide (x y) (multiple-value-list (truncate x y))) -(defvar boot::|$SessionManager| 'boot-session-manager) -(defvar boot::|$EndOfOutput| 'boot-end-of-output) - -(load "parsing_macros.lsp") ;; For macro defs used by util. -(load "util.lisp") - -;; start of OBJS -(load "vmlisp.lisp") -(load "hash.lisp") -(load "bootfuns.lisp") -(load "macros.lisp") -(load "spad.lisp") -(load "spaderror.lisp") -(load "unlisp.lisp") -(load "setq.lisp") -(load "bits.lisp") -(load "cfuns.lisp") -(load "comp.lisp") -(load "debug.lisp") -(load "fname.lisp") -(load "ggreater.lisp") -(load "nci.lisp") -(load "newaux.lisp") -(load "nlib.lisp") -(load "property.lisp") -(load "sfsfun-l.lisp") -(load "sockio.lisp") -(load "union.lisp") -;; end of OBJS - -;; Objects from autoload metaparser sector -(load "parsing.lisp") -(load "bootlex.lisp") -(load "def.lisp") -(load "fnewmeta.lisp") -(load "metalex.lisp") -(load "postprop.lisp") -(load "preparse.lisp") - -; end -; THE CLISP FILES we need -(load "postpar.clisp") -(load "g-boot.clisp") -(load "g-util.clisp") -(load "clam.clisp") -(load "slam.clisp") - - -(copy-module 'ccomp) - -(preserve) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/exports.lisp.pamphlet b/src/boot/exports.lisp.pamphlet deleted file mode 100644 index 60af093..0000000 --- a/src/boot/exports.lisp.pamphlet +++ /dev/null @@ -1,83 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot exports.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -(in-package 'boottran) -(export '( - boottocl - boottocllines - boottoclc - boottoclclines - boottomc - compile-boot-file - boot - eval-boot-file - bo - fbo - fev - stout - steval - sttomc - fc - boot-compile-definition-from-file - boot-eval-definition-from-file - boot-print-definition-from-file - boclam - bootclam - bootloop - defuse - xref - )) - -;## For Rios C compiler -(defun dummy2 (x) x) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/npextras.lisp.pamphlet b/src/boot/npextras.lisp.pamphlet deleted file mode 100644 index 84d0dab..0000000 --- a/src/boot/npextras.lisp.pamphlet +++ /dev/null @@ -1,206 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot npextras.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{GCL cmpnote function} -GCL keeps noting the fact that the compiler is performing tail-recursion. -Bill Schelter added this as a debugging tool for Axiom and it was never -removed. Patching the lisp code in the GCL build fails as the system -is actually built from the pre-compiled C code. Thus, we can only step -on this message after the fact. The cmpnote function is used nowhere -else in GCL so stepping on the function call seems best. We're unhappy -with this hack and will try to convince the GCL crowd to fix this. -<>= -#+:gcl (defun compiler::cmpnote (&rest x)) -@ -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -<> - -(in-package 'boottran :use '("LISP" "SYSTEM")) -(defun double (x) (float x 1.D0)) -(defun |char| (x) (CHAR (PNAME x) 0)) -(defmacro memq (a b) `(member ,a ,b :test #'eq)) -(defvar |$lispType| '|Common|) -(defvar |$lispName| '|Common|) -(defvar |$machineType| 'RTPC) -(defvar *lisp-bin-filetype* "o") -(defvar *lisp-source-filetype* "lisp") -(defun |shoeCOMPILE-FILE| (fn) (compile-file fn )) -(defun setdifference (x y) (set-difference x y)) -(defun make-cvec (sint) (make-string sint)) -(defun MAKE-VEC (n) (make-array n)) -(defun concat (&rest l) - (progn - (setq l (mapcar #'string l)) - (apply #'concatenate 'string l))) - -(defun |shoeInputFile| (filespec ) - (open filespec :direction :input :if-does-not-exist nil)) - -(defun |shoeCLOSE| (s) (close s)) - -(defmacro |shoeOpenInputFile| - (stream fn prog) - `(with-open-file (,stream ,fn :direction :input - :if-does-not-exist nil) ,prog)) - -(defmacro |shoeOpenOutputFile| - (stream fn prog) - `(with-open-file (,stream ,fn :direction :output - :if-exists :supersede) ,prog)) - -(defun |shoeConsole| (line) (write-line line *terminal-io*)) - -(defun reallyprettyprint (x &optional (stream *terminal-io*)) - (shoeprettyprin1 x stream) (terpri stream)) - -(defun shoeprettyprin1 (x &optional (stream *standard-output*)) - (let ( - (*print-pretty* t) - (*print-array* t) - (*print-circle* t) - (*print-level* nil) - (*print-length* nil) - ) - (prin1 x stream))) - -(defun shoenotprettyprint (x &optional (stream *terminal-io*)) - (shoeprettyprin0 x stream) (terpri stream)) - -(defun shoeprettyprin0 (x &optional (stream *standard-output*)) - (let ( - (*print-pretty* nil) - (*print-array* t) - (*print-circle* t) - (*print-level* nil) - (*print-length* nil) - ) - (prin1 x stream))) - -(defun make-full-cvec (sint &optional (char #\space)) - (make-string sint :initial-element (character char))) - -(defun |shoeread-line| (st &optional (eofval nil)) - (read-line st nil eofval)) - -(defun |shoePLACEP| (item) (eq item nil)) -(defun substring (cvec start length) - (if length (subseq cvec start (+ start length)) (subseq cvec start))) - -(defun MAKE-HASHTABLE (id1) - (let ((test (case id1 - ((EQ ID) #'eq) - (CVEC #'equal) - ((UEQUAL EQUAL) #'equal) - (otherwise (error "bad arg to make-hashtable"))))) - (make-hash-table :test test))) - -(defun HKEYS (table) - (let (keys) - (maphash #'(lambda (key val) - (declare (ignore val)) - (push key keys)) table) - keys)) - - -(defun HPUT (table key value) (setf (gethash key table) value)) - - -(defun stringimage (x) (write-to-string x)) - -(defun QENUM (cvec ind) (char-code (char cvec ind))) - -(defun charmem (a b) (member a b :test #'eql)) - -(defun |shoeCloser| (w) (MEMQ (|shoeKeyWord| w) '(CPAREN CBRACK))) -(defun |shoeIdChar| (x)(or (ALPHANUMERICP x) - (charmem x '(#\' #\? #\%)))) -(defun |shoeStartsId| (x) (or (alpha-char-p x) - (charmem x '(#\$ #\? #\%)))) - -(defun strpos (what in start dontcare) - (setq what (string what) in (string in)) - (if dontcare (progn (setq dontcare (character dontcare)) - (search what in :start2 start - :test #'(lambda (x y) (or (eql x dontcare) - (eql x y))))) - (search what in :start2 start))) - - -(defun strposl (table cvec sint item) - (setq cvec (string cvec)) - (if (not item) - (position table cvec :test #'(lambda (x y) (position y x)) :start sint) -(position table cvec :test-not #'(lambda (x y) (position y x)) -:start sint ))) -(defun VEC-SETELT (vec ind val) (setf (elt vec ind) val)) -(defun pname (x) - (cond ((symbolp x) (symbol-name x)) - ((characterp x) (string x)) - (t nil))) - -(defun make-bvec (n) (bvec-make-full n 0)) -(defun bvec-make-full (n x) - (make-array (list n) :element-type 'bit :initial-element x)) - -( defun bvec-setelt (bv i x) (setf (sbit bv i) x)) -(defun size (l) - (cond ((vectorp l) (length l)) - ((consp l) (list-length l)) -(t 0))) - -(defun identp (a) (and (symbolp a) a)) - -(defun shoeGREATERP (s1 s2) (string> (string s1) (string s2))) -(defun |shoeReadLisp| (s n) - (multiple-value-list (read-from-string s nil nil :start n))) -(defun |last| (x) (car (last x))) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/ptyout.boot.pamphlet b/src/boot/ptyout.boot.pamphlet deleted file mode 100644 index eb6c9e3..0000000 --- a/src/boot/ptyout.boot.pamphlet +++ /dev/null @@ -1,2076 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot ptyout.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -This file implement various Boot translators. -\end{abstract} -\eject -\tableofcontents -\eject - -\section{Entry points to this module} - -The only entry points to this module are: -\begin{itemize} -\item [[BOOTTOCL]] -\item [[BOOTCLAM]] -\item [[BOOTTOCLC]] -\item [[BOOTTOMC]] -\item [[BOOT]] -\item [[COMPILE-BOOT-FILE]] -\item [[EVAL-BOOT-FILE]] -\item [[BO]] -\item [[BOCLAM]] -\item [[STOUT]] -\item [[STEVAL]] -\item [[STTOMC]] -\end{itemize} - -Calling other functions defined here, from outside of this module, -may lead to unpredictable results. - -We assume that we are translating a file called {\bf ``foo.boot''} -and expect to generate a file called {\bf ``foo.clisp''}. - -\section{BOOTTOCLLINES} -The {\bf BOOTTOCLLINES} function cleans up the function names. -When called during system build from {\bf BOOTTOCL} the {\bf lines} -variable has the value {\bf NIL} and the {\bf fn} variable has the -value {\bf ``foo.boot''}. - -The infn variable is the input file name, {\bf ``foo.boot''}. - -The outfn variable is the output file name, {\bf ``foo.clisp''}. - -Calling {\bf shoeOpenInputFile} will create {\bf ``foo.clisp''} and -return the string ``foo.clisp PRODUCED''. - -<>= -BOOTTOCLLINES(lines, fn)== - infn:=shoeAddbootIfNec fn - outfn:=CONCAT(shoeRemovebootIfNec fn,'".clisp") - shoeOpenInputFile(a,infn, - shoeClLines(a,fn,lines,outfn)) - -@ -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package 'BOOTTRAN --- (boottocl "filename") translates the file "filename.boot" to --- the common lisp file "filename.clisp" - -BOOTTOCL fn == - a:=PACKAGE_-NAME _*PACKAGE_* - IN_-PACKAGE 'BOOTTRAN - $bfClamming:local:=false - _*READ_-DEFAULT_-FLOAT_-FORMAT_* := 'DOUBLE_-FLOAT - BOOTTOCLLINES(nil,fn) - IN_-PACKAGE a - --- (bootclam "filename") translates the file "filename.boot" to --- the common lisp file "filename.clisp" , producing, for each function --- a hash table to store previously computed values indexed by argument --- list. - -BOOTCLAM fn == BOOTCLAMLINES(nil,fn) - -BOOTCLAMLINES(lines, fn) == - $bfClamming:local:=true - BOOTTOCLLINES(lines,fn) - -<> -shoeClLines(a,fn,lines,outfn)== - if null a - then - shoeNotFound fn - nil - else - $GenVarCounter:local := 0 - shoeOpenOutputFile(stream,outfn, - (for line in lines repeat shoeFileLine (line,stream); - shoeFileTrees(shoeTransformStream a,stream))) - shoeConsole CONCAT(outfn,'" PRODUCED") - --- (boottoclc "filename") translates the file "filename.boot" to --- the common lisp file "filename.clisp" with the original boot --- code as comments - -BOOTTOCLC fn==BOOTTOCLCLINES(nil,fn) - -BOOTTOCLCLINES(lines, fn)== - $bfClamming:local:=false - infn:=shoeAddbootIfNec fn - outfn:=shoeRemovebootIfNec fn - shoeOpenInputFile(a,infn, - shoeClCLines(a,fn,lines,CONCAT(outfn,'".clisp"))) - -shoeClCLines(a,fn,lines,outfn)== - if null a - then shoeNotFound fn - else - $GenVarCounter:local := 0 - shoeOpenOutputFile(stream,outfn, - (for line in lines repeat shoeFileLine (line,stream); - shoeFileTrees(shoeTransformToFile(stream, - shoeInclude bAddLineNumber(bRgen a,bIgen 0)),stream))) - shoeConsole CONCAT(outfn,'" PRODUCED") - --- (boottomc "filename") translates the file "filename.boot" --- to machine code and loads it one item at a time - -BOOTTOMC fn== - $bfClamming:local:=false - $GenVarCounter:local := 0 - infn:=shoeAddbootIfNec fn - shoeOpenInputFile(a,infn,shoeMc(a,fn)) - -shoeMc(a,fn)== - if null a - then shoeNotFound fn - else - shoePCompileTrees shoeTransformStream a - shoeConsole CONCAT(fn,'" COMPILED AND LOADED") - --- (boot "filename") translates the file "filename.boot" to --- the common lisp file "filename.clisp", compiles it and loads --- the bbin/o file. - -COMPILE_-BOOT_-FILE fn == BOOT fn - -BOOT fn == - $bfClamming:local:=false - a:=BOOTTOCL fn - null a => nil - outfn:=CONCAT(shoeRemovebootIfNec fn,'".clisp") - shoeCOMPILE_-FILE outfn - outbin:=CONCAT(shoeRemovebootIfNec fn,'".",_*LISP_-BIN_-FILETYPE_*) - LOAD outbin - -EVAL_-BOOT_-FILE fn == - b:=PACKAGE_-NAME _*PACKAGE_* - IN_-PACKAGE 'BOOTTRAN - $bfClamming:local:=false - infn:=shoeAddbootIfNec fn - outfn:=CONCAT(shoeRemovebootIfNec fn,'".",_*LISP_-SOURCE_-FILETYPE_*) - shoeOpenInputFile(a,infn,shoeClLines(a,infn,[],outfn)) - IN_-PACKAGE b - LOAD outfn - --- (boot "filename") translates the file "filename.boot" --- and prints the result at the console - -BO fn== - b:=PACKAGE_-NAME _*PACKAGE_* - IN_-PACKAGE 'BOOTTRAN - $GenVarCounter:local := 0 - $bfClamming:local := false - infn:=shoeAddbootIfNec fn - shoeOpenInputFile(a,infn,shoeToConsole(a,fn)) - IN_-PACKAGE b - -BOCLAM fn== - $GenVarCounter:local := 0 - $bfClamming:local := true - infn:=shoeAddbootIfNec fn - shoeOpenInputFile(a,infn,shoeToConsole(a,fn)) - -shoeToConsole(a,fn)== - if null a - then shoeNotFound fn - else - shoeConsoleTrees shoeTransformToConsole - shoeInclude bAddLineNumber(bRgen a,bIgen 0) - --- (stout "string") translates the string "string" --- and prints the result at the console - -STOUT string== PSTOUT [string] --- $GenVarCounter:local := 0 --- $bfClamming:local:=false --- shoeConsoleTrees shoeTransformString [string] - -STEVAL string== - $GenVarCounter:local := 0 - $bfClamming:local:=false - a:= shoeTransformString [string] - if bStreamPackageNull a - then nil - else - fn:=stripm(CAR a,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN") - EVAL fn - --- (sttomc "string") translates the string "string" --- to common lisp, and compiles it. - -STTOMC string== - $GenVarCounter:local := 0 - $bfClamming:local:=false - a:= shoeTransformString [string] - if bStreamPackageNull a - then nil - else shoePCompile car a - - -shoeCompileTrees s== - while not bStreamNull s repeat - shoeCompile car s - s:=cdr s - -shoeCompile fn== - fn is ['DEFUN,name,bv,:body]=> - COMPILE (name,['LAMBDA,bv,:body]) - EVAL fn - -shoeNotFound fn== shoeConsole CONCAT(fn ,'" NOT FOUND") - -shoeTransform str== - bNext(function shoeTreeConstruct, - bNext(function shoePileInsert, - bNext(function shoeLineToks, str))) - -shoeTransformString s== - shoeTransform shoeInclude bAddLineNumber(s,bIgen 0) -shoeTransformStream s==shoeTransformString bRgen s --- shoeTransform shoeInclude bAddLineNumber(bRgen s,bIgen 0) - -shoeTransformToConsole str== - bNext(function shoeConsoleItem, - bNext(function shoePileInsert, - bNext(function shoeLineToks, str))) - -shoeTransformToFile(fn,str)== - bFileNext(fn, - bNext(function shoePileInsert, - bNext(function shoeLineToks, str))) - -shoeConsoleItem (str)== - dq:=CAR str - shoeConsoleLines shoeDQlines dq - cons(shoeParseTrees dq,CDR str) - -bFileNext(fn,s)==bDelay(function bFileNext1,[fn,s]) - -bFileNext1(fn,s)== - bStreamNull s=> ["nullstream"] - dq:=CAR s - shoeFileLines(shoeDQlines dq,fn) - bAppend(shoeParseTrees dq,bFileNext(fn,cdr s)) - -shoeParseTrees dq== - toklist := dqToList dq - null toklist => [] - shoeOutParse toklist - -shoeTreeConstruct (str)== - cons(shoeParseTrees CAR str,CDR str) - -shoeDQlines dq== - a:= CDAAR shoeLastTokPosn dq - b:= CDAAR shoeFirstTokPosn dq - streamTake (a-b+1,CAR shoeFirstTokPosn dq) - -streamTake(n,s)== - if bStreamNull s - then nil - else if EQL(n,0) - then nil - else cons(car s,streamTake(n-1,cdr s)) - -shoeFileLines (lines,fn) == - shoeFileLine( '" ",fn) - for line in lines repeat shoeFileLine (shoeAddComment line,fn) - shoeFileLine ('" ",fn) - -shoeConsoleLines lines == - shoeConsole '" " - for line in lines repeat shoeConsole shoeAddComment line - shoeConsole '" " - -shoeFileLine(x, stream) == - WRITE_-LINE(x, stream) - x - -shoeFileTrees(s,st)== - while not bStreamNull s repeat - a:=CAR s - if EQCAR (a,"+LINE") - then shoeFileLine(CADR a,st) - else shoePPtoFile(a,st) - s:=CDR s - - -shoePPtoFile(x, stream) == - SHOENOTPRETTYPRINT(x, stream) - x - -shoeConsoleTrees s == - while not bStreamPackageNull s repeat --- while not bStreamNull s repeat - fn:=stripm(CAR s,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN") - REALLYPRETTYPRINT fn - s:=CDR s - -shoeAddComment l== CONCAT('"; ",CAR l) - -shoeOutParse stream == - $inputStream :local:= stream - $stack:local :=nil - $stok:local := nil - $ttok:local := nil - $op:local :=nil - $wheredefs:local:=nil - $typings:local:=nil - $returns:local :=nil - $bpCount:local:=0 - $bpParenCount:local:=0 - bpFirstTok() - found:=CATCH("TRAPPOINT",bpOutItem()) - if found="TRAPPED" - then nil - else if not bStreamNull $inputStream - then - bpGeneralErrorHere() - nil - else if null $stack - then - bpGeneralErrorHere() - nil - else CAR $stack - -bpOutItem()== - bpComma() or bpTrap() - b:=bpPop1() - EQCAR(b,"TUPLE")=> bpPush cdr b - EQCAR(b,"+LINE")=> bpPush [ b ] - b is ["L%T",l,r] and IDENTP l => - bpPush [shoeEVALANDFILEACTQ ["SETQ",l,r]] - b:=shoeCompTran ["LAMBDA",["x"],b] - bpPush [shoeEVALANDFILEACTQ CADDR b] - -shoeEVALANDFILEACTQ x== ["EVAL-WHEN", ["EVAL","LOAD"], x] - -SoftShoeError(posn,key)== - shoeConsole CONCAT('"ERROR IN LINE ",STRINGIMAGE lineNo posn) - shoeConsole lineString posn - shoeConsole CONCAT(shoeSpaces lineCharacter posn,'"|") - shoeConsole key - -shoeSpaces n == MAKE_-FULL_-CVEC(n, '".") - -bpIgnoredFromTo(pos1, pos2) == - shoeConsole CONCAT('"ignored from line ", STRINGIMAGE lineNo pos1) - shoeConsole lineString pos1 - shoeConsole CONCAT(shoeSpaces lineCharacter pos1,'"|") - shoeConsole CONCAT('"ignored through line ", STRINGIMAGE lineNo pos2) - shoeConsole lineString pos2 - shoeConsole CONCAT(shoeSpaces lineCharacter pos2,'"|") - -lineNo p==CDAAR p -lineString p==CAAAR p -lineCharacter p==CDR p - -bStreamNull x== - null x or EQCAR (x,"nullstream") => true - while EQCAR(x,"nonnullstream") repeat - st:=APPLY(CADR x,CDDR x) - RPLACA(x,CAR st) - RPLACD(x,CDR st) - EQCAR(x,"nullstream") - -bDelay(f,x)==cons("nonnullstream",[f,:x]) - -bAppend(x,y)==bDelay(function bAppend1,[x,y]) - -bAppend1(:z)== - if bStreamNull car z - then if bStreamNull CADR z - then ["nullstream"] - else CADR z - else cons(CAAR z,bAppend(CDAR z,CADR z)) - -bMap(f,x)==bDelay(function bMap1, [f,x]) - -bMap1(:z)== - [f,x]:=z - if bStreamNull x - then bStreamNil - else cons(FUNCALL(f,car x),bMap(f,cdr x)) - -bNext(f,s)==bDelay(function bNext1,[f,s]) - -bNext1(f,s)== - bStreamNull s=> ["nullstream"] - h:= APPLY(f, [s]) - bAppend(car h,bNext(f,cdr h)) - -bRgen s==bDelay(function bRgen1,[s]) - -bRgen1(:s) == - a:=shoeread_-line car s - if shoePLACEP a - then --- shoeCLOSE car s - ["nullstream"] - else cons(a,bRgen car s) - -bIgen n==bDelay(function bIgen1,[n]) - -bIgen1(:n)== - n:=car n+1 - cons(n,bIgen n) - -bAddLineNumber(f1,f2)==bDelay(function bAddLineNumber1,[f1,f2]) - -bAddLineNumber1(:f)== - [f1,f2] := f - bStreamNull f1 => ["nullstream"] - bStreamNull f2 => ["nullstream"] - cons(cons(CAR f1,CAR f2),bAddLineNumber(CDR f1,CDR f2)) - ---shoeStartsAt (sz,name,stream)== --- bStreamNull stream => ['nullstream] --- a:=CAAR stream --- if #asz and not shoeIdChar(a.sz)) --- then stream --- else shoeStartsAt(sz,name,CDR stream) - ---FC(name,fn)== --- $bfClamming:local:=false --- $GenVarCounter:local := 0 --- infn:=shoeAddbootIfNec fn --- shoeOpenInputFile(a,infn,shoeFindName(fn,name, a)) - ---shoeFindName(fn,name,a)== --- shoeFindAndDoSomething(FUNCTION shoeCompile,fn,name,a) ---shoeTransform1 str== --- bNext(function shoeTreeConstruct, --- streamTake(1, bNext(function shoePileInsert, --- bNext(function shoeLineToks, str)))) - ---BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE(fun,fn,symbol)== --- $bfClamming:local:=false --- infn:=shoeAddbootIfNec NAMESTRING fn --- name:=PNAME symbol --- shoeOpenInputFile(a,infn,shoeFindAndDoSomething(fun,fn,name, a)) - ---shoeFindAndDoSomething(fun,fn,name,a)== --- if null a --- then shoeNotFound fn --- else --- b:=shoeStartsAt(#name,name, shoeInclude --- bAddLineNumber(bRgen a,bIgen 0)) --- if bStreamNull b --- then shoeConsole CONCAT (name,'" not found in ",fn) --- else --- $GenVarCounter:local := 0 --- shoeLoop(fun,shoeTransform1 b) - ---BOOT_-COMPILE_-DEFINITION_-FROM_-FILE(fn,symbol)== --- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE --- (FUNCTION shoeCompile,fn,symbol) - ---BOOT_-EVAL_-DEFINITION_-FROM_-FILE(fn,symbol)== --- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE --- (FUNCTION EVAL,fn,symbol) - ---BOOT_-PRINT_-DEFINITION_-FROM_-FILE(fn,symbol)== --- BOOT_-DO_-SOMETHING_-TO_-DEFINITION_-FROM_-FILE --- (FUNCTION REALLYPRETTYPRINT,fn,symbol) - ---shoeLoop(fun, s)== --- while not bStreamNull s repeat --- FUNCALL(fun, car s) --- s:=cdr s - -shoeAddbootIfNec s==shoeAddStringIfNec('".boot",s) - -shoeRemovebootIfNec s==shoeRemoveStringIfNec('".boot",s) -shoeAddStringIfNec(str,s)== - a:=STRPOS(str,s,0,nil) - if null a - then CONCAT(s,str) - else s - -shoeRemoveStringIfNec(str,s)== - a:=STRPOS(str,s,0,nil) - if null a - then s - else SUBSTRING(s,0,a) - --- DEFUSE prints the definitions not used and the words used and --- not defined in the input file and common lisp. - -DEFUSE fn== - infn:=CONCAT(fn,'".boot") - shoeOpenInputFile(a,infn,shoeDfu(a,fn)) - -shoeDfu(a,fn)== - if null a - then shoeNotFound fn - else - $lispWordTable:local :=MAKE_-HASHTABLE ("EQ") - DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),HPUT($lispWordTable,i,true)) - $bootDefined:local :=MAKE_-HASHTABLE "EQ" - $bootUsed:local :=MAKE_-HASHTABLE "EQ" - $bootDefinedTwice:local:=nil - $GenVarCounter:local :=0 - $bfClamming:local:=false - shoeDefUse shoeTransformStream a - out:=CONCAT(fn,'".defuse") - shoeOpenOutputFile(stream,out,shoeReport stream) - shoeConsole CONCAT(out,'" PRODUCED") - -shoeReport stream== - shoeFileLine('"DEFINED and not USED",stream) - a:=[i for i in HKEYS $bootDefined | not GETHASH(i,$bootUsed)] - bootOut(SSORT a,stream) - shoeFileLine('" ",stream) - shoeFileLine('"DEFINED TWICE",stream) - bootOut(SSORT $bootDefinedTwice,stream) - shoeFileLine('" ",stream) - shoeFileLine('"USED and not DEFINED",stream) - a:=[i for i in HKEYS $bootUsed | - not GETHASH(i,$bootDefined)] - for i in SSORT a repeat - b:=CONCAT(PNAME i,'" is used in ") - bootOutLines( SSORT GETHASH(i,$bootUsed),stream,b) - -shoeDefUse(s)== - while not bStreamPackageNull s repeat - defuse([],CAR s) - s:=CDR s - -defuse(e,x)== - x:=stripm(x,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN") - $used:local:=nil - [nee,niens]:= - x is ['DEFUN,name,bv,:body] => [name,['LAMBDA,bv,:body]] - x is ['DEFMACRO,name,bv,:body] => [name,['LAMBDA,bv,:body]] - x is ["EVAL_-WHEN",.,["SETQ",id,exp]]=>[id,exp] - x is ["SETQ",id,exp]=>[id,exp] - ["TOP-LEVEL", x] - if GETHASH(nee,$bootDefined) - then - $bootDefinedTwice:= - nee="TOP-LEVEL"=> $bootDefinedTwice - cons(nee,$bootDefinedTwice) - else HPUT($bootDefined,nee,true) - defuse1 (e,niens) - for i in $used repeat - HPUT($bootUsed,i,cons(nee,GETHASH(i,$bootUsed))) - -defuse1(e,y)== - ATOM y => - IDENTP y => - $used:= - MEMQ(y,e)=>$used - MEMQ(y,$used)=>$used - defusebuiltin y =>$used - UNION([y],$used) - [] - y is ["LAMBDA",a,:b]=> defuse1 (append(unfluidlist a,e),b) - y is ["PROG",a,:b]=> - [dol,ndol]:=defSeparate a - for i in dol repeat - HPUT($bootDefined,i,true) - defuse1 (append(ndol,e),b) - y is ["QUOTE",:a] => [] - y is ["+LINE",:a] => [] - for i in y repeat defuse1(e,i) - -defSeparate x== - if null x - then [[],[]] - else - f:=car x - [x1,x2]:=defSeparate cdr x - if bfBeginsDollar f - then [cons(f,x1),x2] - else [x1,cons(f,x2)] -unfluidlist x== - NULL x => [] - ATOM x=> [x] - x is ["&REST",y]=> [y] - cons(car x,unfluidlist cdr x) - -defusebuiltin x== GETHASH(x,$lispWordTable) - -bootOut (l,outfn)== - for i in l repeat shoeFileLine (CONCAT ('" ",PNAME i),outfn) - -CLESSP(s1,s2)==not(SHOEGREATERP(s1,s2)) -SSORT l == SORT(l,function CLESSP) - -bootOutLines(l,outfn,s)== - if null l - then shoeFileLine(s,outfn) - else - a:=PNAME car l - if #s +#a > 70 - then - shoeFileLine(s,outfn) - bootOutLines(l,outfn,'" ") - else bootOutLines(cdr l,outfn,CONCAT(s,'" ",a)) - - --- (xref "fn") produces a cross reference listing in "fn.xref" --- It contains each name --- used in "fn.boot", together with a list of functions that use it. - -XREF fn== - infn:=CONCAT(fn,'".boot") - shoeOpenInputFile(a,infn,shoeXref(a,fn)) - -shoeXref(a,fn)== - if null a - then shoeNotFound fn - else - $lispWordTable:local :=MAKE_-HASHTABLE ("EQ") - DO_-SYMBOLS(i(FIND_-PACKAGE "LISP"),HPUT($lispWordTable,i,true)) - $bootDefined:local :=MAKE_-HASHTABLE "EQ" - $bootUsed:local :=MAKE_-HASHTABLE "EQ" - $GenVarCounter:local :=0 - $bfClamming:local:=false - shoeDefUse shoeTransformStream a - out:=CONCAT(fn,'".xref") - shoeOpenOutputFile(stream,out,shoeXReport stream) - shoeConsole CONCAT(out,'" PRODUCED") - - -shoeXReport stream== - shoeFileLine('"USED and where DEFINED",stream) - c:=SSORT HKEYS $bootUsed - for i in c repeat - a:=CONCAT(PNAME i,'" is used in ") - bootOutLines( SSORT GETHASH(i,$bootUsed),stream,a) - ---FC (name,fn)== shoeGeneralFC(function BOOT,name,fn) - -FBO (name,fn)== shoeGeneralFC(function BO,name,fn) - -FEV(name,fn)== shoeGeneralFC(function EVAL_-BOOT_-FILE,name,fn) - -shoeGeneralFC(f,name,fn)== - $bfClamming:local:=false - $GenVarCounter:local := 0 - infn:=shoeAddbootIfNec fn - a:= shoeOpenInputFile(a,infn,shoeFindName2(fn,name, a)) - filename:= if # name > 8 then SUBSTRING(name,0,8) else name - a => FUNCALL(f, CONCAT('"/tmp/",filename)) - nil - -shoeFindName2(fn,name,a)== - lines:=shoeFindLines(fn,name,a) - lines => - filename:= if # name > 8 then SUBSTRING(name,0,8) else name - filename := CONCAT ('"/tmp/",filename,'".boot") - shoeOpenOutputFile(stream, filename, - for line in lines repeat shoeFileLine (line,stream)) - true - false - -shoeTransform2 str== - bNext(function shoeItem, - streamTake(1, bNext(function shoePileInsert, - bNext(function shoeLineToks, str)))) - -shoeItem (str)== - dq:=CAR str - cons([[CAR line for line in shoeDQlines dq]],CDR str) - ---shoeLines lines == [CAR line for line in lines] - ---shoeFindAndDoSomething2(fun,fn,name,a)== --- if null a --- then shoeNotFound fn --- else --- [lines,b]:=shoePackageStartsAt([],#name,name, shoeInclude --- bAddLineNumber(bRgen a,bIgen 0)) --- if bStreamNull b --- then --- shoeConsole CONCAT (name,'" not found in ",fn) --- [] --- else --- if null lines --- then shoeConsole '")package not found" --- $GenVarCounter:local := 0 --- shoeLoopPackage(fun,shoeTransform2 b,lines) - -shoeFindLines(fn,name,a)== - if null a - then - shoeNotFound fn - [] - else - [lines,b]:=shoePackageStartsAt([],#name,name, shoeInclude - bAddLineNumber(bRgen a,bIgen 0)) - b:=shoeTransform2 b - if bStreamNull b - then - shoeConsole CONCAT (name,'" not found in ",fn) - [] - else - if null lines - then shoeConsole '")package not found" - append(reverse lines,car b) - -shoePackageStartsAt (lines,sz,name,stream)== - bStreamNull stream => [[],['nullstream]] - a:=CAAR stream - if #a >= 8 and SUBSTRING(a,0,8)='")package" - then shoePackageStartsAt(cons(CAAR stream,lines),sz,name,CDR stream) - else - if #asz and not shoeIdChar(a.sz)) - then [lines,stream] - else shoePackageStartsAt(lines,sz,name,CDR stream) - ---shoeLoopPackage(fun, s,lines)== --- while not bStreamNull s repeat --- FUNCALL(fun, append (reverse lines,car s)) --- s:=cdr s --- true -stripm (x,pk,bt)== - ATOM x => - IDENTP x => - SYMBOL_-PACKAGE x = bt => INTERN(PNAME x,pk) - x - x - CONS(stripm(CAR x,pk,bt),stripm(CDR x,pk,bt)) - -shoePCompile fn== - fn:=stripm(fn,_*PACKAGE_*,FIND_-PACKAGE '"BOOTTRAN") - fn is ['DEFUN,name,bv,:body]=> - COMPILE (name,['LAMBDA,bv,:body]) - EVAL fn - -FC(name,fn)== - $bfClamming:local:=false - $GenVarCounter:local := 0 - infn:=shoeAddbootIfNec fn - shoeOpenInputFile(a,infn,shoeFindName(fn,name, a)) - -shoeFindName(fn,name,a)== - lines:=shoeFindLines(fn,name,a) - shoePCompileTrees shoeTransformString lines - -shoePCompileTrees s== - while not bStreamPackageNull s repeat - REALLYPRETTYPRINT shoePCompile car s - s:=cdr s - -bStreamPackageNull s== - a:=PACKAGE_-NAME _*PACKAGE_* - IN_-PACKAGE 'BOOTTRAN - b:=bStreamNull s - IN_-PACKAGE a - b - -PSTTOMC string== - $GenVarCounter:local := 0 - $bfClamming:local:=false - shoePCompileTrees shoeTransformString string - -BOOTLOOP ()== - a:=READ_-LINE() - #a=0=> - WRITE_-LINE '"Boot Loop; to exit type ] " - BOOTLOOP() - b:=shoePrefix? ('")console",a) - b => - stream:= _*TERMINAL_-IO_* - PSTTOMC bRgen stream - BOOTLOOP() - a.0='"]".0 => nil - PSTTOMC [a] - BOOTLOOP() - -BOOTPO ()== - a:=READ_-LINE() - #a=0=> - WRITE_-LINE '"Boot Loop; to exit type ] " - BOOTPO() - b:=shoePrefix? ('")console",a) - b => - stream:= _*TERMINAL_-IO_* - PSTOUT bRgen stream - BOOTPO() - a.0='"]".0 => nil - PSTOUT [a] - BOOTPO() - -PSTOUT string== - $GenVarCounter:local := 0 - $bfClamming:local:=false - shoeConsoleTrees shoeTransformString string - -@ -<>= - -(IN-PACKAGE 'BOOTTRAN) - -(DEFUN BOOTTOCL (|fn|) - (PROG (|$bfClamming| |a|) - (DECLARE (SPECIAL |$bfClamming|)) - (RETURN - (PROGN - (SETQ |a| (PACKAGE-NAME *PACKAGE*)) - (IN-PACKAGE 'BOOTTRAN) - (SETQ |$bfClamming| NIL) - (BOOTTOCLLINES NIL |fn|) - (IN-PACKAGE |a|))))) - -(DEFUN BOOTCLAM (|fn|) (PROG () (RETURN (BOOTCLAMLINES NIL |fn|)))) - -(DEFUN BOOTCLAMLINES (|lines| |fn|) - (PROG (|$bfClamming|) - (DECLARE (SPECIAL |$bfClamming|)) - (RETURN - (PROGN (SETQ |$bfClamming| T) (BOOTTOCLLINES |lines| |fn|))))) - -(DEFUN BOOTTOCLLINES (|lines| |fn|) - (PROG (|outfn| |infn|) - (RETURN - (PROGN - (SETQ |infn| (|shoeAddbootIfNec| |fn|)) - (SETQ |outfn| (CONCAT (|shoeRemovebootIfNec| |fn|) ".clisp")) - (|shoeOpenInputFile| |a| |infn| - (|shoeClLines| |a| |fn| |lines| |outfn|)))))) - -(DEFUN |shoeClLines| (|a| |fn| |lines| |outfn|) - (PROG (|$GenVarCounter|) - (DECLARE (SPECIAL |$GenVarCounter|)) - (RETURN - (COND - ((NULL |a|) (|shoeNotFound| |fn|) NIL) - ('T (SETQ |$GenVarCounter| 0) - (|shoeOpenOutputFile| |stream| |outfn| - (PROGN - ((LAMBDA (|bfVar#1| |line|) - (LOOP - (COND - ((OR (ATOM |bfVar#1|) - (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - ('T (|shoeFileLine| |line| |stream|))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - |lines| NIL) - (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|))) - (|shoeConsole| (CONCAT |outfn| " PRODUCED"))))))) - -(DEFUN BOOTTOCLC (|fn|) (PROG () (RETURN (BOOTTOCLCLINES NIL |fn|)))) - -(DEFUN BOOTTOCLCLINES (|lines| |fn|) - (PROG (|$bfClamming| |outfn| |infn|) - (DECLARE (SPECIAL |$bfClamming|)) - (RETURN - (PROGN - (SETQ |$bfClamming| NIL) - (SETQ |infn| (|shoeAddbootIfNec| |fn|)) - (SETQ |outfn| (|shoeRemovebootIfNec| |fn|)) - (|shoeOpenInputFile| |a| |infn| - (|shoeClCLines| |a| |fn| |lines| (CONCAT |outfn| ".clisp"))))))) - -(DEFUN |shoeClCLines| (|a| |fn| |lines| |outfn|) - (PROG (|$GenVarCounter|) - (DECLARE (SPECIAL |$GenVarCounter|)) - (RETURN - (COND - ((NULL |a|) (|shoeNotFound| |fn|)) - ('T (SETQ |$GenVarCounter| 0) - (|shoeOpenOutputFile| |stream| |outfn| - (PROGN - ((LAMBDA (|bfVar#2| |line|) - (LOOP - (COND - ((OR (ATOM |bfVar#2|) - (PROGN (SETQ |line| (CAR |bfVar#2|)) NIL)) - (RETURN NIL)) - ('T (|shoeFileLine| |line| |stream|))) - (SETQ |bfVar#2| (CDR |bfVar#2|)))) - |lines| NIL) - (|shoeFileTrees| - (|shoeTransformToFile| |stream| - (|shoeInclude| - (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))) - |stream|))) - (|shoeConsole| (CONCAT |outfn| " PRODUCED"))))))) - -(DEFUN BOOTTOMC (|fn|) - (PROG (|$GenVarCounter| |$bfClamming| |infn|) - (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter|)) - (RETURN - (PROGN - (SETQ |$bfClamming| NIL) - (SETQ |$GenVarCounter| 0) - (SETQ |infn| (|shoeAddbootIfNec| |fn|)) - (|shoeOpenInputFile| |a| |infn| (|shoeMc| |a| |fn|)))))) - -(DEFUN |shoeMc| (|a| |fn|) - (PROG () - (RETURN - (COND - ((NULL |a|) (|shoeNotFound| |fn|)) - ('T (|shoePCompileTrees| (|shoeTransformStream| |a|)) - (|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED"))))))) - -(DEFUN COMPILE-BOOT-FILE (|fn|) (PROG () (RETURN (BOOT |fn|)))) - -(DEFUN BOOT (|fn|) - (PROG (|$bfClamming| |outbin| |outfn| |a|) - (DECLARE (SPECIAL |$bfClamming|)) - (RETURN - (PROGN - (SETQ |$bfClamming| NIL) - (SETQ |a| (BOOTTOCL |fn|)) - (COND - ((NULL |a|) NIL) - ('T - (PROGN - (SETQ |outfn| - (CONCAT (|shoeRemovebootIfNec| |fn|) ".clisp")) - (|shoeCOMPILE-FILE| |outfn|) - (SETQ |outbin| - (CONCAT (|shoeRemovebootIfNec| |fn|) "." - *LISP-BIN-FILETYPE*)) - (LOAD |outbin|)))))))) - -(DEFUN EVAL-BOOT-FILE (|fn|) - (PROG (|$bfClamming| |outfn| |infn| |b|) - (DECLARE (SPECIAL |$bfClamming|)) - (RETURN - (PROGN - (SETQ |b| (PACKAGE-NAME *PACKAGE*)) - (IN-PACKAGE 'BOOTTRAN) - (SETQ |$bfClamming| NIL) - (SETQ |infn| (|shoeAddbootIfNec| |fn|)) - (SETQ |outfn| - (CONCAT (|shoeRemovebootIfNec| |fn|) "." - *LISP-SOURCE-FILETYPE*)) - (|shoeOpenInputFile| |a| |infn| - (|shoeClLines| |a| |infn| NIL |outfn|)) - (IN-PACKAGE |b|) - (LOAD |outfn|))))) - -(DEFUN BO (|fn|) - (PROG (|$bfClamming| |$GenVarCounter| |infn| |b|) - (DECLARE (SPECIAL |$GenVarCounter| |$bfClamming|)) - (RETURN - (PROGN - (SETQ |b| (PACKAGE-NAME *PACKAGE*)) - (IN-PACKAGE 'BOOTTRAN) - (SETQ |$GenVarCounter| 0) - (SETQ |$bfClamming| NIL) - (SETQ |infn| (|shoeAddbootIfNec| |fn|)) - (|shoeOpenInputFile| |a| |infn| (|shoeToConsole| |a| |fn|)) - (IN-PACKAGE |b|))))) - -(DEFUN BOCLAM (|fn|) - (PROG (|$bfClamming| |$GenVarCounter| |infn|) - (DECLARE (SPECIAL |$GenVarCounter| |$bfClamming|)) - (RETURN - (PROGN - (SETQ |$GenVarCounter| 0) - (SETQ |$bfClamming| T) - (SETQ |infn| (|shoeAddbootIfNec| |fn|)) - (|shoeOpenInputFile| |a| |infn| (|shoeToConsole| |a| |fn|)))))) - -(DEFUN |shoeToConsole| (|a| |fn|) - (PROG () - (RETURN - (COND - ((NULL |a|) (|shoeNotFound| |fn|)) - ('T - (|shoeConsoleTrees| - (|shoeTransformToConsole| - (|shoeInclude| - (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))))))))) - -(DEFUN STOUT (|string|) (PROG () (RETURN (PSTOUT (LIST |string|))))) - -(DEFUN STEVAL (|string|) - (PROG (|$bfClamming| |$GenVarCounter| |fn| |a|) - (DECLARE (SPECIAL |$GenVarCounter| |$bfClamming|)) - (RETURN - (PROGN - (SETQ |$GenVarCounter| 0) - (SETQ |$bfClamming| NIL) - (SETQ |a| (|shoeTransformString| (LIST |string|))) - (COND - ((|bStreamPackageNull| |a|) NIL) - ('T - (SETQ |fn| - (|stripm| (CAR |a|) *PACKAGE* - (FIND-PACKAGE "BOOTTRAN"))) - (EVAL |fn|))))))) - -(DEFUN STTOMC (|string|) - (PROG (|$bfClamming| |$GenVarCounter| |a|) - (DECLARE (SPECIAL |$GenVarCounter| |$bfClamming|)) - (RETURN - (PROGN - (SETQ |$GenVarCounter| 0) - (SETQ |$bfClamming| NIL) - (SETQ |a| (|shoeTransformString| (LIST |string|))) - (COND - ((|bStreamPackageNull| |a|) NIL) - ('T (|shoePCompile| (CAR |a|)))))))) - -(DEFUN |shoeCompileTrees| (|s|) - (PROG () - (RETURN - ((LAMBDA () - (LOOP - (COND - ((|bStreamNull| |s|) (RETURN NIL)) - ('T - (PROGN (|shoeCompile| (CAR |s|)) (SETQ |s| (CDR |s|))))))))))) - -(DEFUN |shoeCompile| (|fn|) - (PROG (|body| |bv| |ISTMP#2| |name| |ISTMP#1|) - (RETURN - (COND - ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN) - (PROGN - (SETQ |ISTMP#1| (CDR |fn|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |name| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |bv| (CAR |ISTMP#2|)) - (SETQ |body| (CDR |ISTMP#2|)) - 'T)))))) - (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|)))) - ('T (EVAL |fn|)))))) - -(DEFUN |shoeNotFound| (|fn|) - (PROG () (RETURN (|shoeConsole| (CONCAT |fn| " NOT FOUND"))))) - -(DEFUN |shoeTransform| (|str|) - (PROG () - (RETURN - (|bNext| #'|shoeTreeConstruct| - (|bNext| #'|shoePileInsert| - (|bNext| #'|shoeLineToks| |str|)))))) - -(DEFUN |shoeTransformString| (|s|) - (PROG () - (RETURN - (|shoeTransform| - (|shoeInclude| (|bAddLineNumber| |s| (|bIgen| 0))))))) - -(DEFUN |shoeTransformStream| (|s|) - (PROG () (RETURN (|shoeTransformString| (|bRgen| |s|))))) - -(DEFUN |shoeTransformToConsole| (|str|) - (PROG () - (RETURN - (|bNext| #'|shoeConsoleItem| - (|bNext| #'|shoePileInsert| - (|bNext| #'|shoeLineToks| |str|)))))) - -(DEFUN |shoeTransformToFile| (|fn| |str|) - (PROG () - (RETURN - (|bFileNext| |fn| - (|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|)))))) - -(DEFUN |shoeConsoleItem| (|str|) - (PROG (|dq|) - (RETURN - (PROGN - (SETQ |dq| (CAR |str|)) - (|shoeConsoleLines| (|shoeDQlines| |dq|)) - (CONS (|shoeParseTrees| |dq|) (CDR |str|)))))) - -(DEFUN |bFileNext| (|fn| |s|) - (PROG () (RETURN (|bDelay| #'|bFileNext1| (LIST |fn| |s|))))) - -(DEFUN |bFileNext1| (|fn| |s|) - (PROG (|dq|) - (RETURN - (COND - ((|bStreamNull| |s|) (LIST '|nullstream|)) - ('T - (PROGN - (SETQ |dq| (CAR |s|)) - (|shoeFileLines| (|shoeDQlines| |dq|) |fn|) - (|bAppend| (|shoeParseTrees| |dq|) - (|bFileNext| |fn| (CDR |s|))))))))) - -(DEFUN |shoeParseTrees| (|dq|) - (PROG (|toklist|) - (RETURN - (PROGN - (SETQ |toklist| (|dqToList| |dq|)) - (COND ((NULL |toklist|) NIL) ('T (|shoeOutParse| |toklist|))))))) - -(DEFUN |shoeTreeConstruct| (|str|) - (PROG () (RETURN (CONS (|shoeParseTrees| (CAR |str|)) (CDR |str|))))) - -(DEFUN |shoeDQlines| (|dq|) - (PROG (|b| |a|) - (RETURN - (PROGN - (SETQ |a| (CDAAR (|shoeLastTokPosn| |dq|))) - (SETQ |b| (CDAAR (|shoeFirstTokPosn| |dq|))) - (|streamTake| (+ (- |a| |b|) 1) - (CAR (|shoeFirstTokPosn| |dq|))))))) - -(DEFUN |streamTake| (|n| |s|) - (PROG () - (RETURN - (COND - ((|bStreamNull| |s|) NIL) - ((EQL |n| 0) NIL) - ('T (CONS (CAR |s|) (|streamTake| (- |n| 1) (CDR |s|)))))))) - -(DEFUN |shoeFileLines| (|lines| |fn|) - (PROG () - (RETURN - (PROGN - (|shoeFileLine| " " |fn|) - ((LAMBDA (|bfVar#3| |line|) - (LOOP - (COND - ((OR (ATOM |bfVar#3|) - (PROGN (SETQ |line| (CAR |bfVar#3|)) NIL)) - (RETURN NIL)) - ('T (|shoeFileLine| (|shoeAddComment| |line|) |fn|))) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - |lines| NIL) - (|shoeFileLine| " " |fn|))))) - -(DEFUN |shoeConsoleLines| (|lines|) - (PROG () - (RETURN - (PROGN - (|shoeConsole| " ") - ((LAMBDA (|bfVar#4| |line|) - (LOOP - (COND - ((OR (ATOM |bfVar#4|) - (PROGN (SETQ |line| (CAR |bfVar#4|)) NIL)) - (RETURN NIL)) - ('T (|shoeConsole| (|shoeAddComment| |line|)))) - (SETQ |bfVar#4| (CDR |bfVar#4|)))) - |lines| NIL) - (|shoeConsole| " "))))) - -(DEFUN |shoeFileLine| (|x| |stream|) - (PROG () (RETURN (PROGN (WRITE-LINE |x| |stream|) |x|)))) - -(DEFUN |shoeFileTrees| (|s| |st|) - (PROG (|a|) - (RETURN - ((LAMBDA () - (LOOP - (COND - ((|bStreamNull| |s|) (RETURN NIL)) - ('T - (PROGN - (SETQ |a| (CAR |s|)) - (COND - ((EQCAR |a| '+LINE) (|shoeFileLine| (CADR |a|) |st|)) - ('T (|shoePPtoFile| |a| |st|))) - (SETQ |s| (CDR |s|))))))))))) - -(DEFUN |shoePPtoFile| (|x| |stream|) - (PROG () (RETURN (PROGN (SHOENOTPRETTYPRINT |x| |stream|) |x|)))) - -(DEFUN |shoeConsoleTrees| (|s|) - (PROG (|fn|) - (RETURN - ((LAMBDA () - (LOOP - (COND - ((|bStreamPackageNull| |s|) (RETURN NIL)) - ('T - (PROGN - (SETQ |fn| - (|stripm| (CAR |s|) *PACKAGE* - (FIND-PACKAGE "BOOTTRAN"))) - (REALLYPRETTYPRINT |fn|) - (SETQ |s| (CDR |s|))))))))))) - -(DEFUN |shoeAddComment| (|l|) - (PROG () (RETURN (CONCAT "; " (CAR |l|))))) - -(DEFUN |shoeOutParse| (|stream|) - (PROG (|$bpParenCount| |$bpCount| |$returns| |$typings| |$wheredefs| - |$op| |$ttok| |$stok| |$stack| |$inputStream| |found|) - (DECLARE (SPECIAL |$stok| |$ttok| |$op| |$wheredefs| |$typings| - |$returns| |$bpCount| |$bpParenCount| |$stack| - |$inputStream|)) - (RETURN - (PROGN - (SETQ |$inputStream| |stream|) - (SETQ |$stack| NIL) - (SETQ |$stok| NIL) - (SETQ |$ttok| NIL) - (SETQ |$op| NIL) - (SETQ |$wheredefs| NIL) - (SETQ |$typings| NIL) - (SETQ |$returns| NIL) - (SETQ |$bpCount| 0) - (SETQ |$bpParenCount| 0) - (|bpFirstTok|) - (SETQ |found| (CATCH 'TRAPPOINT (|bpOutItem|))) - (COND - ((EQ |found| 'TRAPPED) NIL) - ((NULL (|bStreamNull| |$inputStream|)) (|bpGeneralErrorHere|) - NIL) - ((NULL |$stack|) (|bpGeneralErrorHere|) NIL) - ('T (CAR |$stack|))))))) - -(DEFUN |bpOutItem| () - (PROG (|r| |ISTMP#2| |l| |ISTMP#1| |b|) - (RETURN - (PROGN - (OR (|bpComma|) (|bpTrap|)) - (SETQ |b| (|bpPop1|)) - (COND - ((EQCAR |b| 'TUPLE) (|bpPush| (CDR |b|))) - ((EQCAR |b| '+LINE) (|bpPush| (LIST |b|))) - ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T) - (PROGN - (SETQ |ISTMP#1| (CDR |b|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |l| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T))))) - (IDENTP |l|)) - (|bpPush| - (LIST (|shoeEVALANDFILEACTQ| (LIST 'SETQ |l| |r|))))) - ('T - (PROGN - (SETQ |b| (|shoeCompTran| (LIST 'LAMBDA (LIST '|x|) |b|))) - (|bpPush| (LIST (|shoeEVALANDFILEACTQ| (CADDR |b|))))))))))) - -(DEFUN |shoeEVALANDFILEACTQ| (|x|) - (PROG () (RETURN (LIST 'EVAL-WHEN (LIST 'EVAL 'LOAD) |x|)))) - -(DEFUN |SoftShoeError| (|posn| |key|) - (PROG () - (RETURN - (PROGN - (|shoeConsole| - (CONCAT "ERROR IN LINE " (STRINGIMAGE (|lineNo| |posn|)))) - (|shoeConsole| (|lineString| |posn|)) - (|shoeConsole| - (CONCAT (|shoeSpaces| (|lineCharacter| |posn|)) "|")) - (|shoeConsole| |key|))))) - -(DEFUN |shoeSpaces| (|n|) (PROG () (RETURN (MAKE-FULL-CVEC |n| ".")))) - -(DEFUN |bpIgnoredFromTo| (|pos1| |pos2|) - (PROG () - (RETURN - (PROGN - (|shoeConsole| - (CONCAT "ignored from line " - (STRINGIMAGE (|lineNo| |pos1|)))) - (|shoeConsole| (|lineString| |pos1|)) - (|shoeConsole| - (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|")) - (|shoeConsole| - (CONCAT "ignored through line " - (STRINGIMAGE (|lineNo| |pos2|)))) - (|shoeConsole| (|lineString| |pos2|)) - (|shoeConsole| - (CONCAT (|shoeSpaces| (|lineCharacter| |pos2|)) "|")))))) - -(DEFUN |lineNo| (|p|) (PROG () (RETURN (CDAAR |p|)))) - -(DEFUN |lineString| (|p|) (PROG () (RETURN (CAAAR |p|)))) - -(DEFUN |lineCharacter| (|p|) (PROG () (RETURN (CDR |p|)))) - -(DEFUN |bStreamNull| (|x|) - (PROG (|st|) - (RETURN - (COND - ((OR (NULL |x|) (EQCAR |x| '|nullstream|)) T) - ('T - (PROGN - ((LAMBDA () - (LOOP - (COND - ((NOT (EQCAR |x| '|nonnullstream|)) (RETURN NIL)) - ('T - (PROGN - (SETQ |st| (APPLY (CADR |x|) (CDDR |x|))) - (RPLACA |x| (CAR |st|)) - (RPLACD |x| (CDR |st|)))))))) - (EQCAR |x| '|nullstream|))))))) - -(DEFUN |bDelay| (|f| |x|) - (PROG () (RETURN (CONS '|nonnullstream| (CONS |f| |x|))))) - -(DEFUN |bAppend| (|x| |y|) - (PROG () (RETURN (|bDelay| #'|bAppend1| (LIST |x| |y|))))) - -(DEFUN |bAppend1| (&REST |z|) - (PROG () - (RETURN - (COND - ((|bStreamNull| (CAR |z|)) - (COND - ((|bStreamNull| (CADR |z|)) (LIST '|nullstream|)) - ('T (CADR |z|)))) - ('T (CONS (CAAR |z|) (|bAppend| (CDAR |z|) (CADR |z|)))))))) - -(DEFUN |bMap| (|f| |x|) - (PROG () (RETURN (|bDelay| #'|bMap1| (LIST |f| |x|))))) - -(DEFUN |bMap1| (&REST |z|) - (PROG (|x| |f|) - (RETURN - (PROGN - (SETQ |f| (CAR |z|)) - (SETQ |x| (CADR |z|)) - (COND - ((|bStreamNull| |x|) |bStreamNil|) - ('T (CONS (FUNCALL |f| (CAR |x|)) (|bMap| |f| (CDR |x|))))))))) - -(DEFUN |bNext| (|f| |s|) - (PROG () (RETURN (|bDelay| #'|bNext1| (LIST |f| |s|))))) - -(DEFUN |bNext1| (|f| |s|) - (PROG (|h|) - (RETURN - (COND - ((|bStreamNull| |s|) (LIST '|nullstream|)) - ('T - (PROGN - (SETQ |h| (APPLY |f| (LIST |s|))) - (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|))))))))) - -(DEFUN |bRgen| (|s|) - (PROG () (RETURN (|bDelay| #'|bRgen1| (LIST |s|))))) - -(DEFUN |bRgen1| (&REST |s|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|shoeread-line| (CAR |s|))) - (COND - ((|shoePLACEP| |a|) (LIST '|nullstream|)) - ('T (CONS |a| (|bRgen| (CAR |s|))))))))) - -(DEFUN |bIgen| (|n|) - (PROG () (RETURN (|bDelay| #'|bIgen1| (LIST |n|))))) - -(DEFUN |bIgen1| (&REST |n|) - (PROG () - (RETURN - (PROGN (SETQ |n| (+ (CAR |n|) 1)) (CONS |n| (|bIgen| |n|)))))) - -(DEFUN |bAddLineNumber| (|f1| |f2|) - (PROG () (RETURN (|bDelay| #'|bAddLineNumber1| (LIST |f1| |f2|))))) - -(DEFUN |bAddLineNumber1| (&REST |f|) - (PROG (|f2| |f1|) - (RETURN - (PROGN - (SETQ |f1| (CAR |f|)) - (SETQ |f2| (CADR |f|)) - (COND - ((|bStreamNull| |f1|) (LIST '|nullstream|)) - ((|bStreamNull| |f2|) (LIST '|nullstream|)) - ('T - (CONS (CONS (CAR |f1|) (CAR |f2|)) - (|bAddLineNumber| (CDR |f1|) (CDR |f2|))))))))) - -(DEFUN |shoeAddbootIfNec| (|s|) - (PROG () (RETURN (|shoeAddStringIfNec| ".boot" |s|)))) - -(DEFUN |shoeRemovebootIfNec| (|s|) - (PROG () (RETURN (|shoeRemoveStringIfNec| ".boot" |s|)))) - -(DEFUN |shoeAddStringIfNec| (|str| |s|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (STRPOS |str| |s| 0 NIL)) - (COND ((NULL |a|) (CONCAT |s| |str|)) ('T |s|)))))) - -(DEFUN |shoeRemoveStringIfNec| (|str| |s|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (STRPOS |str| |s| 0 NIL)) - (COND ((NULL |a|) |s|) ('T (SUBSTRING |s| 0 |a|))))))) - -(DEFUN DEFUSE (|fn|) - (PROG (|infn|) - (RETURN - (PROGN - (SETQ |infn| (CONCAT |fn| ".boot")) - (|shoeOpenInputFile| |a| |infn| (|shoeDfu| |a| |fn|)))))) - -(DEFUN |shoeDfu| (|a| |fn|) - (PROG (|$bfClamming| |$GenVarCounter| |$bootDefinedTwice| |$bootUsed| - |$bootDefined| |$lispWordTable| |out|) - (DECLARE (SPECIAL |$bootDefined| |$bootUsed| |$bootDefinedTwice| - |$GenVarCounter| |$bfClamming| |$lispWordTable|)) - (RETURN - (COND - ((NULL |a|) (|shoeNotFound| |fn|)) - ('T (SETQ |$lispWordTable| (MAKE-HASHTABLE 'EQ)) - (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP)) - (HPUT |$lispWordTable| |i| T)) - (SETQ |$bootDefined| (MAKE-HASHTABLE 'EQ)) - (SETQ |$bootUsed| (MAKE-HASHTABLE 'EQ)) - (SETQ |$bootDefinedTwice| NIL) (SETQ |$GenVarCounter| 0) - (SETQ |$bfClamming| NIL) - (|shoeDefUse| (|shoeTransformStream| |a|)) - (SETQ |out| (CONCAT |fn| ".defuse")) - (|shoeOpenOutputFile| |stream| |out| (|shoeReport| |stream|)) - (|shoeConsole| (CONCAT |out| " PRODUCED"))))))) - -(DEFUN |shoeReport| (|stream|) - (PROG (|b| |a|) - (DECLARE (SPECIAL |$bootDefinedTwice| |$bootDefined| |$bootUsed|)) - (RETURN - (PROGN - (|shoeFileLine| "DEFINED and not USED" |stream|) - (SETQ |a| - ((LAMBDA (|bfVar#6| |bfVar#5| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#5|) - (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL)) - (RETURN (NREVERSE |bfVar#6|))) - ('T - (AND (NULL (GETHASH |i| |$bootUsed|)) - (SETQ |bfVar#6| (CONS |i| |bfVar#6|))))) - (SETQ |bfVar#5| (CDR |bfVar#5|)))) - NIL (HKEYS |$bootDefined|) NIL)) - (|bootOut| (SSORT |a|) |stream|) - (|shoeFileLine| " " |stream|) - (|shoeFileLine| "DEFINED TWICE" |stream|) - (|bootOut| (SSORT |$bootDefinedTwice|) |stream|) - (|shoeFileLine| " " |stream|) - (|shoeFileLine| "USED and not DEFINED" |stream|) - (SETQ |a| - ((LAMBDA (|bfVar#8| |bfVar#7| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#7|) - (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL)) - (RETURN (NREVERSE |bfVar#8|))) - ('T - (AND (NULL (GETHASH |i| |$bootDefined|)) - (SETQ |bfVar#8| (CONS |i| |bfVar#8|))))) - (SETQ |bfVar#7| (CDR |bfVar#7|)))) - NIL (HKEYS |$bootUsed|) NIL)) - ((LAMBDA (|bfVar#9| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#9|) - (PROGN (SETQ |i| (CAR |bfVar#9|)) NIL)) - (RETURN NIL)) - ('T - (PROGN - (SETQ |b| (CONCAT (PNAME |i|) " is used in ")) - (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|)) - |stream| |b|)))) - (SETQ |bfVar#9| (CDR |bfVar#9|)))) - (SSORT |a|) NIL))))) - -(DEFUN |shoeDefUse| (|s|) - (PROG () - (RETURN - ((LAMBDA () - (LOOP - (COND - ((|bStreamPackageNull| |s|) (RETURN NIL)) - ('T (PROGN (|defuse| NIL (CAR |s|)) (SETQ |s| (CDR |s|))))))))))) - -(DEFUN |defuse| (|e| |x|) - (PROG (|$used| |niens| |nee| |LETTMP#1| |exp| |ISTMP#5| |id| - |ISTMP#4| |ISTMP#3| |body| |bv| |ISTMP#2| |name| - |ISTMP#1|) - (DECLARE (SPECIAL |$used| |$bootUsed| |$bootDefinedTwice| - |$bootDefined|)) - (RETURN - (PROGN - (SETQ |x| (|stripm| |x| *PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) - (SETQ |$used| NIL) - (SETQ |LETTMP#1| - (COND - ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFUN) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |name| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |bv| (CAR |ISTMP#2|)) - (SETQ |body| (CDR |ISTMP#2|)) - 'T)))))) - (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|)))) - ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFMACRO) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |name| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |bv| (CAR |ISTMP#2|)) - (SETQ |body| (CDR |ISTMP#2|)) - 'T)))))) - (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|)))) - ((AND (CONSP |x|) (EQ (CAR |x|) 'EVAL-WHEN) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (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|) 'SETQ) - (PROGN - (SETQ |ISTMP#4| - (CDR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (PROGN - (SETQ |id| (CAR |ISTMP#4|)) - (SETQ |ISTMP#5| - (CDR |ISTMP#4|)) - (AND (CONSP |ISTMP#5|) - (EQ (CDR |ISTMP#5|) NIL) - (PROGN - (SETQ |exp| - (CAR |ISTMP#5|)) - 'T)))))))))))) - (LIST |id| |exp|)) - ((AND (CONSP |x|) (EQ (CAR |x|) 'SETQ) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |id| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (PROGN - (SETQ |exp| (CAR |ISTMP#2|)) - 'T)))))) - (LIST |id| |exp|)) - ('T (LIST 'TOP-LEVEL |x|)))) - (SETQ |nee| (CAR |LETTMP#1|)) - (SETQ |niens| (CADR |LETTMP#1|)) - (COND - ((GETHASH |nee| |$bootDefined|) - (SETQ |$bootDefinedTwice| - (COND - ((EQ |nee| 'TOP-LEVEL) |$bootDefinedTwice|) - ('T (CONS |nee| |$bootDefinedTwice|))))) - ('T (HPUT |$bootDefined| |nee| T))) - (|defuse1| |e| |niens|) - ((LAMBDA (|bfVar#10| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#10|) - (PROGN (SETQ |i| (CAR |bfVar#10|)) NIL)) - (RETURN NIL)) - ('T - (HPUT |$bootUsed| |i| - (CONS |nee| (GETHASH |i| |$bootUsed|))))) - (SETQ |bfVar#10| (CDR |bfVar#10|)))) - |$used| NIL))))) - -(DEFUN |defuse1| (|e| |y|) - (PROG (|ndol| |dol| |LETTMP#1| |b| |a| |ISTMP#1|) - (DECLARE (SPECIAL |$bootDefined| |$used|)) - (RETURN - (COND - ((ATOM |y|) - (COND - ((IDENTP |y|) - (SETQ |$used| - (COND - ((MEMQ |y| |e|) |$used|) - ((MEMQ |y| |$used|) |$used|) - ((|defusebuiltin| |y|) |$used|) - ('T (UNION (LIST |y|) |$used|))))) - ('T NIL))) - ((AND (CONSP |y|) (EQ (CAR |y|) 'LAMBDA) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |a| (CAR |ISTMP#1|)) - (SETQ |b| (CDR |ISTMP#1|)) - 'T)))) - (|defuse1| (APPEND (|unfluidlist| |a|) |e|) |b|)) - ((AND (CONSP |y|) (EQ (CAR |y|) 'PROG) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |a| (CAR |ISTMP#1|)) - (SETQ |b| (CDR |ISTMP#1|)) - 'T)))) - (PROGN - (SETQ |LETTMP#1| (|defSeparate| |a|)) - (SETQ |dol| (CAR |LETTMP#1|)) - (SETQ |ndol| (CADR |LETTMP#1|)) - ((LAMBDA (|bfVar#11| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#11|) - (PROGN (SETQ |i| (CAR |bfVar#11|)) NIL)) - (RETURN NIL)) - ('T (HPUT |$bootDefined| |i| T))) - (SETQ |bfVar#11| (CDR |bfVar#11|)))) - |dol| NIL) - (|defuse1| (APPEND |ndol| |e|) |b|))) - ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE) - (PROGN (SETQ |a| (CDR |y|)) 'T)) - NIL) - ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE) - (PROGN (SETQ |a| (CDR |y|)) 'T)) - NIL) - ('T - ((LAMBDA (|bfVar#12| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#12|) - (PROGN (SETQ |i| (CAR |bfVar#12|)) NIL)) - (RETURN NIL)) - ('T (|defuse1| |e| |i|))) - (SETQ |bfVar#12| (CDR |bfVar#12|)))) - |y| NIL)))))) - -(DEFUN |defSeparate| (|x|) - (PROG (|x2| |x1| |LETTMP#1| |f|) - (RETURN - (COND - ((NULL |x|) (LIST NIL NIL)) - ('T (SETQ |f| (CAR |x|)) - (SETQ |LETTMP#1| (|defSeparate| (CDR |x|))) - (SETQ |x1| (CAR |LETTMP#1|)) (SETQ |x2| (CADR |LETTMP#1|)) - (COND - ((|bfBeginsDollar| |f|) (LIST (CONS |f| |x1|) |x2|)) - ('T (LIST |x1| (CONS |f| |x2|))))))))) - -(DEFUN |unfluidlist| (|x|) - (PROG (|y| |ISTMP#1|) - (RETURN - (COND - ((NULL |x|) NIL) - ((ATOM |x|) (LIST |x|)) - ((AND (CONSP |x|) (EQ (CAR |x|) '&REST) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |y| (CAR |ISTMP#1|)) 'T)))) - (LIST |y|)) - ('T (CONS (CAR |x|) (|unfluidlist| (CDR |x|)))))))) - -(DEFUN |defusebuiltin| (|x|) - (PROG () - (DECLARE (SPECIAL |$lispWordTable|)) - (RETURN (GETHASH |x| |$lispWordTable|)))) - -(DEFUN |bootOut| (|l| |outfn|) - (PROG () - (RETURN - ((LAMBDA (|bfVar#13| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#13|) - (PROGN (SETQ |i| (CAR |bfVar#13|)) NIL)) - (RETURN NIL)) - ('T (|shoeFileLine| (CONCAT " " (PNAME |i|)) |outfn|))) - (SETQ |bfVar#13| (CDR |bfVar#13|)))) - |l| NIL)))) - -(DEFUN CLESSP (|s1| |s2|) - (PROG () (RETURN (NULL (SHOEGREATERP |s1| |s2|))))) - -(DEFUN SSORT (|l|) (PROG () (RETURN (SORT |l| #'CLESSP)))) - -(DEFUN |bootOutLines| (|l| |outfn| |s|) - (PROG (|a|) - (RETURN - (COND - ((NULL |l|) (|shoeFileLine| |s| |outfn|)) - ('T (SETQ |a| (PNAME (CAR |l|))) - (COND - ((< 70 (+ (LENGTH |s|) (LENGTH |a|))) - (|shoeFileLine| |s| |outfn|) - (|bootOutLines| |l| |outfn| " ")) - ('T (|bootOutLines| (CDR |l|) |outfn| (CONCAT |s| " " |a|))))))))) - -(DEFUN XREF (|fn|) - (PROG (|infn|) - (RETURN - (PROGN - (SETQ |infn| (CONCAT |fn| ".boot")) - (|shoeOpenInputFile| |a| |infn| (|shoeXref| |a| |fn|)))))) - -(DEFUN |shoeXref| (|a| |fn|) - (PROG (|$bfClamming| |$GenVarCounter| |$bootUsed| |$bootDefined| - |$lispWordTable| |out|) - (DECLARE (SPECIAL |$bootDefined| |$bootUsed| |$GenVarCounter| - |$bfClamming| |$lispWordTable|)) - (RETURN - (COND - ((NULL |a|) (|shoeNotFound| |fn|)) - ('T (SETQ |$lispWordTable| (MAKE-HASHTABLE 'EQ)) - (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP)) - (HPUT |$lispWordTable| |i| T)) - (SETQ |$bootDefined| (MAKE-HASHTABLE 'EQ)) - (SETQ |$bootUsed| (MAKE-HASHTABLE 'EQ)) - (SETQ |$GenVarCounter| 0) (SETQ |$bfClamming| NIL) - (|shoeDefUse| (|shoeTransformStream| |a|)) - (SETQ |out| (CONCAT |fn| ".xref")) - (|shoeOpenOutputFile| |stream| |out| (|shoeXReport| |stream|)) - (|shoeConsole| (CONCAT |out| " PRODUCED"))))))) - -(DEFUN |shoeXReport| (|stream|) - (PROG (|a| |c|) - (DECLARE (SPECIAL |$bootUsed|)) - (RETURN - (PROGN - (|shoeFileLine| "USED and where DEFINED" |stream|) - (SETQ |c| (SSORT (HKEYS |$bootUsed|))) - ((LAMBDA (|bfVar#14| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#14|) - (PROGN (SETQ |i| (CAR |bfVar#14|)) NIL)) - (RETURN NIL)) - ('T - (PROGN - (SETQ |a| (CONCAT (PNAME |i|) " is used in ")) - (|bootOutLines| (SSORT (GETHASH |i| |$bootUsed|)) - |stream| |a|)))) - (SETQ |bfVar#14| (CDR |bfVar#14|)))) - |c| NIL))))) - -(DEFUN FBO (|name| |fn|) - (PROG () (RETURN (|shoeGeneralFC| #'BO |name| |fn|)))) - -(DEFUN FEV (|name| |fn|) - (PROG () (RETURN (|shoeGeneralFC| #'EVAL-BOOT-FILE |name| |fn|)))) - -(DEFUN |shoeGeneralFC| (|f| |name| |fn|) - (PROG (|$GenVarCounter| |$bfClamming| |filename| |a| |infn|) - (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter|)) - (RETURN - (PROGN - (SETQ |$bfClamming| NIL) - (SETQ |$GenVarCounter| 0) - (SETQ |infn| (|shoeAddbootIfNec| |fn|)) - (SETQ |a| - (|shoeOpenInputFile| |a| |infn| - (|shoeFindName2| |fn| |name| |a|))) - (SETQ |filename| - (COND - ((< 8 (LENGTH |name|)) (SUBSTRING |name| 0 8)) - ('T |name|))) - (COND - (|a| (FUNCALL |f| (CONCAT "/tmp/" |filename|))) - ('T NIL)))))) - -(DEFUN |shoeFindName2| (|fn| |name| |a|) - (PROG (|filename| |lines|) - (RETURN - (PROGN - (SETQ |lines| (|shoeFindLines| |fn| |name| |a|)) - (COND - (|lines| (PROGN - (SETQ |filename| - (COND - ((< 8 (LENGTH |name|)) - (SUBSTRING |name| 0 8)) - ('T |name|))) - (SETQ |filename| - (CONCAT "/tmp/" |filename| ".boot")) - (|shoeOpenOutputFile| |stream| |filename| - ((LAMBDA (|bfVar#15| |line|) - (LOOP - (COND - ((OR (ATOM |bfVar#15|) - (PROGN - (SETQ |line| (CAR |bfVar#15|)) - NIL)) - (RETURN NIL)) - ('T (|shoeFileLine| |line| |stream|))) - (SETQ |bfVar#15| (CDR |bfVar#15|)))) - |lines| NIL)) - T)) - ('T NIL)))))) - -(DEFUN |shoeTransform2| (|str|) - (PROG () - (RETURN - (|bNext| #'|shoeItem| - (|streamTake| 1 - (|bNext| #'|shoePileInsert| - (|bNext| #'|shoeLineToks| |str|))))))) - -(DEFUN |shoeItem| (|str|) - (PROG (|dq|) - (RETURN - (PROGN - (SETQ |dq| (CAR |str|)) - (CONS (LIST ((LAMBDA (|bfVar#17| |bfVar#16| |line|) - (LOOP - (COND - ((OR (ATOM |bfVar#16|) - (PROGN - (SETQ |line| (CAR |bfVar#16|)) - NIL)) - (RETURN (NREVERSE |bfVar#17|))) - ('T - (SETQ |bfVar#17| - (CONS (CAR |line|) |bfVar#17|)))) - (SETQ |bfVar#16| (CDR |bfVar#16|)))) - NIL (|shoeDQlines| |dq|) NIL)) - (CDR |str|)))))) - -(DEFUN |shoeFindLines| (|fn| |name| |a|) - (PROG (|b| |lines| |LETTMP#1|) - (RETURN - (COND - ((NULL |a|) (|shoeNotFound| |fn|) NIL) - ('T - (SETQ |LETTMP#1| - (|shoePackageStartsAt| NIL (LENGTH |name|) |name| - (|shoeInclude| - (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0))))) - (SETQ |lines| (CAR |LETTMP#1|)) (SETQ |b| (CADR |LETTMP#1|)) - (SETQ |b| (|shoeTransform2| |b|)) - (COND - ((|bStreamNull| |b|) - (|shoeConsole| (CONCAT |name| " not found in " |fn|)) NIL) - ('T - (COND - ((NULL |lines|) (|shoeConsole| ")package not found"))) - (APPEND (REVERSE |lines|) (CAR |b|))))))))) - -(DEFUN |shoePackageStartsAt| (|lines| |sz| |name| |stream|) - (PROG (|a|) - (RETURN - (COND - ((|bStreamNull| |stream|) (LIST NIL (LIST '|nullstream|))) - ('T - (PROGN - (SETQ |a| (CAAR |stream|)) - (COND - ((AND (NOT (< (LENGTH |a|) 8)) - (EQUAL (SUBSTRING |a| 0 8) ")package")) - (|shoePackageStartsAt| (CONS (CAAR |stream|) |lines|) - |sz| |name| (CDR |stream|))) - ((< (LENGTH |a|) |sz|) - (|shoePackageStartsAt| |lines| |sz| |name| - (CDR |stream|))) - ((AND (EQUAL (SUBSTRING |a| 0 |sz|) |name|) - (< |sz| (LENGTH |a|)) - (NULL (|shoeIdChar| (ELT |a| |sz|)))) - (LIST |lines| |stream|)) - ('T - (|shoePackageStartsAt| |lines| |sz| |name| - (CDR |stream|)))))))))) - -(DEFUN |stripm| (|x| |pk| |bt|) - (PROG () - (RETURN - (COND - ((ATOM |x|) - (COND - ((IDENTP |x|) - (COND - ((EQUAL (SYMBOL-PACKAGE |x|) |bt|) - (INTERN (PNAME |x|) |pk|)) - ('T |x|))) - ('T |x|))) - ('T - (CONS (|stripm| (CAR |x|) |pk| |bt|) - (|stripm| (CDR |x|) |pk| |bt|))))))) - -(DEFUN |shoePCompile| (|fn|) - (PROG (|body| |bv| |ISTMP#2| |name| |ISTMP#1|) - (RETURN - (PROGN - (SETQ |fn| (|stripm| |fn| *PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) - (COND - ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN) - (PROGN - (SETQ |ISTMP#1| (CDR |fn|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |name| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |bv| (CAR |ISTMP#2|)) - (SETQ |body| (CDR |ISTMP#2|)) - 'T)))))) - (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|)))) - ('T (EVAL |fn|))))))) - -(DEFUN FC (|name| |fn|) - (PROG (|$GenVarCounter| |$bfClamming| |infn|) - (DECLARE (SPECIAL |$bfClamming| |$GenVarCounter|)) - (RETURN - (PROGN - (SETQ |$bfClamming| NIL) - (SETQ |$GenVarCounter| 0) - (SETQ |infn| (|shoeAddbootIfNec| |fn|)) - (|shoeOpenInputFile| |a| |infn| - (|shoeFindName| |fn| |name| |a|)))))) - -(DEFUN |shoeFindName| (|fn| |name| |a|) - (PROG (|lines|) - (RETURN - (PROGN - (SETQ |lines| (|shoeFindLines| |fn| |name| |a|)) - (|shoePCompileTrees| (|shoeTransformString| |lines|)))))) - -(DEFUN |shoePCompileTrees| (|s|) - (PROG () - (RETURN - ((LAMBDA () - (LOOP - (COND - ((|bStreamPackageNull| |s|) (RETURN NIL)) - ('T - (PROGN - (REALLYPRETTYPRINT (|shoePCompile| (CAR |s|))) - (SETQ |s| (CDR |s|))))))))))) - -(DEFUN |bStreamPackageNull| (|s|) - (PROG (|b| |a|) - (RETURN - (PROGN - (SETQ |a| (PACKAGE-NAME *PACKAGE*)) - (IN-PACKAGE 'BOOTTRAN) - (SETQ |b| (|bStreamNull| |s|)) - (IN-PACKAGE |a|) - |b|)))) - -(DEFUN PSTTOMC (|string|) - (PROG (|$bfClamming| |$GenVarCounter|) - (DECLARE (SPECIAL |$GenVarCounter| |$bfClamming|)) - (RETURN - (PROGN - (SETQ |$GenVarCounter| 0) - (SETQ |$bfClamming| NIL) - (|shoePCompileTrees| (|shoeTransformString| |string|)))))) - -(DEFUN BOOTLOOP () - (PROG (|stream| |b| |a|) - (RETURN - (PROGN - (SETQ |a| (READ-LINE)) - (COND - ((EQL (LENGTH |a|) 0) - (PROGN - (WRITE-LINE "Boot Loop; to exit type ] ") - (BOOTLOOP))) - ('T - (PROGN - (SETQ |b| (|shoePrefix?| ")console" |a|)) - (COND - (|b| (PROGN - (SETQ |stream| *TERMINAL-IO*) - (PSTTOMC (|bRgen| |stream|)) - (BOOTLOOP))) - ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL) - ('T (PROGN (PSTTOMC (LIST |a|)) (BOOTLOOP))))))))))) - -(DEFUN BOOTPO () - (PROG (|stream| |b| |a|) - (RETURN - (PROGN - (SETQ |a| (READ-LINE)) - (COND - ((EQL (LENGTH |a|) 0) - (PROGN (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTPO))) - ('T - (PROGN - (SETQ |b| (|shoePrefix?| ")console" |a|)) - (COND - (|b| (PROGN - (SETQ |stream| *TERMINAL-IO*) - (PSTOUT (|bRgen| |stream|)) - (BOOTPO))) - ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL) - ('T (PROGN (PSTOUT (LIST |a|)) (BOOTPO))))))))))) - -(DEFUN PSTOUT (|string|) - (PROG (|$bfClamming| |$GenVarCounter|) - (DECLARE (SPECIAL |$GenVarCounter| |$bfClamming|)) - (RETURN - (PROGN - (SETQ |$GenVarCounter| 0) - (SETQ |$bfClamming| NIL) - (|shoeConsoleTrees| (|shoeTransformString| |string|)))))) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/tyextra.boot.pamphlet b/src/boot/tyextra.boot.pamphlet deleted file mode 100644 index d40548c..0000000 --- a/src/boot/tyextra.boot.pamphlet +++ /dev/null @@ -1,313 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot tyextra.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package 'BOOTTRAN -bpStruct()== - bpEqKey "STRUCTURE" and - (bpName() or bpTrap()) and - (bpEqKey "DEF" or bpTrap()) and - bpTypeList() and bpPush bfStruct(bpPop2(),bpPop1()) - -bpTypeList() == bpPileBracketed function bpTypeItemList - or bpTerm() and bpPush [bpPop1()] - -bpTypeItemList() == bpListAndRecover function bpTerm - -bpTerm() == - (bpName() or bpTrap()) and - ((bpParenthesized function bpIdList and - bpPush bfNameArgs (bpPop2(),bpPop1())) - or bpName() and bpPush bfNameArgs(bpPop2(),bpPop1())) - or bpPush(bfNameOnly bpPop1()) - -bpIdList()== bpTuple function bpName - -bfNameOnly x== - if x="t" - then ["T"] - else [x] - -bfNameArgs (x,y)== - y:=if EQCAR(y,"TUPLE") then CDR y else [y] - cons(x,y) - -bfStruct(name,arglist)== - bfTuple [bfCreateDef i for i in arglist] - -bfCreateDef x== - if null cdr x - then - f:=car x - ["SETQ",f,["LIST",["QUOTE",f]]] - else - a:=[bfGenSymbol() for i in cdr x] - ["DEFUN",car x,a,["CONS",["QUOTE",car x],["LIST",:a]]] - -bpCase()== - bpEqKey "CASE" and - (bpWhere() or bpTrap()) and - (bpEqKey "OF" or bpMissing "OF") and - bpPiledCaseItems() - -bpPiledCaseItems()== - bpPileBracketed function bpCaseItemList and - bpPush bfCase(bpPop2(),bpPop1()) -bpCaseItemList()== - bpListAndRecover function bpCaseItem - -bpCaseItem()== - (bpTerm() or bpTrap()) and - (bpEqKey "EXIT" or bpTrap()) and - (bpWhere() or bpTrap()) and - bpPush bfCaseItem (bpPop2(),bpPop1()) - -bfCaseItem(x,y)==[x,y] - -bfCase(x,y)== - g:=bfGenSymbol() - g1:=bfGenSymbol() - a:=bfLET(g,x) - b:=bfLET(g1,["CDR",g]) - c:=bfCaseItems (g1,y) - bfMKPROGN [a,b,["CASE",["CAR", g],:c]] - -bfCaseItems(g,x)== [bfCI(g,i,j) for [i,j] in x] - -bfCI(g,x,y)== - a:=cdr x - if null a - then [car x,y] - else - b:=[[i,bfCARCDR(j,g)] for i in a for j in 0..] - [car x,["LET",b,y]] - -bfCARCDR (n,g)==[INTERN CONCAT ('"CA",bfDs n,'"R"),g] - -bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1)) - - - - -@ -<>= - -(IN-PACKAGE 'BOOTTRAN) - -(DEFUN |bpStruct| () - (PROG () - (RETURN - (AND (|bpEqKey| 'STRUCTURE) (OR (|bpName|) (|bpTrap|)) - (OR (|bpEqKey| 'DEF) (|bpTrap|)) (|bpTypeList|) - (|bpPush| (|bfStruct| (|bpPop2|) (|bpPop1|))))))) - -(DEFUN |bpTypeList| () - (PROG () - (RETURN - (OR (|bpPileBracketed| #'|bpTypeItemList|) - (AND (|bpTerm|) (|bpPush| (LIST (|bpPop1|)))))))) - -(DEFUN |bpTypeItemList| () - (PROG () (RETURN (|bpListAndRecover| #'|bpTerm|)))) - -(DEFUN |bpTerm| () - (PROG () - (RETURN - (OR (AND (OR (|bpName|) (|bpTrap|)) - (OR (AND (|bpParenthesized| #'|bpIdList|) - (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))) - (AND (|bpName|) - (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))))) - (|bpPush| (|bfNameOnly| (|bpPop1|))))))) - -(DEFUN |bpIdList| () (PROG () (RETURN (|bpTuple| #'|bpName|)))) - -(DEFUN |bfNameOnly| (|x|) - (PROG () (RETURN (COND ((EQ |x| '|t|) (LIST 'T)) ('T (LIST |x|)))))) - -(DEFUN |bfNameArgs| (|x| |y|) - (PROG () - (RETURN - (PROGN - (SETQ |y| - (COND ((EQCAR |y| 'TUPLE) (CDR |y|)) ('T (LIST |y|)))) - (CONS |x| |y|))))) - -(DEFUN |bfStruct| (|name| |arglist|) - (PROG () - (RETURN - (|bfTuple| - ((LAMBDA (|bfVar#2| |bfVar#1| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#1|) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN (NREVERSE |bfVar#2|))) - ('T - (SETQ |bfVar#2| (CONS (|bfCreateDef| |i|) |bfVar#2|)))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - NIL |arglist| NIL))))) - -(DEFUN |bfCreateDef| (|x|) - (PROG (|a| |f|) - (RETURN - (COND - ((NULL (CDR |x|)) (SETQ |f| (CAR |x|)) - (LIST 'SETQ |f| (LIST 'LIST (LIST 'QUOTE |f|)))) - ('T - (SETQ |a| - ((LAMBDA (|bfVar#4| |bfVar#3| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#3|) - (PROGN (SETQ |i| (CAR |bfVar#3|)) NIL)) - (RETURN (NREVERSE |bfVar#4|))) - ('T - (SETQ |bfVar#4| - (CONS (|bfGenSymbol|) |bfVar#4|)))) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - NIL (CDR |x|) NIL)) - (LIST 'DEFUN (CAR |x|) |a| - (LIST 'CONS (LIST 'QUOTE (CAR |x|)) (CONS 'LIST |a|)))))))) - -(DEFUN |bpCase| () - (PROG () - (RETURN - (AND (|bpEqKey| 'CASE) (OR (|bpWhere|) (|bpTrap|)) - (OR (|bpEqKey| 'OF) (|bpMissing| 'OF)) (|bpPiledCaseItems|))))) - -(DEFUN |bpPiledCaseItems| () - (PROG () - (RETURN - (AND (|bpPileBracketed| #'|bpCaseItemList|) - (|bpPush| (|bfCase| (|bpPop2|) (|bpPop1|))))))) - -(DEFUN |bpCaseItemList| () - (PROG () (RETURN (|bpListAndRecover| #'|bpCaseItem|)))) - -(DEFUN |bpCaseItem| () - (PROG () - (RETURN - (AND (OR (|bpTerm|) (|bpTrap|)) (OR (|bpEqKey| 'EXIT) (|bpTrap|)) - (OR (|bpWhere|) (|bpTrap|)) - (|bpPush| (|bfCaseItem| (|bpPop2|) (|bpPop1|))))))) - -(DEFUN |bfCaseItem| (|x| |y|) (PROG () (RETURN (LIST |x| |y|)))) - -(DEFUN |bfCase| (|x| |y|) - (PROG (|c| |b| |a| |g1| |g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (SETQ |g1| (|bfGenSymbol|)) - (SETQ |a| (|bfLET| |g| |x|)) - (SETQ |b| (|bfLET| |g1| (LIST 'CDR |g|))) - (SETQ |c| (|bfCaseItems| |g1| |y|)) - (|bfMKPROGN| - (LIST |a| |b| (CONS 'CASE (CONS (LIST 'CAR |g|) |c|)))))))) - -(DEFUN |bfCaseItems| (|g| |x|) - (PROG (|j| |ISTMP#1| |i|) - (RETURN - ((LAMBDA (|bfVar#7| |bfVar#6| |bfVar#5|) - (LOOP - (COND - ((OR (ATOM |bfVar#6|) - (PROGN (SETQ |bfVar#5| (CAR |bfVar#6|)) NIL)) - (RETURN (NREVERSE |bfVar#7|))) - ('T - (AND (CONSP |bfVar#5|) - (PROGN - (SETQ |i| (CAR |bfVar#5|)) - (SETQ |ISTMP#1| (CDR |bfVar#5|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |j| (CAR |ISTMP#1|)) 'T))) - (SETQ |bfVar#7| - (CONS (|bfCI| |g| |i| |j|) |bfVar#7|))))) - (SETQ |bfVar#6| (CDR |bfVar#6|)))) - NIL |x| NIL)))) - -(DEFUN |bfCI| (|g| |x| |y|) - (PROG (|b| |a|) - (RETURN - (PROGN - (SETQ |a| (CDR |x|)) - (COND - ((NULL |a|) (LIST (CAR |x|) |y|)) - ('T - (SETQ |b| - ((LAMBDA (|bfVar#9| |bfVar#8| |i| |j|) - (LOOP - (COND - ((OR (ATOM |bfVar#8|) - (PROGN (SETQ |i| (CAR |bfVar#8|)) NIL)) - (RETURN (NREVERSE |bfVar#9|))) - ('T - (SETQ |bfVar#9| - (CONS (LIST |i| (|bfCARCDR| |j| |g|)) - |bfVar#9|)))) - (SETQ |bfVar#8| (CDR |bfVar#8|)) - (SETQ |j| (+ |j| 1)))) - NIL |a| NIL 0)) - (LIST (CAR |x|) (LIST 'LET |b| |y|)))))))) - -(DEFUN |bfCARCDR| (|n| |g|) - (PROG () - (RETURN (LIST (INTERN (CONCAT "CA" (|bfDs| |n|) "R")) |g|)))) - -(DEFUN |bfDs| (|n|) - (PROG () - (RETURN - (COND ((EQL |n| 0) "") ('T (CONCAT "D" (|bfDs| (- |n| 1)))))))) - -@ - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/typars.boot.pamphlet b/src/boot/typars.boot.pamphlet deleted file mode 100644 index a66fe08..0000000 --- a/src/boot/typars.boot.pamphlet +++ /dev/null @@ -1,2182 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\usepackage{fancyvrb} - -\CustomVerbatimEnvironment{Grammar}{Verbatim}% - {frame=none,fontsize=\small,commandchars=\\\{\}} -\newcommand{\production}[1]{{\rmfamily\itshape{#1}}} -\newcommand{\Terminal}[1]{\ensuremath{\mathbf{#1}}} -\newcommand{\Bar}{\ensuremath{\mid}} -\newcommand{\Comment}[1]{-- \textrm{#1}} - -\begin{document} -\title{\$SPAD/src/boot typars.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{Introduction} -\label{sec:intro} - -This file defines the grammar, and implements the parser for the -Boot language. The parser is -recursive descent and uses \emph{parser combinators} techniques. - -\section{The Parser} -\label{sec:parser} - - -\subsection{Names} -\label{sec:parser:name} - -\begin{Grammar} - \production{Name:} - \Terminal{ID} -\end{Grammar} - -<>= -bpName() == - if EQCAR( $stok,"ID") - then - bpPushId() - bpNext() - else false -@ - - -\subsection{Constants} -\label{sec:parser:constant} - -\begin{Grammar} - \production{Constant:} - \Terminal{INTEGER} - \Bar \Terminal{FLOAT} - \Bar \Terminal{LISP} - \Bar \Terminal{LISPEXPR} - \Bar \Terminal{LINE} - \Bar \Terminal{QUOTE} \production{S-Expression} - \Bar \Terminal{STRING} -\end{Grammar} - -<>= -bpConstTok() == - MEMQ(shoeTokType $stok, '(INTEGER FLOAT)) => - bpPush $ttok - bpNext() - EQCAR($stok,"LISP")=> bpPush bfReadLisp $ttok and bpNext() - EQCAR($stok,"LISPEXP")=> bpPush $ttok and bpNext() - EQCAR($stok,"LINE")=> bpPush ["+LINE", $ttok] and bpNext() - bpEqPeek "QUOTE" => - bpNext() - (bpSexp() or bpTrap()) and - bpPush bfSymbol bpPop1() - bpString() -@ - -\subsection{Wildchar} -\label{sec:parser:dot} - -The dot character (\verb!.!) is used both as a selection operator and -as wild character in patterns. -\begin{Grammar} - \production{Dot:} - \Terminal{DOT} -\end{Grammar} - -<>= -bpDot()== bpEqKey "DOT" and bpPush bfDot () -@ - - -\subsection{Prefix operators} -\label{sec:parser:prefix-op} - -Boot has two prefix operators. -\begin{Grammar} - \production{PrefixOperator:} \textrm{one of} - ^ # -\end{Grammar} - -<>= -bpPrefixOperator()== - EQCAR( $stok,"KEY") and - GET($ttok,"SHOEPRE") and bpPushId() and bpNext() -@ - -\subsection{Infix operators} -\label{sec:parser:infix-op} - -\begin{Grammar} - \production{InfixOperator:} \textrm{one of} - = * + is isnt and or / ** - < > <= >= ^= -\end{Grammar} - -<>= -bpInfixOperator()== - EQCAR( $stok,"KEY") and - GET($ttok,"SHOEINF") and bpPushId() and bpNext() -@ - -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package 'BOOTTRAN -bpFirstToken()== - $stok:= - if null $inputStream - then shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok) - else CAR $inputStream - $ttok:=shoeTokPart $stok - true - -bpFirstTok()== - $stok:= - if null $inputStream - then shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok) - else CAR $inputStream - $ttok:=shoeTokPart $stok - $bpParenCount>0 and EQCAR($stok,"KEY") => - EQ($ttok,"SETTAB")=> - $bpCount:=$bpCount+1 - bpNext() - EQ($ttok,"BACKTAB")=> - $bpCount:=$bpCount-1 - bpNext() - EQ($ttok,"BACKSET")=> - bpNext() - true - true - -bpNext() == - $inputStream := CDR($inputStream) - bpFirstTok() - -bpNextToken() == - $inputStream := CDR($inputStream) - bpFirstToken() - -bpState()== [$inputStream,$stack,$bpParenCount,$bpCount] ---cons($inputStream,$stack) - -bpRestore(x)== - $inputStream:=CAR x - bpFirstToken() - $stack:=CADR x - $bpParenCount:=CADDR x - $bpCount:=CADDDR x - true - -bpPush x==$stack:=CONS(x,$stack) - -bpPushId()== - $stack:=CONS(bfReName $ttok,$stack) - -bpPop1()== - a:=CAR $stack - $stack:=CDR $stack - a - -bpPop2()== - a:=CADR $stack - RPLACD($stack,CDDR $stack) - a - -bpPop3()== - a:=CADDR $stack - RPLACD(CDR $stack,CDDDR $stack) - a - -bpIndentParenthesized f== - $bpCount:local:=0 - a:=$stok - if bpEqPeek "OPAREN" - then - $bpParenCount:=$bpParenCount+1 - bpNext() - if APPLY(f,nil) and bpFirstTok() and - (bpEqPeek "CPAREN" or bpParenTrap(a)) - then - $bpParenCount:=$bpParenCount-1 - bpNextToken() - $bpCount=0 => true - $inputStream:=append( bpAddTokens $bpCount,$inputStream) - bpFirstToken() - $bpParenCount=0 => - bpCancel() - true - true - else if bpEqPeek "CPAREN" - then - bpPush bfTuple [] - $bpParenCount:=$bpParenCount-1 - bpNextToken() - true - else bpParenTrap(a) - else false - -bpParenthesized f== - a:=$stok - if bpEqKey "OPAREN" - then - if APPLY(f,nil) and (bpEqKey "CPAREN" or bpParenTrap(a)) - then true - else if bpEqKey "CPAREN" - then - bpPush bfTuple [] - true - else bpParenTrap(a) - else false - -bpBracket f== - a:=$stok - if bpEqKey "OBRACK" - then - if APPLY(f,nil) and (bpEqKey "CBRACK" or bpBrackTrap(a)) - then bpPush bfBracket bpPop1 () - else if bpEqKey "CBRACK" - then bpPush [] - else bpBrackTrap(a) - else false - -bpPileBracketed f== - if bpEqKey "SETTAB" - then if bpEqKey "BACKTAB" - then true - else if APPLY(f,nil) and - (bpEqKey "BACKTAB" or bpPileTrap()) - then bpPush bfPile bpPop1() - else false - else false - -bpListof(f,str1,g)== - if APPLY(f,nil) - then - if bpEqKey str1 and (APPLY(f,nil) or bpTrap()) - then - a:=$stack - $stack:=nil - while bpEqKey str1 and (APPLY(f,nil) or bpTrap()) repeat 0 - $stack:=cons(NREVERSE $stack,a) - bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()]) - else - true - else false - - --- to do , -bpListofFun(f,h,g)== - if APPLY(f,nil) - then - if APPLY(h,nil) and (APPLY(f,nil) or bpTrap()) - then - a:=$stack - $stack:=nil - while APPLY(h,nil) and (APPLY(f,nil) or bpTrap()) repeat 0 - $stack:=cons(NREVERSE $stack,a) - bpPush FUNCALL(g, bfListOf [bpPop3(),bpPop2(),:bpPop1()]) - else - true - else false - -bpList(f,str1,g)== - if APPLY(f,nil) - then - if bpEqKey str1 and (APPLY(f,nil) or bpTrap()) - then - a:=$stack - $stack:=nil - while bpEqKey str1 and (APPLY(f,nil) or bpTrap()) repeat 0 - $stack:=cons(NREVERSE $stack,a) - bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()]) - else - bpPush FUNCALL(g, [bpPop1()]) - else bpPush FUNCALL(g, []) - -bpOneOrMore f== - APPLY(f,nil)=> - a:=$stack - $stack:=nil - while APPLY(f,nil) repeat 0 - $stack:=cons(NREVERSE $stack,a) - bpPush cons(bpPop2(),bpPop1()) - false - - --- s must transform the head of the stack -bpAnyNo s== - while APPLY(s,nil) repeat 0 - true - - --- AndOr(k,p,f)= k p -bpAndOr(keyword,p,f)== - bpEqKey keyword and (APPLY(p,nil) or bpTrap()) - and bpPush FUNCALL(f, bpPop1()) - -bpConditional f== - if bpEqKey "IF" and (bpWhere() or bpTrap()) and - (bpEqKey "BACKSET" or true) - then - if bpEqKey "SETTAB" - then if bpEqKey "THEN" - then (APPLY(f,nil) or bpTrap()) and bpElse(f) and bpEqKey "BACKTAB" - else bpMissing "THEN" - else if bpEqKey "THEN" - then (APPLY(f,nil) or bpTrap()) and bpElse(f) - else bpMissing "then" - else false - -bpElse(f)== - a:=bpState() - if bpBacksetElse() - then (APPLY(f,nil) or bpTrap()) and - bpPush bfIf(bpPop3(),bpPop2(),bpPop1()) - else - bpRestore a - bpPush bfIfThenOnly(bpPop2(),bpPop1()) - -bpBacksetElse()== - if bpEqKey "BACKSET" - then bpEqKey "ELSE" - else bpEqKey "ELSE" - -bpEqPeek s == EQCAR($stok,"KEY") and EQ(s,$ttok) - -bpEqKey s == EQCAR($stok,"KEY") and EQ(s,$ttok) and bpNext() -bpEqKeyNextTok s == EQCAR($stok,"KEY") and EQ(s,$ttok) and - bpNextToken() - -bpPileTrap() == bpMissing "BACKTAB" -bpBrackTrap(x) == bpMissingMate("]",x) -bpParenTrap(x) == bpMissingMate(")",x) - -bpMissingMate(close,open)== - bpSpecificErrorAtToken(open, '"possibly missing mate") - bpMissing close - -bpMissing s== - bpSpecificErrorHere(CONCAT(PNAME s,'" possibly missing")) - THROW("TRAPPOINT","TRAPPED") - -bpCompMissing s == bpEqKey s or bpMissing s - -bpTrap()== - bpGeneralErrorHere() - THROW("TRAPPOINT","TRAPPED") - -bpRecoverTrap()== - bpFirstToken() - pos1 := shoeTokPosn $stok - bpMoveTo 0 - pos2 := shoeTokPosn $stok - bpIgnoredFromTo(pos1, pos2) - bpPush [['"pile syntax error"]] - -bpListAndRecover(f)== - a:=$stack - b:=nil - $stack:=nil - done:=false - c:=$inputStream - while not done repeat --- $trapped:local:=false - found:=CATCH("TRAPPOINT",APPLY(f,nil)) - if found="TRAPPED" - then - $inputStream:=c - bpRecoverTrap() - else if not found - then - $inputStream:=c - bpGeneralErrorHere() - bpRecoverTrap() - if bpEqKey "BACKSET" - then - c:=$inputStream - else if bpEqPeek "BACKTAB" or null $inputStream - then - done:=true - else - $inputStream:=c - bpGeneralErrorHere() - bpRecoverTrap() - if bpEqPeek "BACKTAB" or null $inputStream - then done:=true - else - bpNext() - c:=$inputStream - b:=cons(bpPop1(),b) - $stack:=a - bpPush NREVERSE b - -bpMoveTo n== - null $inputStream => true - bpEqPeek "BACKTAB" => - n=0 => true - bpNextToken() - $bpCount:=$bpCount-1 - bpMoveTo(n-1) - bpEqPeek "BACKSET" => - n=0 => true - bpNextToken() - bpMoveTo n - bpEqPeek "SETTAB" => - bpNextToken() - bpMoveTo(n+1) - bpEqPeek "OPAREN" => - bpNextToken() - $bpParenCount:=$bpParenCount+1 - bpMoveTo n - bpEqPeek "CPAREN" => - bpNextToken() - $bpParenCount:=$bpParenCount-1 - bpMoveTo n - bpNextToken() - bpMoveTo n - -bpSpecificErrorAtToken(tok, key) == - a:=shoeTokPosn tok - SoftShoeError(a,key) - -bpGeneralErrorHere() == bpSpecificErrorHere('"syntax error") - -bpSpecificErrorHere(key) == bpSpecificErrorAtToken($stok, key) - -bpName() == - if EQCAR( $stok,"ID") - then - bpPushId() - bpNext() - else false - -bpConstTok() == - MEMQ(shoeTokType $stok, '(INTEGER FLOAT)) => - bpPush $ttok - bpNext() - EQCAR($stok,"LISP")=> bpPush bfReadLisp $ttok and bpNext() - EQCAR($stok,"LISPEXP")=> bpPush $ttok and bpNext() - EQCAR($stok,"LINE")=> bpPush ["+LINE", $ttok] and bpNext() - bpEqPeek "QUOTE" => - bpNext() - (bpSexp() or bpTrap()) and - bpPush bfSymbol bpPop1() - bpString() -bpCancel()== - a:=bpState() - if bpEqKeyNextTok "SETTAB" - then if bpCancel() - then if bpEqKeyNextTok "BACKTAB" - then true - else - bpRestore a - false - else - if bpEqKeyNextTok "BACKTAB" - then true - else - bpRestore a - false - else false -bpAddTokens n== - n=0 => nil - n>0=> cons(shoeTokConstruct("KEY","SETTAB",shoeTokPosn $stok),bpAddTokens(n-1)) - cons(shoeTokConstruct("KEY","BACKTAB",shoeTokPosn $stok),bpAddTokens(n+1)) - -bpExceptions()== - bpEqPeek "DOT" or bpEqPeek "QUOTE" or - bpEqPeek "OPAREN" or bpEqPeek "CPAREN" or - bpEqPeek "SETTAB" or bpEqPeek "BACKTAB" - or bpEqPeek "BACKSET" - - -bpSexpKey()== - EQCAR( $stok,"KEY") and not bpExceptions()=> - a:=GET($ttok,"SHOEINF") - null a=> bpPush $ttok and bpNext() - bpPush a and bpNext() - false - -bpAnyId()== - bpEqKey "MINUS" and (EQCAR($stok,"INTEGER") or bpTrap()) and - bpPush MINUS $ttok and bpNext() or - bpSexpKey() or - MEMQ(shoeTokType $stok, '(ID INTEGER STRING FLOAT)) - and bpPush $ttok and bpNext() - -bpSexp()== - bpAnyId() or - bpEqKey "QUOTE" and (bpSexp() or bpTrap()) - and bpPush bfSymbol bpPop1() or - bpIndentParenthesized function bpSexp1 - -bpSexp1()== bpFirstTok() and - bpSexp() and - (bpEqKey "DOT" and bpSexp() and bpPush CONS (bpPop2(),bpPop1())or - bpSexp1() and bpPush CONS (bpPop2(),bpPop1())) or - bpPush nil - -bpPrimary1() == - bpName() or - bpDot() or - bpConstTok() or - bpConstruct() or - bpCase() or - bpStruct() or - bpPDefinition() or - bpBPileDefinition() - -bpPrimary()== bpFirstTok() and (bpPrimary1() or bpPrefixOperator()) - -bpDot()== bpEqKey "DOT" and bpPush bfDot () - -bpPrefixOperator()== - EQCAR( $stok,"KEY") and - GET($ttok,"SHOEPRE") and bpPushId() and bpNext() - -bpInfixOperator()== - EQCAR( $stok,"KEY") and - GET($ttok,"SHOEINF") and bpPushId() and bpNext() - -bpSelector()== - bpEqKey "DOT" and (bpPrimary() - and bpPush(bfElt(bpPop2(),bpPop1())) - or bpPush bfSuffixDot bpPop1() ) - -bpOperator()== bpPrimary() and bpAnyNo function bpSelector - -bpApplication()== - bpPrimary() and bpAnyNo function bpSelector and - (bpApplication() and - bpPush(bfApplication(bpPop2(),bpPop1())) or true) - -bpTagged()== - bpApplication() and - (bpEqKey "COLON" and (bpApplication() or bpTrap()) and - bpPush bfTagged(bpPop2(),bpPop1()) or true) - -bpExpt()== bpRightAssoc('(POWER),function bpTagged) - -bpInfKey s== - EQCAR( $stok,"KEY") and - MEMBER($ttok,s) and bpPushId() and bpNext() - -bpInfGeneric s== bpInfKey s and (bpEqKey "BACKSET" or true) - -bpRightAssoc(o,p)== - a:=bpState() - if APPLY(p,nil) - then - while bpInfGeneric o and (bpRightAssoc(o,p) or bpTrap()) repeat - bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) - true - else - bpRestore a - false - -bpLeftAssoc(operations,parser)== - if APPLY(parser,nil) - then - while bpInfGeneric(operations) and - (APPLY(parser,nil) or bpTrap()) - repeat - bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) - true - else false - -bpString()== - EQ(shoeTokType $stok,"STRING") and - bpPush(["QUOTE",INTERN $ttok]) and bpNext() - -bpThetaName() == - if EQCAR( $stok,"ID") and GET($ttok,"SHOETHETA") - then - bpPushId() - bpNext() - else false - -bpReduceOperator()== - bpInfixOperator() or bpString() - or bpThetaName() - -bpReduce()== - a:=bpState() - if bpReduceOperator() and bpEqKey "SLASH" - then - bpEqPeek "OBRACK" => (bpDConstruct() or bpTrap()) and - bpPush bfReduceCollect(bpPop2(),bpPop1()) - (bpApplication() or bpTrap()) and - bpPush bfReduce(bpPop2(),bpPop1()) - else - bpRestore a - false - -bpTimes()== - bpReduce() or bpLeftAssoc('(TIMES SLASH),function bpExpt) - -bpMinus()== - bpInfGeneric '(MINUS) and (bpTimes() or bpTrap()) - and bpPush(bfApplication(bpPop2(),bpPop1())) - or bpTimes() - -bpArith()==bpLeftAssoc('(PLUS MINUS),function bpMinus) - -bpIs()== - bpArith() and (bpInfKey '(IS ISNT) and (bpPattern() or bpTrap()) - and bpPush bfISApplication(bpPop2(),bpPop2(),bpPop1()) - or true) - -bpBracketConstruct(f)== - bpBracket f and bpPush bfConstruct bpPop1 () - -bpCompare()== - bpIs() and (bpInfKey '(SHOEEQ NE LT LE GT GE IN) - and (bpIs() or bpTrap()) - and bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) - or true) - -bpAnd()== bpLeftAssoc('(AND),function bpCompare) - -bpReturn()== - (bpEqKey "RETURN" and - (bpAnd() or bpTrap()) and - bpPush bfReturnNoName bpPop1()) or bpAnd() - - -bpLogical()== bpLeftAssoc('(OR),function bpReturn) - -bpExpression()== - bpEqKey "COLON" and (bpLogical() and - bpPush bfApplication ("COLON",bpPop1()) - or bpTrap()) or bpLogical() - -bpStatement()== - bpConditional function bpWhere or bpLoop() or bpExpression() - -bpLoop()== - bpIterators() and - (bpCompMissing "REPEAT" and - (bpWhere() or bpTrap()) and - bpPush bfLp(bpPop2(),bpPop1())) - or - bpEqKey "REPEAT" and (bpLogical() or bpTrap()) and - bpPush bfLoop1 bpPop1 () - -bpSuchThat()==bpAndOr("BAR",function bpWhere,function bfSuchthat) - -bpWhile()==bpAndOr ("WHILE",function bpLogical,function bfWhile) - -bpUntil()==bpAndOr ("UNTIL",function bpLogical,function bfUntil) - -bpForIn()== - bpEqKey "FOR" and (bpVariable() or bpTrap()) and (bpCompMissing "IN") - and ((bpSeg() or bpTrap()) and - (bpEqKey "BY" and (bpArith() or bpTrap()) and - bpPush bfForInBy(bpPop3(),bpPop2(),bpPop1())) or - bpPush bfForin(bpPop2(),bpPop1())) - -bpSeg()== - bpArith() and - (bpEqKey "SEG" and - (bpArith() and bpPush(bfSegment2(bpPop2(),bpPop1())) - or bpPush(bfSegment1(bpPop1()))) or true) - -bpIterator()== - bpForIn() or bpSuchThat() or bpWhile() or bpUntil() - -bpIteratorList()==bpOneOrMore function bpIterator - and bpPush bfIterators bpPop1 () - -bpCrossBackSet()== bpEqKey "CROSS" and (bpEqKey "BACKSET" or true) - -bpIterators()== - bpListofFun(function bpIteratorList, - function bpCrossBackSet,function bfCross) - -bpAssign()== - a:=bpState() - if bpStatement() - then - if bpEqPeek "BEC" - then - bpRestore a - bpAssignment() or bpTrap() - else true - else - bpRestore a - false - -bpAssignment()== - bpAssignVariable() and - bpEqKey "BEC" and - (bpAssign() or bpTrap()) and - bpPush bfAssign (bpPop2(),bpPop1()) - --- should only be allowed in sequences -bpExit()== - bpAssign() and (bpEqKey "EXIT" and - ((bpWhere() or bpTrap()) and - bpPush bfExit (bpPop2(),bpPop1())) - or true) - -bpDefinition()== - a:=bpState() - bpExit() => - bpEqPeek "DEF" => - bpRestore a - bpDef() - bpEqPeek "MDEF" => - bpRestore a - bpMdef() - true - bpRestore a - false - -bpStoreName()== - $op:=car $stack - $wheredefs:=nil - $typings:=nil - true - -bpDef() == bpName() and bpStoreName() and - bpDefTail() and bpPush bfCompDef bpPop1 () - -bpDDef() == bpName() and bpDefTail() - -bpDefTail()== - bpEqKey "DEF" and - (bpWhere() or bpTrap()) - and bpPush bfDefinition1(bpPop2(),bpPop1()) - or - bpVariable() and - bpEqKey "DEF" and (bpWhere() or bpTrap()) - and bpPush bfDefinition2(bpPop3(),bpPop2(),bpPop1()) - - -bpMDefTail()== - -- bpEqKey "MDEF" and - -- (bpWhere() or bpTrap()) - -- and bpPush bfMDefinition1(bpPop2(),bpPop1()) - -- or - (bpVariable() or bpTrap()) and - bpEqKey "MDEF" and (bpWhere() or bpTrap()) - and bpPush bfMDefinition2(bpPop3(),bpPop2(),bpPop1()) - -bpMdef()== bpName() and bpStoreName() and bpMDefTail() - -bpWhere()== - bpDefinition() and - (bpEqKey "WHERE" and (bpDefinitionItem() or bpTrap()) - and bpPush bfWhere(bpPop1(),bpPop1()) or true) - -bpDefinitionItem()== - a:=bpState() - if bpDDef() - then true - else - bpRestore a - if bpBDefinitionPileItems() - then true - else - bpRestore a - if bpPDefinitionItems() - then true - else - bpRestore a - bpWhere() - -bpDefinitionPileItems()== - bpListAndRecover function bpDefinitionItem - and bpPush bfDefSequence bpPop1() - -bpBDefinitionPileItems()== bpPileBracketed function bpDefinitionPileItems - -bpSemiColonDefinition()==bpSemiListing - (function bpDefinitionItem,function bfDefSequence) - -bpPDefinitionItems()==bpParenthesized function bpSemiColonDefinition - -bpComma()== bpTuple function bpWhere - -bpTuple(p)==bpListofFun(p,function bpCommaBackSet,function bfTuple) - -bpCommaBackSet()== bpEqKey "COMMA" and (bpEqKey "BACKSET" or true) - -bpSemiColon()==bpSemiListing (function bpComma,function bfSequence) - -bpSemiListing(p,f)==bpListofFun(p,function bpSemiBackSet,f) - -bpSemiBackSet()== bpEqKey "SEMICOLON" and (bpEqKey "BACKSET" or true) - -bpPDefinition()== bpIndentParenthesized function bpSemiColon - -bpPileItems()== - bpListAndRecover function bpSemiColon and bpPush bfSequence bpPop1() - -bpBPileDefinition()== bpPileBracketed function bpPileItems - -bpIteratorTail()== - (bpEqKey "REPEAT" or true) and bpIterators() - ---bpExpression()== bpLogical() - -bpConstruct()==bpBracket function bpConstruction - -bpConstruction()== - bpComma() and - (bpIteratorTail() and - bpPush bfCollect (bpPop2(),bpPop1()) or - bpPush bfTupleConstruct bpPop1()) - -bpDConstruct()==bpBracket function bpDConstruction - -bpDConstruction()== - bpComma() and - (bpIteratorTail() and - bpPush bfDCollect (bpPop2(),bpPop1()) or - bpPush bfDTuple bpPop1()) - - - ---PATTERN - ---bpNameOrDot() == bpName() or bpDot() or bpEqual() - -bpPattern()== bpBracketConstruct function bpPatternL - or bpName() or bpConstTok() - -bpEqual()== - bpEqKey "SHOEEQ" and (bpApplication() or bpConstTok() or - bpTrap()) and bpPush bfEqual bpPop1() - -bpRegularPatternItem() == - bpEqual() or - bpConstTok() or bpDot() or - bpName() and - ((bpEqKey "BEC" and (bpPattern() or bpTrap()) - and bpPush bfAssign(bpPop2(),bpPop1())) or true) - or bpBracketConstruct function bpPatternL - -bpRegularPatternItemL()== - bpRegularPatternItem() and bpPush [bpPop1()] - -bpRegularList()== - bpListof(function bpRegularPatternItemL,"COMMA",function bfAppend) - -bpPatternColon()== - bpEqKey "COLON" and (bpRegularPatternItem() or bpTrap()) - and bpPush [bfColon bpPop1()] - - --- only one colon -bpPatternL() == bpPatternList() and bpPush bfTuple bpPop1() - -bpPatternList()== - if bpRegularPatternItemL() - then - while (bpEqKey "COMMA" and (bpRegularPatternItemL() or - (bpPatternTail() - and bpPush append(bpPop2(),bpPop1()) - or bpTrap();false) )) repeat - bpPush append(bpPop2(),bpPop1()) - true - else bpPatternTail() - -bpPatternTail()== - bpPatternColon() and - (bpEqKey "COMMA" and (bpRegularList() or bpTrap()) - and bpPush append (bpPop2(),bpPop1()) or true) - --- BOUND VARIABLE -bpRegularBVItem() == - bpBVString() or - bpConstTok() or - (bpName() and - (bpEqKey "BEC" and (bpPattern() or bpTrap()) - and bpPush bfAssign(bpPop2(),bpPop1()) or - (bpEqKey "IS" and (bpPattern() or bpTrap()) - and bpPush bfAssign(bpPop2(),bpPop1())) or true)) - or bpBracketConstruct function bpPatternL - -bpBVString()== - EQ(shoeTokType $stok,"STRING") and - bpPush(["BVQUOTE",INTERN $ttok]) and bpNext() - -bpRegularBVItemL() == - bpRegularBVItem() and bpPush [bpPop1()] - -bpColonName()== - bpEqKey "COLON" and (bpName() or bpBVString() or bpTrap()) - - --- at most one colon at end -bpBoundVariablelist()== - if bpRegularBVItemL() - then - while (bpEqKey "COMMA" and (bpRegularBVItemL() or - (bpColonName() - and bpPush bfColonAppend(bpPop2(),bpPop1()) - or bpTrap();false) )) repeat - bpPush append(bpPop2(),bpPop1()) - true - else bpColonName() and bpPush bfColonAppend(nil,bpPop1()) - -bpVariable()== - bpParenthesized function bpBoundVariablelist - and bpPush bfTupleIf bpPop1() - or bpBracketConstruct function bpPatternL - or bpName() or bpConstTok() - -bpAssignVariable()== - bpBracketConstruct function bpPatternL or bpAssignLHS() - -bpAssignLHS()== - bpName() and (bpEqKey "COLON" and (bpApplication() or bpTrap()) - and bpPush bfLocal(bpPop2(),bpPop1()) - or bpEqKey "DOT" and bpList(function bpPrimary,"DOT", - function bfListOf) - and bpChecknull() and - bpPush bfTuple(cons(bpPop2(),bpPop1())) - or true) -bpChecknull()== - a:=bpPop1() - if null a - then bpTrap() - else bpPush a -@ - -\section{The Common Lisp translation} -\label{sec:cl-translation} - -<>= - -(IN-PACKAGE 'BOOTTRAN) - -(DEFUN |bpFirstToken| () - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok| |$inputStream|)) - (RETURN - (PROGN - (SETQ |$stok| - (COND - ((NULL |$inputStream|) - (|shoeTokConstruct| 'ERROR 'NOMORE - (|shoeTokPosn| |$stok|))) - ('T (CAR |$inputStream|)))) - (SETQ |$ttok| (|shoeTokPart| |$stok|)) - T)))) - -(DEFUN |bpFirstTok| () - (PROG () - (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$ttok| |$stok| - |$inputStream|)) - (RETURN - (PROGN - (SETQ |$stok| - (COND - ((NULL |$inputStream|) - (|shoeTokConstruct| 'ERROR 'NOMORE - (|shoeTokPosn| |$stok|))) - ('T (CAR |$inputStream|)))) - (SETQ |$ttok| (|shoeTokPart| |$stok|)) - (COND - ((AND (< 0 |$bpParenCount|) (EQCAR |$stok| 'KEY)) - (COND - ((EQ |$ttok| 'SETTAB) - (PROGN (SETQ |$bpCount| (+ |$bpCount| 1)) (|bpNext|))) - ((EQ |$ttok| 'BACKTAB) - (PROGN (SETQ |$bpCount| (- |$bpCount| 1)) (|bpNext|))) - ((EQ |$ttok| 'BACKSET) (|bpNext|)) - ('T T))) - ('T T)))))) - -(DEFUN |bpNext| () - (PROG () - (DECLARE (SPECIAL |$inputStream|)) - (RETURN - (PROGN - (SETQ |$inputStream| (CDR |$inputStream|)) - (|bpFirstTok|))))) - -(DEFUN |bpNextToken| () - (PROG () - (DECLARE (SPECIAL |$inputStream|)) - (RETURN - (PROGN - (SETQ |$inputStream| (CDR |$inputStream|)) - (|bpFirstToken|))))) - -(DEFUN |bpState| () - (PROG () - (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| - |$inputStream|)) - (RETURN (LIST |$inputStream| |$stack| |$bpParenCount| |$bpCount|)))) - -(DEFUN |bpRestore| (|x|) - (PROG () - (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| - |$inputStream|)) - (RETURN - (PROGN - (SETQ |$inputStream| (CAR |x|)) - (|bpFirstToken|) - (SETQ |$stack| (CADR |x|)) - (SETQ |$bpParenCount| (CADDR |x|)) - (SETQ |$bpCount| (CADDDR |x|)) - T)))) - -(DEFUN |bpPush| (|x|) - (PROG () - (DECLARE (SPECIAL |$stack|)) - (RETURN (SETQ |$stack| (CONS |x| |$stack|))))) - -(DEFUN |bpPushId| () - (PROG () - (DECLARE (SPECIAL |$stack| |$ttok|)) - (RETURN (SETQ |$stack| (CONS (|bfReName| |$ttok|) |$stack|))))) - -(DEFUN |bpPop1| () - (PROG (|a|) - (DECLARE (SPECIAL |$stack|)) - (RETURN - (PROGN - (SETQ |a| (CAR |$stack|)) - (SETQ |$stack| (CDR |$stack|)) - |a|)))) - -(DEFUN |bpPop2| () - (PROG (|a|) - (DECLARE (SPECIAL |$stack|)) - (RETURN - (PROGN - (SETQ |a| (CADR |$stack|)) - (RPLACD |$stack| (CDDR |$stack|)) - |a|)))) - -(DEFUN |bpPop3| () - (PROG (|a|) - (DECLARE (SPECIAL |$stack|)) - (RETURN - (PROGN - (SETQ |a| (CADDR |$stack|)) - (RPLACD (CDR |$stack|) (CDDDR |$stack|)) - |a|)))) - -(DEFUN |bpIndentParenthesized| (|f|) - (PROG (|$bpCount| |a|) - (DECLARE (SPECIAL |$inputStream| |$bpCount| |$bpParenCount| - |$stok|)) - (RETURN - (PROGN - (SETQ |$bpCount| 0) - (SETQ |a| |$stok|) - (COND - ((|bpEqPeek| 'OPAREN) - (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) (|bpNext|) - (COND - ((AND (APPLY |f| NIL) (|bpFirstTok|) - (OR (|bpEqPeek| 'CPAREN) (|bpParenTrap| |a|))) - (SETQ |$bpParenCount| (- |$bpParenCount| 1)) - (|bpNextToken|) - (COND - ((EQL |$bpCount| 0) T) - ('T - (PROGN - (SETQ |$inputStream| - (APPEND (|bpAddTokens| |$bpCount|) - |$inputStream|)) - (|bpFirstToken|) - (COND - ((EQL |$bpParenCount| 0) (PROGN (|bpCancel|) T)) - ('T T)))))) - ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL)) - (SETQ |$bpParenCount| (- |$bpParenCount| 1)) - (|bpNextToken|) T) - ('T (|bpParenTrap| |a|)))) - ('T NIL)))))) - -(DEFUN |bpParenthesized| (|f|) - (PROG (|a|) - (DECLARE (SPECIAL |$stok|)) - (RETURN - (PROGN - (SETQ |a| |$stok|) - (COND - ((|bpEqKey| 'OPAREN) - (COND - ((AND (APPLY |f| NIL) - (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|))) - T) - ((|bpEqKey| 'CPAREN) (|bpPush| (|bfTuple| NIL)) T) - ('T (|bpParenTrap| |a|)))) - ('T NIL)))))) - -(DEFUN |bpBracket| (|f|) - (PROG (|a|) - (DECLARE (SPECIAL |$stok|)) - (RETURN - (PROGN - (SETQ |a| |$stok|) - (COND - ((|bpEqKey| 'OBRACK) - (COND - ((AND (APPLY |f| NIL) - (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|))) - (|bpPush| (|bfBracket| (|bpPop1|)))) - ((|bpEqKey| 'CBRACK) (|bpPush| NIL)) - ('T (|bpBrackTrap| |a|)))) - ('T NIL)))))) - -(DEFUN |bpPileBracketed| (|f|) - (PROG () - (RETURN - (COND - ((|bpEqKey| 'SETTAB) - (COND - ((|bpEqKey| 'BACKTAB) T) - ((AND (APPLY |f| NIL) - (OR (|bpEqKey| 'BACKTAB) (|bpPileTrap|))) - (|bpPush| (|bfPile| (|bpPop1|)))) - ('T NIL))) - ('T NIL))))) - -(DEFUN |bpListof| (|f| |str1| |g|) - (PROG (|a|) - (DECLARE (SPECIAL |$stack|)) - (RETURN - (COND - ((APPLY |f| NIL) - (COND - ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|))) - (SETQ |a| |$stack|) (SETQ |$stack| NIL) - ((LAMBDA () - (LOOP - (COND - ((NOT (AND (|bpEqKey| |str1|) - (OR (APPLY |f| NIL) (|bpTrap|)))) - (RETURN NIL)) - ('T 0))))) - (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) - (|bpPush| - (FUNCALL |g| - (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) - ('T T))) - ('T NIL))))) - -(DEFUN |bpListofFun| (|f| |h| |g|) - (PROG (|a|) - (DECLARE (SPECIAL |$stack|)) - (RETURN - (COND - ((APPLY |f| NIL) - (COND - ((AND (APPLY |h| NIL) (OR (APPLY |f| NIL) (|bpTrap|))) - (SETQ |a| |$stack|) (SETQ |$stack| NIL) - ((LAMBDA () - (LOOP - (COND - ((NOT (AND (APPLY |h| NIL) - (OR (APPLY |f| NIL) (|bpTrap|)))) - (RETURN NIL)) - ('T 0))))) - (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) - (|bpPush| - (FUNCALL |g| - (|bfListOf| - (CONS (|bpPop3|) - (CONS (|bpPop2|) (|bpPop1|))))))) - ('T T))) - ('T NIL))))) - -(DEFUN |bpList| (|f| |str1| |g|) - (PROG (|a|) - (DECLARE (SPECIAL |$stack|)) - (RETURN - (COND - ((APPLY |f| NIL) - (COND - ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|))) - (SETQ |a| |$stack|) (SETQ |$stack| NIL) - ((LAMBDA () - (LOOP - (COND - ((NOT (AND (|bpEqKey| |str1|) - (OR (APPLY |f| NIL) (|bpTrap|)))) - (RETURN NIL)) - ('T 0))))) - (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) - (|bpPush| - (FUNCALL |g| - (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) - ('T (|bpPush| (FUNCALL |g| (LIST (|bpPop1|))))))) - ('T (|bpPush| (FUNCALL |g| NIL))))))) - -(DEFUN |bpOneOrMore| (|f|) - (PROG (|a|) - (DECLARE (SPECIAL |$stack|)) - (RETURN - (COND - ((APPLY |f| NIL) - (PROGN - (SETQ |a| |$stack|) - (SETQ |$stack| NIL) - ((LAMBDA () - (LOOP - (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) ('T 0))))) - (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) - (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))) - ('T NIL))))) - -(DEFUN |bpAnyNo| (|s|) - (PROG () - (RETURN - (PROGN - ((LAMBDA () - (LOOP (COND ((NOT (APPLY |s| NIL)) (RETURN NIL)) ('T 0))))) - T)))) - -(DEFUN |bpAndOr| (|keyword| |p| |f|) - (PROG () - (RETURN - (AND (|bpEqKey| |keyword|) (OR (APPLY |p| NIL) (|bpTrap|)) - (|bpPush| (FUNCALL |f| (|bpPop1|))))))) - -(DEFUN |bpConditional| (|f|) - (PROG () - (RETURN - (COND - ((AND (|bpEqKey| 'IF) (OR (|bpWhere|) (|bpTrap|)) - (OR (|bpEqKey| 'BACKSET) T)) - (COND - ((|bpEqKey| 'SETTAB) - (COND - ((|bpEqKey| 'THEN) - (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|) - (|bpEqKey| 'BACKTAB))) - ('T (|bpMissing| 'THEN)))) - ((|bpEqKey| 'THEN) - (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|))) - ('T (|bpMissing| '|then|)))) - ('T NIL))))) - -(DEFUN |bpElse| (|f|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|bpState|)) - (COND - ((|bpBacksetElse|) - (AND (OR (APPLY |f| NIL) (|bpTrap|)) - (|bpPush| (|bfIf| (|bpPop3|) (|bpPop2|) (|bpPop1|))))) - ('T (|bpRestore| |a|) - (|bpPush| (|bfIfThenOnly| (|bpPop2|) (|bpPop1|))))))))) - -(DEFUN |bpBacksetElse| () - (PROG () - (RETURN - (COND - ((|bpEqKey| 'BACKSET) (|bpEqKey| 'ELSE)) - ('T (|bpEqKey| 'ELSE)))))) - -(DEFUN |bpEqPeek| (|s|) - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|))))) - -(DEFUN |bpEqKey| (|s|) - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|) (|bpNext|))))) - -(DEFUN |bpEqKeyNextTok| (|s|) - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN - (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|) (|bpNextToken|))))) - -(DEFUN |bpPileTrap| () (PROG () (RETURN (|bpMissing| 'BACKTAB)))) - -(DEFUN |bpBrackTrap| (|x|) - (PROG () (RETURN (|bpMissingMate| '] |x|))) -) -(DEFUN |bpParenTrap| (|x|) - (PROG () (RETURN (|bpMissingMate| '|)| |x|))) -) -(DEFUN |bpMissingMate| (|close| |open|) - (PROG () - (RETURN - (PROGN - (|bpSpecificErrorAtToken| |open| "possibly missing mate") - (|bpMissing| |close|))))) - -(DEFUN |bpMissing| (|s|) - (PROG () - (RETURN - (PROGN - (|bpSpecificErrorHere| - (CONCAT (PNAME |s|) " possibly missing")) - (THROW 'TRAPPOINT 'TRAPPED))))) - -(DEFUN |bpCompMissing| (|s|) - (PROG () (RETURN (OR (|bpEqKey| |s|) (|bpMissing| |s|))))) - -(DEFUN |bpTrap| () - (PROG () - (RETURN - (PROGN (|bpGeneralErrorHere|) (THROW 'TRAPPOINT 'TRAPPED))))) - -(DEFUN |bpRecoverTrap| () - (PROG (|pos2| |pos1|) - (DECLARE (SPECIAL |$stok|)) - (RETURN - (PROGN - (|bpFirstToken|) - (SETQ |pos1| (|shoeTokPosn| |$stok|)) - (|bpMoveTo| 0) - (SETQ |pos2| (|shoeTokPosn| |$stok|)) - (|bpIgnoredFromTo| |pos1| |pos2|) - (|bpPush| (LIST (LIST "pile syntax error"))))))) - -(DEFUN |bpListAndRecover| (|f|) - (PROG (|found| |c| |done| |b| |a|) - (DECLARE (SPECIAL |$inputStream| |$stack|)) - (RETURN - (PROGN - (SETQ |a| |$stack|) - (SETQ |b| NIL) - (SETQ |$stack| NIL) - (SETQ |done| NIL) - (SETQ |c| |$inputStream|) - ((LAMBDA () - (LOOP - (COND - (|done| (RETURN NIL)) - ('T - (PROGN - (SETQ |found| (CATCH 'TRAPPOINT (APPLY |f| NIL))) - (COND - ((EQ |found| 'TRAPPED) (SETQ |$inputStream| |c|) - (|bpRecoverTrap|)) - ((NULL |found|) (SETQ |$inputStream| |c|) - (|bpGeneralErrorHere|) (|bpRecoverTrap|))) - (COND - ((|bpEqKey| 'BACKSET) (SETQ |c| |$inputStream|)) - ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|)) - (SETQ |done| T)) - ('T (SETQ |$inputStream| |c|) - (|bpGeneralErrorHere|) (|bpRecoverTrap|) - (COND - ((OR (|bpEqPeek| 'BACKTAB) - (NULL |$inputStream|)) - (SETQ |done| T)) - ('T (|bpNext|) (SETQ |c| |$inputStream|))))) - (SETQ |b| (CONS (|bpPop1|) |b|)))))))) - (SETQ |$stack| |a|) - (|bpPush| (NREVERSE |b|)))))) - -(DEFUN |bpMoveTo| (|n|) - (PROG () - (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$inputStream|)) - (RETURN - (COND - ((NULL |$inputStream|) T) - ((|bpEqPeek| 'BACKTAB) - (COND - ((EQL |n| 0) T) - ('T - (PROGN - (|bpNextToken|) - (SETQ |$bpCount| (- |$bpCount| 1)) - (|bpMoveTo| (- |n| 1)))))) - ((|bpEqPeek| 'BACKSET) - (COND - ((EQL |n| 0) T) - ('T (PROGN (|bpNextToken|) (|bpMoveTo| |n|))))) - ((|bpEqPeek| 'SETTAB) - (PROGN (|bpNextToken|) (|bpMoveTo| (+ |n| 1)))) - ((|bpEqPeek| 'OPAREN) - (PROGN - (|bpNextToken|) - (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) - (|bpMoveTo| |n|))) - ((|bpEqPeek| 'CPAREN) - (PROGN - (|bpNextToken|) - (SETQ |$bpParenCount| (- |$bpParenCount| 1)) - (|bpMoveTo| |n|))) - ('T (PROGN (|bpNextToken|) (|bpMoveTo| |n|))))))) - -(DEFUN |bpSpecificErrorAtToken| (|tok| |key|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|shoeTokPosn| |tok|)) - (|SoftShoeError| |a| |key|))))) - -(DEFUN |bpGeneralErrorHere| () - (PROG () (RETURN (|bpSpecificErrorHere| "syntax error")))) - -(DEFUN |bpSpecificErrorHere| (|key|) - (PROG () - (DECLARE (SPECIAL |$stok|)) - (RETURN (|bpSpecificErrorAtToken| |$stok| |key|)))) - -(DEFUN |bpName| () - (PROG () - (DECLARE (SPECIAL |$stok|)) - (RETURN - (COND ((EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|)) ('T NIL))))) - -(DEFUN |bpConstTok| () - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN - (COND - ((MEMQ (|shoeTokType| |$stok|) '(INTEGER FLOAT)) - (PROGN (|bpPush| |$ttok|) (|bpNext|))) - ((EQCAR |$stok| 'LISP) - (AND (|bpPush| (|bfReadLisp| |$ttok|)) (|bpNext|))) - ((EQCAR |$stok| 'LISPEXP) (AND (|bpPush| |$ttok|) (|bpNext|))) - ((EQCAR |$stok| 'LINE) - (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|))) - ((|bpEqPeek| 'QUOTE) - (PROGN - (|bpNext|) - (AND (OR (|bpSexp|) (|bpTrap|)) - (|bpPush| (|bfSymbol| (|bpPop1|)))))) - ('T (|bpString|)))))) - -(DEFUN |bpCancel| () - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|bpState|)) - (COND - ((|bpEqKeyNextTok| 'SETTAB) - (COND - ((|bpCancel|) - (COND - ((|bpEqKeyNextTok| 'BACKTAB) T) - ('T (|bpRestore| |a|) NIL))) - ((|bpEqKeyNextTok| 'BACKTAB) T) - ('T (|bpRestore| |a|) NIL))) - ('T NIL)))))) - -(DEFUN |bpAddTokens| (|n|) - (PROG () - (DECLARE (SPECIAL |$stok|)) - (RETURN - (COND - ((EQL |n| 0) NIL) - ((< 0 |n|) - (CONS (|shoeTokConstruct| 'KEY 'SETTAB - (|shoeTokPosn| |$stok|)) - (|bpAddTokens| (- |n| 1)))) - ('T - (CONS (|shoeTokConstruct| 'KEY 'BACKTAB - (|shoeTokPosn| |$stok|)) - (|bpAddTokens| (+ |n| 1)))))))) - -(DEFUN |bpExceptions| () - (PROG () - (RETURN - (OR (|bpEqPeek| 'DOT) (|bpEqPeek| 'QUOTE) (|bpEqPeek| 'OPAREN) - (|bpEqPeek| 'CPAREN) (|bpEqPeek| 'SETTAB) - (|bpEqPeek| 'BACKTAB) (|bpEqPeek| 'BACKSET))))) - -(DEFUN |bpSexpKey| () - (PROG (|a|) - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN - (COND - ((AND (EQCAR |$stok| 'KEY) (NULL (|bpExceptions|))) - (PROGN - (SETQ |a| (GET |$ttok| 'SHOEINF)) - (COND - ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|))) - ('T (AND (|bpPush| |a|) (|bpNext|)))))) - ('T NIL))))) - -(DEFUN |bpAnyId| () - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN - (OR (AND (|bpEqKey| 'MINUS) - (OR (EQCAR |$stok| 'INTEGER) (|bpTrap|)) - (|bpPush| (- |$ttok|)) (|bpNext|)) - (|bpSexpKey|) - (AND (MEMQ (|shoeTokType| |$stok|) - '(ID INTEGER STRING FLOAT)) - (|bpPush| |$ttok|) (|bpNext|)))))) - -(DEFUN |bpSexp| () - (PROG () - (RETURN - (OR (|bpAnyId|) - (AND (|bpEqKey| 'QUOTE) (OR (|bpSexp|) (|bpTrap|)) - (|bpPush| (|bfSymbol| (|bpPop1|)))) - (|bpIndentParenthesized| #'|bpSexp1|))))) - -(DEFUN |bpSexp1| () - (PROG () - (RETURN - (OR (AND (|bpFirstTok|) (|bpSexp|) - (OR (AND (|bpEqKey| 'DOT) (|bpSexp|) - (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))) - (AND (|bpSexp1|) - (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))))) - (|bpPush| NIL))))) - -(DEFUN |bpPrimary1| () - (PROG () - (RETURN - (OR (|bpName|) (|bpDot|) (|bpConstTok|) (|bpConstruct|) - (|bpCase|) (|bpStruct|) (|bpPDefinition|) - (|bpBPileDefinition|))))) - -(DEFUN |bpPrimary| () - (PROG () - (RETURN - (AND (|bpFirstTok|) (OR (|bpPrimary1|) (|bpPrefixOperator|)))))) - -(DEFUN |bpDot| () - (PROG () (RETURN (AND (|bpEqKey| 'DOT) (|bpPush| (|bfDot|)))))) - -(DEFUN |bpPrefixOperator| () - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN - (AND (EQCAR |$stok| 'KEY) (GET |$ttok| 'SHOEPRE) (|bpPushId|) - (|bpNext|))))) - -(DEFUN |bpInfixOperator| () - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN - (AND (EQCAR |$stok| 'KEY) (GET |$ttok| 'SHOEINF) (|bpPushId|) - (|bpNext|))))) - -(DEFUN |bpSelector| () - (PROG () - (RETURN - (AND (|bpEqKey| 'DOT) - (OR (AND (|bpPrimary|) - (|bpPush| (|bfElt| (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfSuffixDot| (|bpPop1|)))))))) - -(DEFUN |bpOperator| () - (PROG () (RETURN (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|))))) - -(DEFUN |bpApplication| () - (PROG () - (RETURN - (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|) - (OR (AND (|bpApplication|) - (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) - T))))) - -(DEFUN |bpTagged| () - (PROG () - (RETURN - (AND (|bpApplication|) - (OR (AND (|bpEqKey| 'COLON) - (OR (|bpApplication|) (|bpTrap|)) - (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|)))) - T))))) - -(DEFUN |bpExpt| () - (PROG () (RETURN (|bpRightAssoc| '(POWER) #'|bpTagged|)))) - -(DEFUN |bpInfKey| (|s|) - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN - (AND (EQCAR |$stok| 'KEY) (MEMBER |$ttok| |s|) (|bpPushId|) - (|bpNext|))))) - -(DEFUN |bpInfGeneric| (|s|) - (PROG () - (RETURN (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T))))) - -(DEFUN |bpRightAssoc| (|o| |p|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|bpState|)) - (COND - ((APPLY |p| NIL) - ((LAMBDA () - (LOOP - (COND - ((NOT (AND (|bpInfGeneric| |o|) - (OR (|bpRightAssoc| |o| |p|) (|bpTrap|)))) - (RETURN NIL)) - ('T - (|bpPush| - (|bfInfApplication| (|bpPop2|) (|bpPop2|) - (|bpPop1|)))))))) - T) - ('T (|bpRestore| |a|) NIL)))))) - -(DEFUN |bpLeftAssoc| (|operations| |parser|) - (PROG () - (RETURN - (COND - ((APPLY |parser| NIL) - ((LAMBDA () - (LOOP - (COND - ((NOT (AND (|bpInfGeneric| |operations|) - (OR (APPLY |parser| NIL) (|bpTrap|)))) - (RETURN NIL)) - ('T - (|bpPush| - (|bfInfApplication| (|bpPop2|) (|bpPop2|) - (|bpPop1|)))))))) - T) - ('T NIL))))) - -(DEFUN |bpString| () - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN - (AND (EQ (|shoeTokType| |$stok|) 'STRING) - (|bpPush| (LIST 'QUOTE (INTERN |$ttok|))) (|bpNext|))))) - -(DEFUN |bpThetaName| () - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN - (COND - ((AND (EQCAR |$stok| 'ID) (GET |$ttok| 'SHOETHETA)) - (|bpPushId|) (|bpNext|)) - ('T NIL))))) - -(DEFUN |bpReduceOperator| () - (PROG () - (RETURN (OR (|bpInfixOperator|) (|bpString|) (|bpThetaName|))))) - -(DEFUN |bpReduce| () - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|bpState|)) - (COND - ((AND (|bpReduceOperator|) (|bpEqKey| 'SLASH)) - (COND - ((|bpEqPeek| 'OBRACK) - (AND (OR (|bpDConstruct|) (|bpTrap|)) - (|bpPush| (|bfReduceCollect| (|bpPop2|) (|bpPop1|))))) - ('T - (AND (OR (|bpApplication|) (|bpTrap|)) - (|bpPush| (|bfReduce| (|bpPop2|) (|bpPop1|))))))) - ('T (|bpRestore| |a|) NIL)))))) - -(DEFUN |bpTimes| () - (PROG () - (RETURN - (OR (|bpReduce|) (|bpLeftAssoc| '(TIMES SLASH) #'|bpExpt|))))) - -(DEFUN |bpMinus| () - (PROG () - (RETURN - (OR (AND (|bpInfGeneric| '(MINUS)) (OR (|bpTimes|) (|bpTrap|)) - (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) - (|bpTimes|))))) - -(DEFUN |bpArith| () - (PROG () (RETURN (|bpLeftAssoc| '(PLUS MINUS) #'|bpMinus|)))) - -(DEFUN |bpIs| () - (PROG () - (RETURN - (AND (|bpArith|) - (OR (AND (|bpInfKey| '(IS ISNT)) - (OR (|bpPattern|) (|bpTrap|)) - (|bpPush| - (|bfISApplication| (|bpPop2|) (|bpPop2|) - (|bpPop1|)))) - T))))) - -(DEFUN |bpBracketConstruct| (|f|) - (PROG () - (RETURN - (AND (|bpBracket| |f|) (|bpPush| (|bfConstruct| (|bpPop1|))))))) - -(DEFUN |bpCompare| () - (PROG () - (RETURN - (AND (|bpIs|) - (OR (AND (|bpInfKey| '(SHOEEQ NE LT LE GT GE IN)) - (OR (|bpIs|) (|bpTrap|)) - (|bpPush| - (|bfInfApplication| (|bpPop2|) (|bpPop2|) - (|bpPop1|)))) - T))))) - -(DEFUN |bpAnd| () - (PROG () (RETURN (|bpLeftAssoc| '(AND) #'|bpCompare|)))) - -(DEFUN |bpReturn| () - (PROG () - (RETURN - (OR (AND (|bpEqKey| 'RETURN) (OR (|bpAnd|) (|bpTrap|)) - (|bpPush| (|bfReturnNoName| (|bpPop1|)))) - (|bpAnd|))))) - -(DEFUN |bpLogical| () - (PROG () (RETURN (|bpLeftAssoc| '(OR) #'|bpReturn|)))) - -(DEFUN |bpExpression| () - (PROG () - (RETURN - (OR (AND (|bpEqKey| 'COLON) - (OR (AND (|bpLogical|) - (|bpPush| (|bfApplication| 'COLON (|bpPop1|)))) - (|bpTrap|))) - (|bpLogical|))))) - -(DEFUN |bpStatement| () - (PROG () - (RETURN - (OR (|bpConditional| #'|bpWhere|) (|bpLoop|) (|bpExpression|))))) - -(DEFUN |bpLoop| () - (PROG () - (RETURN - (OR (AND (|bpIterators|) (|bpCompMissing| 'REPEAT) - (OR (|bpWhere|) (|bpTrap|)) - (|bpPush| (|bfLp| (|bpPop2|) (|bpPop1|)))) - (AND (|bpEqKey| 'REPEAT) (OR (|bpLogical|) (|bpTrap|)) - (|bpPush| (|bfLoop1| (|bpPop1|)))))))) - -(DEFUN |bpSuchThat| () - (PROG () (RETURN (|bpAndOr| 'BAR #'|bpWhere| #'|bfSuchthat|)))) - -(DEFUN |bpWhile| () - (PROG () (RETURN (|bpAndOr| 'WHILE #'|bpLogical| #'|bfWhile|)))) - -(DEFUN |bpUntil| () - (PROG () (RETURN (|bpAndOr| 'UNTIL #'|bpLogical| #'|bfUntil|)))) - -(DEFUN |bpForIn| () - (PROG () - (RETURN - (AND (|bpEqKey| 'FOR) (OR (|bpVariable|) (|bpTrap|)) - (|bpCompMissing| 'IN) - (OR (AND (OR (|bpSeg|) (|bpTrap|)) (|bpEqKey| 'BY) - (OR (|bpArith|) (|bpTrap|)) - (|bpPush| - (|bfForInBy| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfForin| (|bpPop2|) (|bpPop1|)))))))) - -(DEFUN |bpSeg| () - (PROG () - (RETURN - (AND (|bpArith|) - (OR (AND (|bpEqKey| 'SEG) - (OR (AND (|bpArith|) - (|bpPush| - (|bfSegment2| (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfSegment1| (|bpPop1|))))) - T))))) - -(DEFUN |bpIterator| () - (PROG () - (RETURN (OR (|bpForIn|) (|bpSuchThat|) (|bpWhile|) (|bpUntil|))))) - -(DEFUN |bpIteratorList| () - (PROG () - (RETURN - (AND (|bpOneOrMore| #'|bpIterator|) - (|bpPush| (|bfIterators| (|bpPop1|))))))) - -(DEFUN |bpCrossBackSet| () - (PROG () - (RETURN (AND (|bpEqKey| 'CROSS) (OR (|bpEqKey| 'BACKSET) T))))) - -(DEFUN |bpIterators| () - (PROG () - (RETURN - (|bpListofFun| #'|bpIteratorList| #'|bpCrossBackSet| #'|bfCross|)))) - -(DEFUN |bpAssign| () - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|bpState|)) - (COND - ((|bpStatement|) - (COND - ((|bpEqPeek| 'BEC) (|bpRestore| |a|) - (OR (|bpAssignment|) (|bpTrap|))) - ('T T))) - ('T (|bpRestore| |a|) NIL)))))) - -(DEFUN |bpAssignment| () - (PROG () - (RETURN - (AND (|bpAssignVariable|) (|bpEqKey| 'BEC) - (OR (|bpAssign|) (|bpTrap|)) - (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))))) - -(DEFUN |bpExit| () - (PROG () - (RETURN - (AND (|bpAssign|) - (OR (AND (|bpEqKey| 'EXIT) (OR (|bpWhere|) (|bpTrap|)) - (|bpPush| (|bfExit| (|bpPop2|) (|bpPop1|)))) - T))))) - -(DEFUN |bpDefinition| () - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|bpState|)) - (COND - ((|bpExit|) - (COND - ((|bpEqPeek| 'DEF) (PROGN (|bpRestore| |a|) (|bpDef|))) - ((|bpEqPeek| 'MDEF) (PROGN (|bpRestore| |a|) (|bpMdef|))) - ('T T))) - ('T (PROGN (|bpRestore| |a|) NIL))))))) - -(DEFUN |bpStoreName| () - (PROG () - (DECLARE (SPECIAL |$typings| |$wheredefs| |$op| |$stack|)) - (RETURN - (PROGN - (SETQ |$op| (CAR |$stack|)) - (SETQ |$wheredefs| NIL) - (SETQ |$typings| NIL) - T)))) - -(DEFUN |bpDef| () - (PROG () - (RETURN - (AND (|bpName|) (|bpStoreName|) (|bpDefTail|) - (|bpPush| (|bfCompDef| (|bpPop1|))))))) - -(DEFUN |bpDDef| () (PROG () (RETURN (AND (|bpName|) (|bpDefTail|))))) - -(DEFUN |bpDefTail| () - (PROG () - (RETURN - (OR (AND (|bpEqKey| 'DEF) (OR (|bpWhere|) (|bpTrap|)) - (|bpPush| (|bfDefinition1| (|bpPop2|) (|bpPop1|)))) - (AND (|bpVariable|) (|bpEqKey| 'DEF) - (OR (|bpWhere|) (|bpTrap|)) - (|bpPush| - (|bfDefinition2| (|bpPop3|) (|bpPop2|) (|bpPop1|)))))))) - -(DEFUN |bpMDefTail| () - (PROG () - (RETURN - (AND (OR (|bpVariable|) (|bpTrap|)) (|bpEqKey| 'MDEF) - (OR (|bpWhere|) (|bpTrap|)) - (|bpPush| - (|bfMDefinition2| (|bpPop3|) (|bpPop2|) (|bpPop1|))))))) - -(DEFUN |bpMdef| () - (PROG () (RETURN (AND (|bpName|) (|bpStoreName|) (|bpMDefTail|))))) - -(DEFUN |bpWhere| () - (PROG () - (RETURN - (AND (|bpDefinition|) - (OR (AND (|bpEqKey| 'WHERE) - (OR (|bpDefinitionItem|) (|bpTrap|)) - (|bpPush| (|bfWhere| (|bpPop1|) (|bpPop1|)))) - T))))) - -(DEFUN |bpDefinitionItem| () - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|bpState|)) - (COND - ((|bpDDef|) T) - ('T (|bpRestore| |a|) - (COND - ((|bpBDefinitionPileItems|) T) - ('T (|bpRestore| |a|) - (COND - ((|bpPDefinitionItems|) T) - ('T (|bpRestore| |a|) (|bpWhere|))))))))))) - -(DEFUN |bpDefinitionPileItems| () - (PROG () - (RETURN - (AND (|bpListAndRecover| #'|bpDefinitionItem|) - (|bpPush| (|bfDefSequence| (|bpPop1|))))))) - -(DEFUN |bpBDefinitionPileItems| () - (PROG () (RETURN (|bpPileBracketed| #'|bpDefinitionPileItems|)))) - -(DEFUN |bpSemiColonDefinition| () - (PROG () - (RETURN (|bpSemiListing| #'|bpDefinitionItem| #'|bfDefSequence|)))) - -(DEFUN |bpPDefinitionItems| () - (PROG () (RETURN (|bpParenthesized| #'|bpSemiColonDefinition|)))) - -(DEFUN |bpComma| () (PROG () (RETURN (|bpTuple| #'|bpWhere|)))) - -(DEFUN |bpTuple| (|p|) - (PROG () - (RETURN (|bpListofFun| |p| #'|bpCommaBackSet| #'|bfTuple|)))) - -(DEFUN |bpCommaBackSet| () - (PROG () - (RETURN (AND (|bpEqKey| 'COMMA) (OR (|bpEqKey| 'BACKSET) T))))) - -(DEFUN |bpSemiColon| () - (PROG () (RETURN (|bpSemiListing| #'|bpComma| #'|bfSequence|)))) - -(DEFUN |bpSemiListing| (|p| |f|) - (PROG () (RETURN (|bpListofFun| |p| #'|bpSemiBackSet| |f|)))) - -(DEFUN |bpSemiBackSet| () - (PROG () - (RETURN (AND (|bpEqKey| 'SEMICOLON) (OR (|bpEqKey| 'BACKSET) T))))) - -(DEFUN |bpPDefinition| () - (PROG () (RETURN (|bpIndentParenthesized| #'|bpSemiColon|)))) - -(DEFUN |bpPileItems| () - (PROG () - (RETURN - (AND (|bpListAndRecover| #'|bpSemiColon|) - (|bpPush| (|bfSequence| (|bpPop1|))))))) - -(DEFUN |bpBPileDefinition| () - (PROG () (RETURN (|bpPileBracketed| #'|bpPileItems|)))) - -(DEFUN |bpIteratorTail| () - (PROG () (RETURN (AND (OR (|bpEqKey| 'REPEAT) T) (|bpIterators|))))) - -(DEFUN |bpConstruct| () - (PROG () (RETURN (|bpBracket| #'|bpConstruction|)))) - -(DEFUN |bpConstruction| () - (PROG () - (RETURN - (AND (|bpComma|) - (OR (AND (|bpIteratorTail|) - (|bpPush| (|bfCollect| (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfTupleConstruct| (|bpPop1|)))))))) - -(DEFUN |bpDConstruct| () - (PROG () (RETURN (|bpBracket| #'|bpDConstruction|)))) - -(DEFUN |bpDConstruction| () - (PROG () - (RETURN - (AND (|bpComma|) - (OR (AND (|bpIteratorTail|) - (|bpPush| (|bfDCollect| (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfDTuple| (|bpPop1|)))))))) - -(DEFUN |bpPattern| () - (PROG () - (RETURN - (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) - (|bpConstTok|))))) - -(DEFUN |bpEqual| () - (PROG () - (RETURN - (AND (|bpEqKey| 'SHOEEQ) - (OR (|bpApplication|) (|bpConstTok|) (|bpTrap|)) - (|bpPush| (|bfEqual| (|bpPop1|))))))) - -(DEFUN |bpRegularPatternItem| () - (PROG () - (RETURN - (OR (|bpEqual|) (|bpConstTok|) (|bpDot|) - (AND (|bpName|) - (OR (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|)) - (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) - T)) - (|bpBracketConstruct| #'|bpPatternL|))))) - -(DEFUN |bpRegularPatternItemL| () - (PROG () - (RETURN - (AND (|bpRegularPatternItem|) (|bpPush| (LIST (|bpPop1|))))))) - -(DEFUN |bpRegularList| () - (PROG () - (RETURN - (|bpListof| #'|bpRegularPatternItemL| 'COMMA #'|bfAppend|)))) - -(DEFUN |bpPatternColon| () - (PROG () - (RETURN - (AND (|bpEqKey| 'COLON) (OR (|bpRegularPatternItem|) (|bpTrap|)) - (|bpPush| (LIST (|bfColon| (|bpPop1|)))))))) - -(DEFUN |bpPatternL| () - (PROG () - (RETURN (AND (|bpPatternList|) (|bpPush| (|bfTuple| (|bpPop1|))))))) - -(DEFUN |bpPatternList| () - (PROG () - (RETURN - (COND - ((|bpRegularPatternItemL|) - ((LAMBDA () - (LOOP - (COND - ((NOT (AND (|bpEqKey| 'COMMA) - (OR (|bpRegularPatternItemL|) - (PROGN - (OR (AND (|bpPatternTail|) - (|bpPush| - (APPEND (|bpPop2|) (|bpPop1|)))) - (|bpTrap|)) - NIL)))) - (RETURN NIL)) - ('T (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))))))) - T) - ('T (|bpPatternTail|)))))) - -(DEFUN |bpPatternTail| () - (PROG () - (RETURN - (AND (|bpPatternColon|) - (OR (AND (|bpEqKey| 'COMMA) - (OR (|bpRegularList|) (|bpTrap|)) - (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))) - T))))) - -(DEFUN |bpRegularBVItem| () - (PROG () - (RETURN - (OR (|bpBVString|) (|bpConstTok|) - (AND (|bpName|) - (OR (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|)) - (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) - (AND (|bpEqKey| 'IS) (OR (|bpPattern|) (|bpTrap|)) - (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) - T)) - (|bpBracketConstruct| #'|bpPatternL|))))) - -(DEFUN |bpBVString| () - (PROG () - (DECLARE (SPECIAL |$ttok| |$stok|)) - (RETURN - (AND (EQ (|shoeTokType| |$stok|) 'STRING) - (|bpPush| (LIST 'BVQUOTE (INTERN |$ttok|))) (|bpNext|))))) - -(DEFUN |bpRegularBVItemL| () - (PROG () - (RETURN (AND (|bpRegularBVItem|) (|bpPush| (LIST (|bpPop1|))))))) - -(DEFUN |bpColonName| () - (PROG () - (RETURN - (AND (|bpEqKey| 'COLON) - (OR (|bpName|) (|bpBVString|) (|bpTrap|)))))) - -(DEFUN |bpBoundVariablelist| () - (PROG () - (RETURN - (COND - ((|bpRegularBVItemL|) - ((LAMBDA () - (LOOP - (COND - ((NOT (AND (|bpEqKey| 'COMMA) - (OR (|bpRegularBVItemL|) - (PROGN - (OR (AND (|bpColonName|) - (|bpPush| - (|bfColonAppend| (|bpPop2|) - (|bpPop1|)))) - (|bpTrap|)) - NIL)))) - (RETURN NIL)) - ('T (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))))))) - T) - ('T - (AND (|bpColonName|) - (|bpPush| (|bfColonAppend| NIL (|bpPop1|))))))))) - -(DEFUN |bpVariable| () - (PROG () - (RETURN - (OR (AND (|bpParenthesized| #'|bpBoundVariablelist|) - (|bpPush| (|bfTupleIf| (|bpPop1|)))) - (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) - (|bpConstTok|))))) - -(DEFUN |bpAssignVariable| () - (PROG () - (RETURN - (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpAssignLHS|))))) - -(DEFUN |bpAssignLHS| () - (PROG () - (RETURN - (AND (|bpName|) - (OR (AND (|bpEqKey| 'COLON) - (OR (|bpApplication|) (|bpTrap|)) - (|bpPush| (|bfLocal| (|bpPop2|) (|bpPop1|)))) - (AND (|bpEqKey| 'DOT) - (|bpList| #'|bpPrimary| 'DOT #'|bfListOf|) - (|bpChecknull|) - (|bpPush| (|bfTuple| (CONS (|bpPop2|) (|bpPop1|))))) - T))))) - -(DEFUN |bpChecknull| () - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|bpPop1|)) - (COND ((NULL |a|) (|bpTrap|)) ('T (|bpPush| |a|))))))) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/typrops.boot.pamphlet b/src/boot/typrops.boot.pamphlet deleted file mode 100644 index 062d4dd..0000000 --- a/src/boot/typrops.boot.pamphlet +++ /dev/null @@ -1,464 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot typrops.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package 'BOOTTRAN -shoeKeyWords := [ _ - ['"and","AND"] , _ - ['"by", "BY" ], _ - ['"case","CASE"] , _ - ['"cross","CROSS"] , _ - ['"else", "ELSE"] , _ - ['"for", "FOR"] , _ - ['"if", "IF"], _ - ['"in", "IN" ], _ - ['"is", "IS"], _ - ['"isnt", "ISNT"] , _ - ['"of", "OF"] , _ - ['"or", "OR"] , _ - ['"repeat", "REPEAT"] , _ - ['"return", "RETURN"], _ - ['"structure", "STRUCTURE"], _ - ['"then", "THEN"], _ - ['"until", "UNTIL"], _ - ['"where", "WHERE"], _ - ['"while", "WHILE"], _ - ['".", "DOT"], _ - ['":", "COLON"], _ - ['",", "COMMA"], _ - ['";", "SEMICOLON"], _ - ['"*", "TIMES"], _ - ['"**", "POWER"], _ - ['"/", "SLASH"], _ - ['"+", "PLUS"], _ - ['"-", "MINUS"], _ - ['"<", "LT"], _ - ['">", "GT"] , _ - ['"<=","LE" ], _ - ['">=","GE" ], _ - ['"=", "SHOEEQ"], _ - ['"^", "NOT"], _ - ['"^=","NE" ], _ - ['"..","SEG" ], _ - ['"#", "LENGTH"], _ - ['"=>","EXIT" ], _ - ['":=", "BEC"], _ - ['"==", "DEF"], _ - ['"==>","MDEF" ], _ - ['"(", "OPAREN"], _ - ['")", "CPAREN"], _ - ['"(|", "OBRACK"], _ - ['"|)", "CBRACK"], _ - ['"[", "OBRACK"], _ - ['"]", "CBRACK"], _ - ['"suchthat","BAR"], _ - ['"'", "QUOTE"], _ - ['"|", "BAR"] ] - - -shoeKeyTable:=shoeKeyTableCons() - -shoeSPACE := QENUM('" ", 0) - -shoeESCAPE := QENUM('"__ ", 0) -shoeLispESCAPE := QENUM('"! ", 0) - -shoeSTRING_CHAR := QENUM('"_" ", 0) - -shoePLUSCOMMENT := QENUM('"+ ", 0) - -shoeMINUSCOMMENT:= QENUM('"- ", 0) - -shoeDOT := QENUM('". ", 0) - -shoeEXPONENT1 := QENUM('"E ", 0) - -shoeEXPONENT2 := QENUM('"e ", 0) - -shoeCLOSEPAREN := QENUM('") ", 0) - ---shoeCLOSEANGLE := QENUM('"> ", 0) -shoeTAB := 9 - - -shoeDict:=shoeDictCons() - - -shoePun:=shoePunCons() - -for i in [ _ - "NOT", _ --- "COLON", _ --- "SHOEEQ", _ - "LENGTH" _ - ] _ - repeat SETF (GET(i,'SHOEPRE),'T) - -for i in [ _ - ["SHOEEQ" ,"="], _ - ["TIMES" ,"*"], _ - ["PLUS" ,"+"], _ - ["IS" ,"is"], _ - ["ISNT" ,"isnt"], _ - ["AND" ,"and"], _ - ["OR" ,"or"], _ - ["SLASH" ,"/"], _ - ["POWER" ,"**"], _ - ["MINUS" ,"-"], _ - ["LT" ,"<"], _ - ["GT" ,">"], _ - ["LE" ,"<="], _ - ["GE" ,">="], _ - ["NE" ,"^="] _ - ]_ - repeat SETF (GET(CAR i,'SHOEINF),CADR i) - - -for i in [ _ - ["+", 0] , _ - ["gcd", 0] , _ - ["lcm", 1] , _ - ["STRCONC", '""] , _ - ["strconc", '""] , _ - ["MAX", -999999] , _ - ["MIN", 999999] , _ - ["*", 1] , _ - ["times", 1] , _ - ["CONS", NIL] , _ - ["APPEND", NIL] , _ - ["append", NIL] , _ - ["UNION", NIL] , _ - ["UNIONQ", NIL] , _ - ["union", NIL] , _ - ["NCONC", NIL] , _ - ["and", 'T] , _ - ["or", NIL] , _ - ["AND", 'T] , _ - ["OR", NIL] _ - ] - - repeat SETF (GET(CAR i,'SHOETHETA),CDR i) -for i in [ _ - ["and", "AND"] , _ - ["append", "APPEND"] , _ - ["apply", "APPLY"] , _ - ["atom", "ATOM"] , _ - ["car", "CAR"] , _ - ["cdr", "CDR"] , _ - ["cons", "CONS"] , _ - ["copy", "COPY"] , _ - ["croak", "CROAK"] , _ - ["drop", "DROP"] , _ - ["exit", "EXIT"] , _ - ["false", 'NIL] , _ - ["first", "CAR"] , _ - ["function","FUNCTION"] , _ - ["genvar", "GENVAR"] , _ - ["IN", "MEMBER"] , _ - ["is", "IS"] , _ - ["isnt", "ISNT"] , _ - ["lastNode", "LAST"] , _ - ["LAST", "last"] , _ - ["list", "LIST"] , _ - ["member", "MEMBER"] , _ - ["mkpf", "MKPF"] , _ - ["nconc", "NCONC"] , _ - ["nil" ,NIL ] , _ - ["not", "NULL"] , _ - ["NOT", "NULL"] , _ - ["nreverse", "NREVERSE"] , _ - ["null", "NULL"] , _ - ["or", "OR"] , _ - ["otherwise", "T"] , _ - ["PAIRP", "CONSP"] , _ - ["removeDuplicates", "REMDUP"] , _ - ["rest", "CDR"] , _ - ["reverse", "REVERSE"] , _ - ["setDifference", "SETDIFFERENCE"] , _ - ["setIntersection", "INTERSECTION"] , _ - ["setPart", "SETELT"] , _ - ["setUnion", "UNION"] , _ - ["size", "SIZE"] , _ - ["strconc", "CONCAT"] , _ - ["substitute", "SUBST"] , _ - ["take", "TAKE"] , _ - ["true", "T"] , _ - ["PLUS", "+"] , _ - ["MINUS", "-"] , _ - ["TIMES", "*"] , _ - ["POWER", "EXPT"] , _ - ["SLASH", "/"] , _ - ["LT", "<"], _ - ["GT", ">"] , _ - ["LE", "<="], _ - ["GE", ">="], _ - ["SHOEEQ", "EQUAL"], _ - ["NE", "/="], _ - ["T", "T$"] _ - ] - repeat SETF (GET(CAR i,'SHOERENAME),CDR i) - -for i in [ _ - ["setName", 0] , _ - ["setLabel", 1] , _ - ["setLevel", 2] , _ - ["setType", 3] , _ - ["setVar", 4] , _ - ["setLeaf", 5] , _ - ["setDef", 6] , _ - ["aGeneral", 4] , _ - ["aMode", 1] , _ - ["aModeSet", 3] , _ - ["aTree", 0] , _ - ["aValue", 2] , _ - ["attributes", "CADDR"] , _ - ["cacheCount", "CADDDDR"] , _ - ["cacheName", "CADR"] , _ - ["cacheReset", "CADDDR"] , _ - ["cacheType", "CADDR"] , _ - ["env", "CADDR"] , _ - ["expr", "CAR"] , _ - ["CAR", "CAR"] , _ - ["mmCondition", "CAADR"] , _ - ["mmDC", "CAAR"] , _ - ["mmImplementation","CADADR"] , _ - ["mmSignature", "CDAR"] , _ - ["mmTarget", "CADAR"] , _ - ["mode", "CADR"] , _ - ["op", "CAR"] , _ - ["opcode", "CADR"] , _ - ["opSig", "CADR"] , _ - ["CDR", "CDR"] , _ - ["sig", "CDDR"] , _ - ["source", "CDR"] , _ - ["streamCode", "CADDDR"] , _ - ["streamDef", "CADDR"] , _ - ["streamName", "CADR"] , _ - ["target", "CAR"] _ - ] _ - repeat SETF (GET(CAR i,'SHOESELFUNCTION),CADR i) -@ -<>= - -(IN-PACKAGE 'BOOTTRAN) - -(EVAL-WHEN (EVAL LOAD) - (SETQ |shoeKeyWords| - (LIST (LIST "and" 'AND) (LIST "by" 'BY) (LIST "case" 'CASE) - (LIST "cross" 'CROSS) (LIST "else" 'ELSE) - (LIST "for" 'FOR) (LIST "if" 'IF) (LIST "in" 'IN) - (LIST "is" 'IS) (LIST "isnt" 'ISNT) (LIST "of" 'OF) - (LIST "or" 'OR) (LIST "repeat" 'REPEAT) - (LIST "return" 'RETURN) (LIST "structure" 'STRUCTURE) - (LIST "then" 'THEN) (LIST "until" 'UNTIL) - (LIST "where" 'WHERE) (LIST "while" 'WHILE) - (LIST "." 'DOT) (LIST ":" 'COLON) (LIST "," 'COMMA) - (LIST ";" 'SEMICOLON) (LIST "*" 'TIMES) - (LIST "**" 'POWER) (LIST "/" 'SLASH) (LIST "+" 'PLUS) - (LIST "-" 'MINUS) (LIST "<" 'LT) (LIST ">" 'GT) - (LIST "<=" 'LE) (LIST ">=" 'GE) (LIST "=" 'SHOEEQ) - (LIST "^" 'NOT) (LIST "^=" 'NE) (LIST ".." 'SEG) - (LIST "#" 'LENGTH) (LIST "=>" 'EXIT) (LIST ":=" 'BEC) - (LIST "==" 'DEF) (LIST "==>" 'MDEF) (LIST "(" 'OPAREN) - (LIST ")" 'CPAREN) (LIST "(|" 'OBRACK) - (LIST "|)" 'CBRACK) (LIST "[" 'OBRACK) (LIST "]" 'CBRACK) - (LIST "suchthat" 'BAR) (LIST "'" 'QUOTE) (LIST "|" 'BAR)))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeKeyTable| (|shoeKeyTableCons|))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeSPACE| (QENUM " " 0))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeESCAPE| (QENUM "_ " 0))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeLispESCAPE| (QENUM "! " 0))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeSTRINGCHAR| (QENUM "\" " 0))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoePLUSCOMMENT| (QENUM "+ " 0))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeMINUSCOMMENT| (QENUM "- " 0))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeDOT| (QENUM ". " 0))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeEXPONENT1| (QENUM "E " 0))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeEXPONENT2| (QENUM "e " 0))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeCLOSEPAREN| (QENUM ") " 0))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeTAB| 9)) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoeDict| (|shoeDictCons|))) - -(EVAL-WHEN (EVAL LOAD) (SETQ |shoePun| (|shoePunCons|))) - -(EVAL-WHEN (EVAL LOAD) - (PROG () - (RETURN - ((LAMBDA (|bfVar#1| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#1|) - (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)) - (RETURN NIL)) - ('T (SETF (GET |i| 'SHOEPRE) 'T))) - (SETQ |bfVar#1| (CDR |bfVar#1|)))) - (LIST 'NOT 'LENGTH) NIL)))) - -(EVAL-WHEN (EVAL LOAD) - (PROG () - (RETURN - ((LAMBDA (|bfVar#2| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#2|) - (PROGN (SETQ |i| (CAR |bfVar#2|)) NIL)) - (RETURN NIL)) - ('T (SETF (GET (CAR |i|) 'SHOEINF) (CADR |i|)))) - (SETQ |bfVar#2| (CDR |bfVar#2|)))) - (LIST (LIST 'SHOEEQ '=) (LIST 'TIMES '*) (LIST 'PLUS '+) - (LIST 'IS '|is|) (LIST 'ISNT '|isnt|) (LIST 'AND '|and|) - (LIST 'OR '|or|) (LIST 'SLASH '/) (LIST 'POWER '**) - (LIST 'MINUS '-) (LIST 'LT '<) (LIST 'GT '>) - (LIST 'LE '<=) (LIST 'GE '>=) (LIST 'NE '^=)) - NIL)))) - -(EVAL-WHEN (EVAL LOAD) - (PROG () - (RETURN - ((LAMBDA (|bfVar#3| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#3|) - (PROGN (SETQ |i| (CAR |bfVar#3|)) NIL)) - (RETURN NIL)) - ('T (SETF (GET (CAR |i|) 'SHOETHETA) (CDR |i|)))) - (SETQ |bfVar#3| (CDR |bfVar#3|)))) - (LIST (LIST '+ 0) (LIST '|gcd| 0) (LIST '|lcm| 1) - (LIST 'STRCONC "") (LIST '|strconc| "") - (LIST 'MAX (- 999999)) (LIST 'MIN 999999) (LIST '* 1) - (LIST '|times| 1) (LIST 'CONS NIL) (LIST 'APPEND NIL) - (LIST '|append| NIL) (LIST 'UNION NIL) (LIST 'UNIONQ NIL) - (LIST '|union| NIL) (LIST 'NCONC NIL) (LIST '|and| 'T) - (LIST '|or| NIL) (LIST 'AND 'T) (LIST 'OR NIL)) - NIL)))) - -(EVAL-WHEN (EVAL LOAD) - (PROG () - (RETURN - ((LAMBDA (|bfVar#4| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#4|) - (PROGN (SETQ |i| (CAR |bfVar#4|)) NIL)) - (RETURN NIL)) - ('T (SETF (GET (CAR |i|) 'SHOERENAME) (CDR |i|)))) - (SETQ |bfVar#4| (CDR |bfVar#4|)))) - (LIST (LIST '|and| 'AND) (LIST '|append| 'APPEND) - (LIST '|apply| 'APPLY) (LIST '|atom| 'ATOM) - (LIST '|car| 'CAR) (LIST '|cdr| 'CDR) (LIST '|cons| 'CONS) - (LIST '|copy| 'COPY) (LIST '|croak| 'CROAK) - (LIST '|drop| 'DROP) (LIST '|exit| 'EXIT) - (LIST '|false| 'NIL) (LIST '|first| 'CAR) - (LIST '|function| 'FUNCTION) (LIST '|genvar| 'GENVAR) - (LIST 'IN 'MEMBER) (LIST '|is| 'IS) (LIST '|isnt| 'ISNT) - (LIST '|lastNode| 'LAST) (LIST 'LAST '|last|) - (LIST '|list| 'LIST) (LIST '|member| 'MEMBER) - (LIST '|mkpf| 'MKPF) (LIST '|nconc| 'NCONC) - (LIST '|nil| NIL) (LIST '|not| 'NULL) (LIST 'NOT 'NULL) - (LIST '|nreverse| 'NREVERSE) (LIST '|null| 'NULL) - (LIST '|or| 'OR) (LIST '|otherwise| 'T) - (LIST 'PAIRP 'CONSP) (LIST '|removeDuplicates| 'REMDUP) - (LIST '|rest| 'CDR) (LIST '|reverse| 'REVERSE) - (LIST '|setDifference| 'SETDIFFERENCE) - (LIST '|setIntersection| 'INTERSECTION) - (LIST '|setPart| 'SETELT) (LIST '|setUnion| 'UNION) - (LIST '|size| 'SIZE) (LIST '|strconc| 'CONCAT) - (LIST '|substitute| 'SUBST) (LIST '|take| 'TAKE) - (LIST '|true| 'T) (LIST 'PLUS '+) (LIST 'MINUS '-) - (LIST 'TIMES '*) (LIST 'POWER 'EXPT) (LIST 'SLASH '/) - (LIST 'LT '<) (LIST 'GT '>) (LIST 'LE '<=) (LIST 'GE '>=) - (LIST 'SHOEEQ 'EQUAL) (LIST 'NE '/=) (LIST 'T 'T$)) - NIL)))) - -(EVAL-WHEN (EVAL LOAD) - (PROG () - (RETURN - ((LAMBDA (|bfVar#5| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#5|) - (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL)) - (RETURN NIL)) - ('T (SETF (GET (CAR |i|) 'SHOESELFUNCTION) (CADR |i|)))) - (SETQ |bfVar#5| (CDR |bfVar#5|)))) - (LIST (LIST '|setName| 0) (LIST '|setLabel| 1) - (LIST '|setLevel| 2) (LIST '|setType| 3) - (LIST '|setVar| 4) (LIST '|setLeaf| 5) (LIST '|setDef| 6) - (LIST '|aGeneral| 4) (LIST '|aMode| 1) - (LIST '|aModeSet| 3) (LIST '|aTree| 0) (LIST '|aValue| 2) - (LIST '|attributes| 'CADDR) (LIST '|cacheCount| 'CADDDDR) - (LIST '|cacheName| 'CADR) (LIST '|cacheReset| 'CADDDR) - (LIST '|cacheType| 'CADDR) (LIST '|env| 'CADDR) - (LIST '|expr| 'CAR) (LIST 'CAR 'CAR) - (LIST '|mmCondition| 'CAADR) (LIST '|mmDC| 'CAAR) - (LIST '|mmImplementation| 'CADADR) - (LIST '|mmSignature| 'CDAR) (LIST '|mmTarget| 'CADAR) - (LIST '|mode| 'CADR) (LIST '|op| 'CAR) - (LIST '|opcode| 'CADR) (LIST '|opSig| 'CADR) - (LIST 'CDR 'CDR) (LIST '|sig| 'CDDR) (LIST '|source| 'CDR) - (LIST '|streamCode| 'CADDDR) (LIST '|streamDef| 'CADDR) - (LIST '|streamName| 'CADR) (LIST '|target| 'CAR)) - NIL)))) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/boot/tytree1.boot.pamphlet b/src/boot/tytree1.boot.pamphlet deleted file mode 100644 index 2309ce5..0000000 --- a/src/boot/tytree1.boot.pamphlet +++ /dev/null @@ -1,2754 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/boot tytree1.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -Note that shoeReadLispString has a duplicate definition in this file. -I don't know why. I've commented out the first definition since it -gets overwritten. -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package 'BOOTTRAN - -bfGenSymbol()== - $GenVarCounter:=$GenVarCounter+1 - INTERN(CONCAT ('"bfVar#",STRINGIMAGE $GenVarCounter)) - -bfListOf x==x - -bfColon x== ["COLON",x] - -bfSymbol x== - STRINGP x=> x - ['QUOTE,x] - -bfDot()== "DOT" - -bfSuffixDot x==[x,"DOT"] - -bfEqual(name)== ["EQUAL",name] - -bfBracket(part) == part - -bfPile(part) == part - -bfAppend x== APPLY(function APPEND,x) - -bfColonAppend (x,y) == - if null x - then - if y is ["BVQUOTE",:a] - then ["&REST",["QUOTE",:a]] - else ["&REST",y] - else cons(CAR x,bfColonAppend(CDR x,y)) - -bfDefinition1(bflhsitems, bfrhs) == - ['DEF, bflhsitems,bfTuple nil, bfrhs] - -bfDefinition2(bflhsitems, bfrhs,body) == - ['DEF,bflhsitems,bfrhs,body] - -bfMDefinition2(bflhsitems, bfrhs,body) == - bfMDef('MDEF,bflhsitems,bfrhs,body) - -bfCompDef [def,op,args,body]== bfDef(def,op,args,body) - -bfBeginsDollar x== EQL('"$".0,(PNAME x).0) - -compFluid id== ["FLUID",id] - -compFluidize x== - IDENTP x and bfBeginsDollar x=>compFluid x - ATOM x =>x - EQCAR(x,"QUOTE")=>x - cons(compFluidize(CAR x),compFluidize(CDR x)) - -bfTuple x== ["TUPLE",:x] - -bfTupleP x==EQCAR(x,"TUPLE") - -bfTupleIf x== - if bfTupleP x - then x - else bfTuple x - -bfTupleConstruct b == - a:= if bfTupleP b - then cdr b - else [b] - or/[x is ["COLON",.] for x in a] => bfMakeCons a - ["LIST",:a] - -bfConstruct b == - a:= if bfTupleP b - then cdr b - else [b] - bfMakeCons a - -bfMakeCons l == - null l => NIL - l is [["COLON",a],:l1] => - l1 => ['APPEND,a,bfMakeCons l1] - a - ['CONS,first l,bfMakeCons rest l] - -bfFor(bflhs,U,step) == - if EQCAR (U,'tails) - then bfForTree('ON, bflhs, CADR U) - else - if EQCAR(U,"SEGMENT") - then bfSTEP(bflhs,CADR U,step,CADDR U) - else bfForTree('IN, bflhs, U) - -bfForTree(OP,lhs,whole)== - whole:=if bfTupleP whole then bfMakeCons cdr whole else whole - ATOM lhs =>bfINON [OP,lhs,whole] - lhs:=if bfTupleP lhs then CADR lhs else lhs - EQCAR(lhs,"L%T") => - G:=CADR lhs - [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,CADDR lhs)] - G:=bfGenSymbol() - [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,lhs)] - - -bfSTEP(id,fst,step,lst)== - initvar:=[id] - initval:=[fst] - inc:=if ATOM step - then step - else - g1:=bfGenSymbol() - initvar:=cons(g1,initvar) - initval:=cons(step,initval) - g1 - final:=if ATOM lst - then lst - else - g2:=bfGenSymbol() - initvar:=cons(g2,initvar) - initval:=cons(lst,initval) - g2 - ex:= - null lst=> [] - INTEGERP inc => - pred:=if MINUSP inc then "<" else ">" - [[pred,id,final]] - [['COND,[['MINUSP,inc], - ["<",id,final]],['T,[">",id,final]]]] - suc:=[['SETQ,id,["+",id,inc]]] - [[initvar,initval,suc,[],ex,[]]] - - -bfINON x== - [op,id,whole]:=x - if EQ(op,"ON") - then bfON(id,whole) - else bfIN(id,whole) - -bfIN(x,E)== - g:=bfGenSymbol() - [[[g,x],[E,nil],[['SETQ,g,['CDR, g]]],[], - [['OR,['ATOM,g],['PROGN,['SETQ,x,['CAR,g]] ,'NIL]]],[]]] - -bfON(x,E)== - [[[x],[E],[['SETQ,x,['CDR, x]]],[], - [['ATOM,x]],[]]] - -bfSuchthat p== [[[],[],[],[p],[],[]]] - -bfWhile p== [[[],[],[],[],[bfNOT p],[]]] - -bfUntil p== - g:=bfGenSymbol() - [[[g],[nil],[['SETQ,g,p]],[],[g],[]]] - -bfIterators x==["ITERATORS",:x] - -bfCross x== ["CROSS",:x] - -bfLp(iters,body)== - EQCAR (iters,"ITERATORS")=>bfLp1(CDR iters,body) - bfLpCross(CDR iters,body) - -bfLpCross(iters,body)== - if null cdr iters - then bfLp(car iters,body) - else bfLp(car iters,bfLpCross(cdr iters,body)) - -bfSep(iters)== - if null iters - then [[],[],[],[],[],[]] - else - f:=first iters - r:=bfSep rest iters - [append(i,j) for i in f for j in r] - -bfReduce(op,y)== - a:=if EQCAR(op,"QUOTE") then CADR op else op - op:=bfReName a - init:=GET(op,"SHOETHETA") - g:=bfGenSymbol() - g1:=bfGenSymbol() - body:=['SETQ,g,[op,g1,g]] - if null init - then - g2:=bfGenSymbol() - init:=['CAR,g2] - ny:=['CDR,g2] - it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,ny)]] - bfMKPROGN [['L%T,g2,y],bfLp(it,body)] - else - init:=car init - it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,y)]] - bfLp(it,body) - -bfReduceCollect(op,y)== - if EQCAR (y,"COLLECT") - then - body:=y.1 - itl:=y.2 - a:=if EQCAR(op,"QUOTE") then CADR op else op - op:=bfReName a - init:=GET(op,"SHOETHETA") - bfOpReduce(op,init,body,itl) - else - a:=bfTupleConstruct (y.1) - bfReduce(op,a) - --- delayed collect - -bfDCollect(y,itl)== ["COLLECT",y,itl] - -bfDTuple x== ["DTUPLE",x] - -bfCollect(y,itl) == - y is ["COLON",a] => bf0APPEND(a,itl) - y is ["TUPLE",:.] => - newBody:=bfConstruct y - bf0APPEND(newBody,itl) - bf0COLLECT(y,itl) - -bf0COLLECT(y,itl)==bfListReduce('CONS,y,itl) - - -bf0APPEND(y,itl)== - g:=bfGenSymbol() - body:=['SETQ,g,['APPEND,['REVERSE,y],g]] - extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]] - bfLp2(extrait,itl,body) - -bfListReduce(op,y,itl)== - g:=bfGenSymbol() - body:=['SETQ,g,[op,y,g]] - extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]] - bfLp2(extrait,itl,body) - -bfLp1(iters,body)== - [vars,inits,sucs,filters,exits,value]:=bfSep bfAppend iters - nbody:=if null filters then body else bfAND [:filters,body] - value:=if null value then "NIL" else car value - exits:= ["COND",[bfOR exits,["RETURN",value]], - ['(QUOTE T),nbody]] - loop:= - [["LAMBDA",vars, - ["LOOP",exits,:sucs]],:inits] - loop - -bfLp2(extrait,itl,body)== - EQCAR (itl,"ITERATORS")=>bfLp1(cons(extrait,CDR itl),body) - iters:=cdr itl - bfLpCross - ([["ITERATORS",extrait,:CDAR iters],:CDR iters],body) - -bfOpReduce(op,init,y,itl)== - g:=bfGenSymbol() - body:= - EQ(op,"AND")=> - bfMKPROGN [["SETQ",g,y], - ['COND, [['NOT,g],['RETURN,'NIL]]]] - EQ(op,"OR") => - bfMKPROGN [["SETQ",g,y], - ['COND, [g,['RETURN,g]]]] - ['SETQ,g,[op,g,y]] - if null init - then - g1:=bfGenSymbol() - init:=['CAR,g1] - y:=['CDR,g1] - extrait:= [[[g],[init],[],[],[],[g]]] - bfMKPROGN [['L%T,g1,y],bfLp2(extrait,itl,body)] - else - init:=car init - extrait:= [[[g],[init],[],[],[],[g]]] - bfLp2(extrait,itl,body) - -bfLoop1 body == bfLp (bfIterators nil,body) - -bfSegment1(lo)== ["SEGMENT",lo,nil] - -bfSegment2(lo,hi)== ["SEGMENT",lo,hi] - -bfForInBy(variable,collection,step)== - bfFor(variable,collection,step) - -bfForin(lhs,U)==bfFor(lhs,U,1) - -bfLocal(a,b)== - EQ(b,"FLUID")=> compFluid a - EQ(b,"fluid")=> compFluid a - EQ(b,"local") => compFluid a - -- $typings:=cons(["TYPE",b,a],$typings) - a - -bfTake(n,x)== - null x=>x - n=0 => nil - cons(car x,bfTake(n-1,cdr x)) - -bfDrop(n,x)== - null x or n=0 =>x - bfDrop(n-1,cdr x) - -bfDefSequence l == ['SEQ,: l] - -bfReturnNoName a == - ["RETURN",a] - -bfSUBLIS(p,e)== - ATOM e=>bfSUBLIS1(p,e) - EQCAR(e,"QUOTE")=>e - cons(bfSUBLIS(p,car e),bfSUBLIS(p,cdr e)) - -bfSUBLIS1(p,e)== - null p =>e - f:=CAR p - EQ(CAR f,e)=>CDR f - bfSUBLIS1(cdr p,e) - -defSheepAndGoats(x)== - EQCAR (x,"DEF") => - [def,op,args,body]:=x - argl:=if bfTupleP args - then cdr args - else [args] - if null argl - then - opassoc:=[[op,:body]] - [opassoc,[],[]] - else - op1:=INTERN CONCAT(PNAME $op,'",",PNAME op) - opassoc:=[[op,:op1]] - defstack:=[["DEF",op1,args,body]] - [opassoc,defstack,[]] - EQCAR (x,"SEQ") => defSheepAndGoatsList(cdr x) - [[],[],[x]] - -defSheepAndGoatsList(x)== - if null x - then [[],[],[]] - else - [opassoc,defs,nondefs] := defSheepAndGoats car x - [opassoc1,defs1,nondefs1] := defSheepAndGoatsList cdr x - [append(opassoc,opassoc1),append(defs,defs1), - append(nondefs,nondefs1)] ---% LET - -bfLetForm(lhs,rhs) == ['L%T,lhs,rhs] - -bfLET1(lhs,rhs) == - IDENTP lhs => bfLetForm(lhs,rhs) - lhs is ['FLUID,.] => bfLetForm(lhs,rhs) - IDENTP rhs and not bfCONTAINED(rhs,lhs) => - rhs1 := bfLET2(lhs,rhs) - EQCAR(rhs1,'L%T) => bfMKPROGN [rhs1,rhs] - EQCAR(rhs1,'PROGN) => APPEND(rhs1,[rhs]) - if IDENTP CAR rhs1 then rhs1 := CONS(rhs1,NIL) - bfMKPROGN [:rhs1,rhs] - CONSP(rhs) and EQCAR(rhs,'L%T) and IDENTP(name := CADR rhs) => - -- handle things like [a] := x := foo - l1 := bfLET1(name,CADDR rhs) - l2 := bfLET1(lhs,name) - EQCAR(l2,'PROGN) => bfMKPROGN [l1,:CDR l2] - if IDENTP CAR l2 then l2 := cons(l2,nil) - bfMKPROGN [l1,:l2,name] - g := INTERN CONCAT('"LETTMP#",STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - rhs1 := ['L%T,g,rhs] - let1 := bfLET1(lhs,g) - EQCAR(let1,'PROGN) => bfMKPROGN [rhs1,:CDR let1] - if IDENTP CAR let1 then let1 := CONS(let1,NIL) - bfMKPROGN [rhs1,:let1,g] - -bfCONTAINED(x,y)== - EQ(x,y) => true - ATOM y=> false - bfCONTAINED(x,car y) or bfCONTAINED(x,cdr y) - -bfLET2(lhs,rhs) == - IDENTP lhs => bfLetForm(lhs,rhs) - NULL lhs => NIL - lhs is ['FLUID,.] => bfLetForm(lhs,rhs) - lhs is ['L%T,a,b] => - a := bfLET2(a,rhs) - null (b := bfLET2(b,rhs)) => a - ATOM b => [a,b] - CONSP CAR b => CONS(a,b) - [a,b] - lhs is ['CONS,var1,var2] => - var1 = "DOT" or (CONSP(var1) and EQCAR(var1,'QUOTE)) => - bfLET2(var2,addCARorCDR('CDR,rhs)) - l1 := bfLET2(var1,addCARorCDR('CAR,rhs)) - null var2 or EQ(var2,"DOT") =>l1 - if CONSP l1 and ATOM CAR l1 then l1 := cons(l1,nil) - IDENTP var2 => - [:l1,bfLetForm(var2,addCARorCDR('CDR,rhs))] - l2 := bfLET2(var2,addCARorCDR('CDR,rhs)) - if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - APPEND(l1,l2) - lhs is ['APPEND,var1,var2] => - patrev := bfISReverse(var2,var1) - rev := ['REVERSE,rhs] - g := INTERN CONCAT('"LETTMP#", STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - l2 := bfLET2(patrev,g) - if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - var1 = "DOT" => [['L%T,g,rev],:l2] - last l2 is ['L%T, =var1, val1] => - [['L%T,g,rev],:REVERSE CDR REVERSE l2, - bfLetForm(var1,['NREVERSE,val1])] - [['L%T,g,rev],:l2,bfLetForm(var1,['NREVERSE,var1])] - lhs is ["EQUAL",var1] => - ['COND,[["EQUAL",var1,rhs],var1]] - bpSpecificErrorHere '"unexpected LET code is generated in this line" - REALLYPRETTYPRINT lhs - bpTrap() - --- -- let the IS code take over from here --- REALLYPRETTYPRINT lhs --- isPred := --- $inDefIS => bfIS1(rhs,lhs) --- bfIS(rhs,lhs) --- REALLYPRETTYPRINT ['COND,[isPred,rhs]] --- ['COND,[isPred,rhs]] - -bfLET(lhs,rhs) == - $letGenVarCounter : local := 1 --- $inbfLet : local := true - bfLET1(lhs,rhs) - -addCARorCDR(acc,expr) == - NULL CONSP expr => [acc,expr] - acc = 'CAR and EQCAR(expr,'REVERSE) => - ["CAR",["LAST",:CDR expr]] - -- cons('last,CDR expr) - funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR - CDAAR CDDAR CDADR CDDDR) - p := bfPosition(CAR expr,funs) - p = -1 => [acc,expr] - funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR - CAADDR CADAAR CADDAR CADADR CADDDR) - funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR - CDADDR CDDAAR CDDDAR CDDADR CDDDDR) - if acc = 'CAR then CONS(funsA.p,CDR expr) - else CONS(funsR.p,CDR expr) - -bfPosition(x,l) == bfPosn(x,l,0) -bfPosn(x,l,n) == - null l => -1 - x=first l => n - bfPosn(x,rest l,n+1) - ---% IS - -bfISApplication(op,left,right)== - EQ(op ,"IS") => bfIS(left,right) - EQ(op ,"ISNT") => bfNOT bfIS(left,right) - [op ,left,right] - -bfIS(left,right)== - $isGenVarCounter:local :=1 - $inDefIS :local :=true - bfIS1(left,right) - -bfISReverse(x,a) == - x is ['CONS,:.] => - NULL CADDR x => ['CONS,CADR x, a] - y := bfISReverse(CADDR x, NIL) - RPLACA(CDDR y,['CONS,CADR x,a]) - y - bpSpecificErrorHere '"Error in bfISReverse" - bpTrap() - -bfIS1(lhs,rhs) == - NULL rhs => - ['NULL,lhs] - STRINGP rhs => - ['EQ,lhs,['QUOTE,INTERN rhs]] - NUMBERP rhs => - ["EQUAL",lhs,rhs] - ATOM rhs => - ['PROGN,bfLetForm(rhs,lhs),''T] - rhs is ['QUOTE,a] => - IDENTP a => ['EQ,lhs,rhs] - ["EQUAL",lhs,rhs] - rhs is ['L%T,c,d] => - l := - bfLET(c,lhs) --- $inbfLet => bfLET1(c,lhs) --- bfLET(c,lhs) - ['AND,bfIS1(lhs,d),bfMKPROGN [l,''T]] - rhs is ["EQUAL",a] => - ["EQUAL",lhs,a] - CONSP lhs => - g := INTERN CONCAT('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - bfMKPROGN [['L%T,g,lhs],bfIS1(g,rhs)] - rhs is ['CONS,a,b] => - a = "DOT" => - NULL b => - ['AND,['CONSP,lhs], - ['EQ,['CDR,lhs],'NIL]] - ['AND,['CONSP,lhs], - bfIS1(['CDR,lhs],b)] - NULL b => - ['AND,['CONSP,lhs], - ['EQ,['CDR,lhs],'NIL],_ - bfIS1(['CAR,lhs],a)] - b = "DOT" => - ['AND,['CONSP,lhs],bfIS1(['CAR,lhs],a)] - a1 := bfIS1(['CAR,lhs],a) - b1 := bfIS1(['CDR,lhs],b) - a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] => - ['AND,['CONSP,lhs],bfMKPROGN [c,:cls]] - ['AND,['CONSP,lhs],a1,b1] - rhs is ['APPEND,a,b] => - patrev := bfISReverse(b,a) - g := INTERN CONCAT('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - rev := ['AND,['CONSP,lhs],['PROGN,['L%T,g,['REVERSE,lhs]],''T]] - l2 := bfIS1(g,patrev) - if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - a = "DOT" => ['AND,rev,:l2] - ['AND,rev,:l2,['PROGN,bfLetForm(a,['NREVERSE,a]),''T]] - bpSpecificErrorHere '"bad IS code is generated" - bpTrap() - -bfApplication(bfop, bfarg) == - if bfTupleP bfarg - then cons(bfop,CDR bfarg) - else cons(bfop,[bfarg]) - - -bfReName x== - a:=GET(x,"SHOERENAME") - if a - then car a - else x - -bfInfApplication(op,left,right)== - EQ(op,"EQUAL") => bfQ(left,right) - EQ(op,"/=") => bfNOT bfQ(left,right) - EQ(op,">") => bfLessp(right,left) - EQ(op,"<") => bfLessp(left,right) - EQ(op,"<=") => bfNOT bfLessp(right,left) - EQ(op,">=") => bfNOT bfLessp(left,right) - EQ(op,"OR") => bfOR [left,right] - EQ(op,"AND") => bfAND [left,right] - [op,left,right] - -bfNOT x== - x is ["NOT",a]=> a - x is ["NULL",a]=> a - ["NOT",x] - -bfFlatten(op, x) == - EQCAR(x,op) => CDR x - [x] - -bfOR l == - null l => NIL - null cdr l => CAR l - ["OR",:[:bfFlatten("OR",c) for c in l]] - -bfAND l == - null l=> 'T - null cdr l => CAR l - ["AND",:[:bfFlatten("AND",c) for c in l]] - - -defQuoteId x== EQCAR(x,"QUOTE") and IDENTP CADR x - -bfSmintable x== - INTEGERP x or CONSP x and - MEMQ(CAR x, '(SIZE LENGTH)) - -bfQ(l,r)== - if bfSmintable l or bfSmintable r - then ["EQL",l,r] - else if defQuoteId l or defQuoteId r - then ["EQ",l,r] - else - if null l - then ["NULL",r] - else if null r - then ["NULL",l] - else ["EQUAL",l,r] - -bfLessp(l,r)== - if r=0 - then ["MINUSP", l] - else ["<",l,r] - -bfMDef (defOp,op,args,body) == - argl:=if bfTupleP args then cdr args else [args] - [gargl,sgargl,nargl,largl]:=bfGargl argl - sb:=[cons(i,j) for i in nargl for j in sgargl] - body:= SUBLIS(sb,body) - sb2 := [["CONS",["QUOTE",i],j] for i in sgargl for j in largl] - body := ["SUBLIS",["LIST",:sb2],["QUOTE",body]] - lamex:= ["MLAMBDA",gargl,body] - def:= [op,lamex] - bfTuple - cons(shoeComp def,[:shoeComps bfDef1 d for d in $wheredefs]) - -bfGargl argl== - if null argl - then [[],[],[],[]] - else - [a,b,c,d]:=bfGargl cdr argl - if car argl="&REST" - then [cons(car argl,b),b,c, - cons(["CONS",["QUOTE","LIST"],car d],cdr d)] - else - f:=bfGenSymbol() - [cons(f,a),cons(f,b),cons(car argl,c),cons(f,d)] - -bfDef1 [defOp,op,args,body] == - argl:=if bfTupleP args then cdr args else [args] - [quotes,control,arglp,body]:=bfInsertLet (argl,body) - quotes=>shoeLAM(op,arglp,control,body) - [[op,["LAMBDA",arglp,body]]] - -shoeLAM (op,args,control,body)== - margs :=bfGenSymbol() - innerfunc:=INTERN(CONCAT(PNAME op,",LAM")) - [[innerfunc,["LAMBDA",args,body]], - [op,["MLAMBDA",["&REST",margs],["CONS",["QUOTE", innerfunc], - ["WRAP",margs, ["QUOTE", control]]]]]] - -bfDef(defOp,op,args,body) == - $bfClamming => - [.,op1,arg1,:body1]:=shoeComp first bfDef1 [defOp,op,args,body] - bfCompHash(op1,arg1,body1) - bfTuple - [:shoeComps bfDef1 d for d in cons([defOp,op,args,body],$wheredefs)] - -shoeComps x==[shoeComp def for def in x] -shoeComp x== - a:=shoeCompTran CADR x - if EQCAR(a,"LAMBDA") - then ["DEFUN",CAR x,CADR a,:CDDR a] - else ["DEFMACRO",CAR x,CADR a,:CDDR a] - -bfInsertLet(x,body)== - if null x - then [false,nil,x,body] - else - if x is ["&REST",a] - then if a is ["QUOTE",b] - then [true,"QUOTE",["&REST",b],body] - else [false,nil,x,body] - else - [b,norq,name1,body1]:= bfInsertLet1 (car x,body) - [b1,norq1,name2,body2]:= bfInsertLet (cdr x,body1) - [b or b1,cons(norq,norq1),cons(name1,name2),body2] - -bfInsertLet1(y,body)== - if y is ["L%T",l,r] - then [false,nil,l,bfMKPROGN [bfLET(r,l),body]] - else if IDENTP y - then [false,nil,y,body] - else - if y is ["BVQUOTE",b] - then [true,"QUOTE",b,body] - else - g:=bfGenSymbol() - ATOM y => [false,nil,g,body] - [false,nil,g,bfMKPROGN [bfLET(compFluidize y,g),body]] - -shoeCompTran x== - lamtype:=CAR x - args :=CADR x - body :=CDDR x - $fluidVars:local:=nil - $locVars:local:=nil - $dollarVars:local:=nil - shoeCompTran1 body - $locVars:=SETDIFFERENCE(SETDIFFERENCE($locVars, - $fluidVars),shoeATOMs args) - body:= - if $fluidVars or $locVars or $dollarVars or $typings - then - lvars:=append($fluidVars,$locVars) - $fluidVars:=UNION($fluidVars,$dollarVars) - if null $fluidVars - then - null $typings=> shoePROG(lvars,body) - shoePROG(lvars,[["DECLARE",:$typings],:body]) - else - fvars:=["DECLARE",["SPECIAL",:$fluidVars]] - null $typings => shoePROG(lvars,[fvars,:body]) - shoePROG(lvars,[fvars,["DECLARE",:$typings],:body]) - else shoePROG([], body) - fl:=shoeFluids args - body:=if fl - then - fvs:=["DECLARE",["SPECIAL",:fl]] - cons(fvs,body) - else body - [lamtype,args, :body] - -shoePROG(v,b)== - null b => [["PROG", v]] - [:blist,blast] := b - [["PROG",v,:blist,["RETURN", blast]]] - -shoeFluids x== - if null x - then nil - else if IDENTP x and bfBeginsDollar x - then [x] - else - if EQCAR(x,"QUOTE") - then [] - else - if ATOM x - then nil - else append(shoeFluids car x,shoeFluids cdr x) -shoeATOMs x== - if null x - then nil - else if ATOM x - then [x] - else append(shoeATOMs car x,shoeATOMs cdr x) - -shoeCompTran1 x== - ATOM x=> - IDENTP x and bfBeginsDollar x=> - $dollarVars:= - MEMQ(x,$dollarVars)=>$dollarVars - cons(x,$dollarVars) - nil - U:=car x - EQ(U,"QUOTE")=>nil - x is ["L%T",l,r]=> - RPLACA (x,"SETQ") - shoeCompTran1 r - IDENTP l => - not bfBeginsDollar l=> - $locVars:= - MEMQ(l,$locVars)=>$locVars - cons(l,$locVars) - $dollarVars:= - MEMQ(l,$dollarVars)=>$dollarVars - cons(l,$dollarVars) - EQCAR(l,"FLUID")=> - $fluidVars:= - MEMQ(CADR l,$fluidVars)=>$fluidVars - cons(CADR l,$fluidVars) - RPLACA (CDR x,CADR l) - MEMQ(U,'(PROG LAMBDA))=> - newbindings:=nil - for y in CADR x repeat - not MEMQ(y,$locVars)=> - $locVars:=cons(y,$locVars) - newbindings:=cons(y,newbindings) - res:=shoeCompTran1 CDDR x - $locVars:=[y for y in $locVars | not MEMQ(y,newbindings)] - shoeCompTran1 car x - shoeCompTran1 cdr x - -bfTagged(a,b)== - IDENTP a => - EQ(b,"FLUID") => bfLET(compFluid a,NIL) - EQ(b,"fluid") => bfLET(compFluid a,NIL) - EQ(b,"local") => bfLET(compFluid a,NIL) - $typings:=cons(["TYPE",b,a],$typings) - a - ["THE",b,a] - -bfAssign(l,r)== - if bfTupleP l then bfSetelt(CADR l,CDDR l ,r) else bfLET(l,r) - -bfSetelt(e,l,r)== - if null cdr l - then defSETELT(e,car l,r) - else bfSetelt(bfElt(e,car l),cdr l,r) - -bfElt(expr,sel)== - y:=SYMBOLP sel and GET(sel,"SHOESELFUNCTION") - y=> - INTEGERP y => ["ELT",expr,y] - [y,expr] - ["ELT",expr,sel] - -defSETELT(var,sel,expr)== - y:=SYMBOLP sel and GET(sel,"SHOESELFUNCTION") - y=> - INTEGERP y => ["SETF",["ELT",var,y],expr] - ["SETF",[y,var],expr] - ["SETF",["ELT",var,sel],expr] - -bfIfThenOnly(a,b)== - b1:=if EQCAR (b,"PROGN") then CDR b else [b] - ["COND",[a,:b1]] - -bfIf(a,b,c)== - b1:=if EQCAR (b,"PROGN") then CDR b else [b] - EQCAR (c,"COND") => ["COND",[a,:b1],:CDR c] - c1:=if EQCAR (c,"PROGN") then CDR c else [c] - ["COND",[a,:b1],['(QUOTE T),:c1]] - -bfExit(a,b)== ["COND",[a,["IDENTITY",b]]] - -bfMKPROGN l== - a:=[:bfFlattenSeq c for c in tails l] - null a=> nil - null CDR a=> CAR a - ["PROGN",:a] - -bfFlattenSeq x == - null x=>NIL - f:=CAR x - ATOM f =>if CDR x then nil else [f] - EQCAR(f,"PROGN") => - CDR x=> [i for i in CDR f| not ATOM i] - CDR f - [f] - -bfSequence l == - null l=> NIL - transform:= [[a,b] for x in l while - x is ["COND",[a,["IDENTITY",b]]]] - no:=#transform - before:= bfTake(no,l) - aft := bfDrop(no,l) - null before => - null rest l => - f:=first l - if EQCAR(f,"PROGN") - then bfSequence CDR f - else f - bfMKPROGN [first l,bfSequence rest l] - null aft => ["COND",:transform] - ["COND",:transform,['(QUOTE T),bfSequence aft]] - -bfWhere (context,expr)== - [opassoc,defs,nondefs] := defSheepAndGoats context - a:=[[def,op,args,bfSUBLIS(opassoc,body)] - for d in defs |d is [def,op,args,body]] - $wheredefs:=append(a,$wheredefs) - bfMKPROGN bfSUBLIS(opassoc,NCONC(nondefs,[expr])) - -bfReadLisp string==bfTuple shoeReadLispString (string,0) - ---shoeReadLispString(s,n)== --- n>= # s => nil --- [exp,ind]:=shoeReadLisp(s,n) --- null exp => nil --- cons(exp,shoeReadLispString(s,ind)) - -shoeReadLispString(s,n) == - l:=# s - n >= l => nil - READ_-FROM_-STRING CONCAT ( "(", SUBSTRING(s,n,l-n) ,")") - -bfCompHash(op,argl,body) == - auxfn:= INTERN CONCAT (PNAME op,'";") - computeFunction:= ["DEFUN",auxfn,argl,:body] - bfTuple [computeFunction,:bfMain(auxfn,op)] - -bfMain(auxfn,op)== - g1:= bfGenSymbol() - arg:=["&REST",g1] - computeValue := ['APPLY,["FUNCTION",auxfn],g1] - cacheName:= INTERN CONCAT (PNAME op,'";AL") - g2:= bfGenSymbol() - getCode:= ['GETHASH,g1,cacheName] - secondPredPair:= [['SETQ,g2,getCode],g2] - putCode:= ['SETF ,getCode,computeValue] - thirdPredPair:= ['(QUOTE T),putCode] - codeBody:= ['PROG,[g2], - ['RETURN,['COND,secondPredPair,thirdPredPair]]] - mainFunction:= ["DEFUN",op,arg,codeBody] - - cacheType:= 'hash_-table - cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE, - ["QUOTE","UEQUAL"]]] - cacheCountCode:= ['hashCount,cacheName] - cacheVector:= - [op,cacheName,cacheType,cacheResetCode,cacheCountCode] - [mainFunction, - shoeEVALANDFILEACTQ - ["SETF",["GET", - ["QUOTE", op],["QUOTE",'cacheInfo]],["QUOTE", cacheVector]], - shoeEVALANDFILEACTQ cacheResetCode ] - -@ -<>= - -(IN-PACKAGE 'BOOTTRAN) - -(DEFUN |bfGenSymbol| () - (PROG () - (DECLARE (SPECIAL |$GenVarCounter|)) - (RETURN - (PROGN - (SETQ |$GenVarCounter| (+ |$GenVarCounter| 1)) - (INTERN (CONCAT "bfVar#" (STRINGIMAGE |$GenVarCounter|))))))) - -(DEFUN |bfListOf| (|x|) (PROG () (RETURN |x|))) - -(DEFUN |bfColon| (|x|) (PROG () (RETURN (LIST 'COLON |x|)))) - -(DEFUN |bfSymbol| (|x|) - (PROG () (RETURN (COND ((STRINGP |x|) |x|) ('T (LIST 'QUOTE |x|)))))) - -(DEFUN |bfDot| () (PROG () (RETURN 'DOT))) - -(DEFUN |bfSuffixDot| (|x|) (PROG () (RETURN (LIST |x| 'DOT)))) - -(DEFUN |bfEqual| (|name|) (PROG () (RETURN (LIST 'EQUAL |name|)))) - -(DEFUN |bfBracket| (|part|) (PROG () (RETURN |part|))) - -(DEFUN |bfPile| (|part|) (PROG () (RETURN |part|))) - -(DEFUN |bfAppend| (|x|) (PROG () (RETURN (APPLY #'APPEND |x|)))) - -(DEFUN |bfColonAppend| (|x| |y|) - (PROG (|a|) - (RETURN - (COND - ((NULL |x|) - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) - (PROGN (SETQ |a| (CDR |y|)) 'T)) - (LIST '&REST (CONS 'QUOTE |a|))) - ('T (LIST '&REST |y|)))) - ('T (CONS (CAR |x|) (|bfColonAppend| (CDR |x|) |y|))))))) - -(DEFUN |bfDefinition1| (|bflhsitems| |bfrhs|) - (PROG () (RETURN (LIST 'DEF |bflhsitems| (|bfTuple| NIL) |bfrhs|)))) - -(DEFUN |bfDefinition2| (|bflhsitems| |bfrhs| |body|) - (PROG () (RETURN (LIST 'DEF |bflhsitems| |bfrhs| |body|)))) - -(DEFUN |bfMDefinition2| (|bflhsitems| |bfrhs| |body|) - (PROG () (RETURN (|bfMDef| 'MDEF |bflhsitems| |bfrhs| |body|)))) - -(DEFUN |bfCompDef| (|bfVar#1|) - (PROG (|body| |args| |op| |def|) - (RETURN - (PROGN - (SETQ |def| (CAR |bfVar#1|)) - (SETQ |op| (CADR |bfVar#1|)) - (SETQ |args| (CADDR |bfVar#1|)) - (SETQ |body| (CADDDR |bfVar#1|)) - (|bfDef| |def| |op| |args| |body|))))) - -(DEFUN |bfBeginsDollar| (|x|) - (PROG () (RETURN (EQL (ELT "$" 0) (ELT (PNAME |x|) 0))))) - -(DEFUN |compFluid| (|id|) (PROG () (RETURN (LIST 'FLUID |id|)))) - -(DEFUN |compFluidize| (|x|) - (PROG () - (RETURN - (COND - ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) (|compFluid| |x|)) - ((ATOM |x|) |x|) - ((EQCAR |x| 'QUOTE) |x|) - ('T - (CONS (|compFluidize| (CAR |x|)) (|compFluidize| (CDR |x|)))))))) - -(DEFUN |bfTuple| (|x|) (PROG () (RETURN (CONS 'TUPLE |x|)))) - -(DEFUN |bfTupleP| (|x|) (PROG () (RETURN (EQCAR |x| 'TUPLE)))) - -(DEFUN |bfTupleIf| (|x|) - (PROG () - (RETURN (COND ((|bfTupleP| |x|) |x|) ('T (|bfTuple| |x|)))))) - -(DEFUN |bfTupleConstruct| (|b|) - (PROG (|ISTMP#1| |a|) - (RETURN - (PROGN - (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) ('T (LIST |b|)))) - (COND - (((LAMBDA (|bfVar#3| |bfVar#2| |x|) - (LOOP - (COND - ((OR (ATOM |bfVar#2|) - (PROGN (SETQ |x| (CAR |bfVar#2|)) NIL)) - (RETURN |bfVar#3|)) - ('T - (PROGN - (SETQ |bfVar#3| - (AND (CONSP |x|) (EQ (CAR |x|) 'COLON) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (EQ (CDR |ISTMP#1|) NIL))))) - (COND (|bfVar#3| (RETURN |bfVar#3|)))))) - (SETQ |bfVar#2| (CDR |bfVar#2|)))) - NIL |a| NIL) - (|bfMakeCons| |a|)) - ('T (CONS 'LIST |a|))))))) - -(DEFUN |bfConstruct| (|b|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) ('T (LIST |b|)))) - (|bfMakeCons| |a|))))) - -(DEFUN |bfMakeCons| (|l|) - (PROG (|l1| |a| |ISTMP#2| |ISTMP#1|) - (RETURN - (COND - ((NULL |l|) NIL) - ((AND (CONSP |l|) - (PROGN - (SETQ |ISTMP#1| (CAR |l|)) - (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'COLON) - (PROGN - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#2|)) 'T))))) - (PROGN (SETQ |l1| (CDR |l|)) 'T)) - (COND (|l1| (LIST 'APPEND |a| (|bfMakeCons| |l1|))) ('T |a|))) - ('T (LIST 'CONS (CAR |l|) (|bfMakeCons| (CDR |l|)))))))) - -(DEFUN |bfFor| (|bflhs| U |step|) - (PROG () - (RETURN - (COND - ((EQCAR U '|tails|) (|bfForTree| 'ON |bflhs| (CADR U))) - ((EQCAR U 'SEGMENT) - (|bfSTEP| |bflhs| (CADR U) |step| (CADDR U))) - ('T (|bfForTree| 'IN |bflhs| U)))))) - -(DEFUN |bfForTree| (OP |lhs| |whole|) - (PROG (G) - (RETURN - (PROGN - (SETQ |whole| - (COND - ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|))) - ('T |whole|))) - (COND - ((ATOM |lhs|) (|bfINON| (LIST OP |lhs| |whole|))) - ('T - (PROGN - (SETQ |lhs| - (COND ((|bfTupleP| |lhs|) (CADR |lhs|)) ('T |lhs|))) - (COND - ((EQCAR |lhs| 'L%T) - (PROGN - (SETQ G (CADR |lhs|)) - (APPEND (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G (CADDR |lhs|)))))) - ('T - (PROGN - (SETQ G (|bfGenSymbol|)) - (APPEND (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G |lhs|))))))))))))) - -(DEFUN |bfSTEP| (|id| |fst| |step| |lst|) - (PROG (|suc| |ex| |pred| |final| |g2| |inc| |g1| |initval| |initvar|) - (RETURN - (PROGN - (SETQ |initvar| (LIST |id|)) - (SETQ |initval| (LIST |fst|)) - (SETQ |inc| - (COND - ((ATOM |step|) |step|) - ('T (SETQ |g1| (|bfGenSymbol|)) - (SETQ |initvar| (CONS |g1| |initvar|)) - (SETQ |initval| (CONS |step| |initval|)) |g1|))) - (SETQ |final| - (COND - ((ATOM |lst|) |lst|) - ('T (SETQ |g2| (|bfGenSymbol|)) - (SETQ |initvar| (CONS |g2| |initvar|)) - (SETQ |initval| (CONS |lst| |initval|)) |g2|))) - (SETQ |ex| - (COND - ((NULL |lst|) NIL) - ((INTEGERP |inc|) - (PROGN - (SETQ |pred| (COND ((MINUSP |inc|) '<) ('T '>))) - (LIST (LIST |pred| |id| |final|)))) - ('T - (LIST (LIST 'COND - (LIST (LIST 'MINUSP |inc|) - (LIST '< |id| |final|)) - (LIST 'T (LIST '> |id| |final|))))))) - (SETQ |suc| (LIST (LIST 'SETQ |id| (LIST '+ |id| |inc|)))) - (LIST (LIST |initvar| |initval| |suc| NIL |ex| NIL)))))) - -(DEFUN |bfINON| (|x|) - (PROG (|whole| |id| |op|) - (RETURN - (PROGN - (SETQ |op| (CAR |x|)) - (SETQ |id| (CADR |x|)) - (SETQ |whole| (CADDR |x|)) - (COND - ((EQ |op| 'ON) (|bfON| |id| |whole|)) - ('T (|bfIN| |id| |whole|))))))) - -(DEFUN |bfIN| (|x| E) - (PROG (|g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (LIST (LIST (LIST |g| |x|) (LIST E NIL) - (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL - (LIST (LIST 'OR (LIST 'ATOM |g|) - (LIST 'PROGN - (LIST 'SETQ |x| (LIST 'CAR |g|)) - 'NIL))) - NIL)))))) - -(DEFUN |bfON| (|x| E) - (PROG () - (RETURN - (LIST (LIST (LIST |x|) (LIST E) - (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL - (LIST (LIST 'ATOM |x|)) NIL))))) - -(DEFUN |bfSuchthat| (|p|) - (PROG () (RETURN (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL))))) - -(DEFUN |bfWhile| (|p|) - (PROG () - (RETURN (LIST (LIST NIL NIL NIL NIL (LIST (|bfNOT| |p|)) NIL))))) - -(DEFUN |bfUntil| (|p|) - (PROG (|g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (LIST (LIST (LIST |g|) (LIST NIL) (LIST (LIST 'SETQ |g| |p|)) - NIL (LIST |g|) NIL)))))) - -(DEFUN |bfIterators| (|x|) (PROG () (RETURN (CONS 'ITERATORS |x|)))) - -(DEFUN |bfCross| (|x|) (PROG () (RETURN (CONS 'CROSS |x|)))) - -(DEFUN |bfLp| (|iters| |body|) - (PROG () - (RETURN - (COND - ((EQCAR |iters| 'ITERATORS) (|bfLp1| (CDR |iters|) |body|)) - ('T (|bfLpCross| (CDR |iters|) |body|)))))) - -(DEFUN |bfLpCross| (|iters| |body|) - (PROG () - (RETURN - (COND - ((NULL (CDR |iters|)) (|bfLp| (CAR |iters|) |body|)) - ('T (|bfLp| (CAR |iters|) (|bfLpCross| (CDR |iters|) |body|))))))) - -(DEFUN |bfSep| (|iters|) - (PROG (|r| |f|) - (RETURN - (COND - ((NULL |iters|) (LIST NIL NIL NIL NIL NIL NIL)) - ('T (SETQ |f| (CAR |iters|)) (SETQ |r| (|bfSep| (CDR |iters|))) - ((LAMBDA (|bfVar#6| |bfVar#4| |i| |bfVar#5| |j|) - (LOOP - (COND - ((OR (ATOM |bfVar#4|) - (PROGN (SETQ |i| (CAR |bfVar#4|)) NIL) - (ATOM |bfVar#5|) - (PROGN (SETQ |j| (CAR |bfVar#5|)) NIL)) - (RETURN (NREVERSE |bfVar#6|))) - ('T (SETQ |bfVar#6| (CONS (APPEND |i| |j|) |bfVar#6|)))) - (SETQ |bfVar#4| (CDR |bfVar#4|)) - (SETQ |bfVar#5| (CDR |bfVar#5|)))) - NIL |f| NIL |r| NIL)))))) - -(DEFUN |bfReduce| (|op| |y|) - (PROG (|it| |ny| |g2| |body| |g1| |g| |init| |a|) - (RETURN - (PROGN - (SETQ |a| (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) ('T |op|))) - (SETQ |op| (|bfReName| |a|)) - (SETQ |init| (GET |op| 'SHOETHETA)) - (SETQ |g| (|bfGenSymbol|)) - (SETQ |g1| (|bfGenSymbol|)) - (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g1| |g|))) - (COND - ((NULL |init|) (SETQ |g2| (|bfGenSymbol|)) - (SETQ |init| (LIST 'CAR |g2|)) (SETQ |ny| (LIST 'CDR |g2|)) - (SETQ |it| - (CONS 'ITERATORS - (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL - NIL NIL (LIST |g|))) - (|bfIN| |g1| |ny|)))) - (|bfMKPROGN| - (LIST (LIST 'L%T |g2| |y|) (|bfLp| |it| |body|)))) - ('T (SETQ |init| (CAR |init|)) - (SETQ |it| - (CONS 'ITERATORS - (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL - NIL NIL (LIST |g|))) - (|bfIN| |g1| |y|)))) - (|bfLp| |it| |body|))))))) - -(DEFUN |bfReduceCollect| (|op| |y|) - (PROG (|init| |a| |itl| |body|) - (RETURN - (COND - ((EQCAR |y| 'COLLECT) (SETQ |body| (ELT |y| 1)) - (SETQ |itl| (ELT |y| 2)) - (SETQ |a| (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) ('T |op|))) - (SETQ |op| (|bfReName| |a|)) - (SETQ |init| (GET |op| 'SHOETHETA)) - (|bfOpReduce| |op| |init| |body| |itl|)) - ('T (SETQ |a| (|bfTupleConstruct| (ELT |y| 1))) - (|bfReduce| |op| |a|)))))) - -(DEFUN |bfDCollect| (|y| |itl|) - (PROG () (RETURN (LIST 'COLLECT |y| |itl|)))) - -(DEFUN |bfDTuple| (|x|) (PROG () (RETURN (LIST 'DTUPLE |x|)))) - -(DEFUN |bfCollect| (|y| |itl|) - (PROG (|newBody| |a| |ISTMP#1|) - (RETURN - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'COLON) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) 'T)))) - (|bf0APPEND| |a| |itl|)) - ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) - (PROGN - (SETQ |newBody| (|bfConstruct| |y|)) - (|bf0APPEND| |newBody| |itl|))) - ('T (|bf0COLLECT| |y| |itl|)))))) - -(DEFUN |bf0COLLECT| (|y| |itl|) - (PROG () (RETURN (|bfListReduce| 'CONS |y| |itl|)))) - -(DEFUN |bf0APPEND| (|y| |itl|) - (PROG (|extrait| |body| |g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (SETQ |body| - (LIST 'SETQ |g| (LIST 'APPEND (LIST 'REVERSE |y|) |g|))) - (SETQ |extrait| - (LIST (LIST (LIST |g|) (LIST NIL) NIL NIL NIL - (LIST (LIST 'NREVERSE |g|))))) - (|bfLp2| |extrait| |itl| |body|))))) - -(DEFUN |bfListReduce| (|op| |y| |itl|) - (PROG (|extrait| |body| |g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (SETQ |body| (LIST 'SETQ |g| (LIST |op| |y| |g|))) - (SETQ |extrait| - (LIST (LIST (LIST |g|) (LIST NIL) NIL NIL NIL - (LIST (LIST 'NREVERSE |g|))))) - (|bfLp2| |extrait| |itl| |body|))))) - -(DEFUN |bfLp1| (|iters| |body|) - (PROG (|loop| |nbody| |value| |exits| |filters| |sucs| |inits| |vars| - |LETTMP#1|) - (RETURN - (PROGN - (SETQ |LETTMP#1| (|bfSep| (|bfAppend| |iters|))) - (SETQ |vars| (CAR |LETTMP#1|)) - (SETQ |inits| (CADR |LETTMP#1|)) - (SETQ |sucs| (CADDR |LETTMP#1|)) - (SETQ |filters| (CADDDR |LETTMP#1|)) - (SETQ |exits| (CAR (CDDDDR |LETTMP#1|))) - (SETQ |value| (CADR (CDDDDR |LETTMP#1|))) - (SETQ |nbody| - (COND - ((NULL |filters|) |body|) - ('T (|bfAND| (APPEND |filters| (CONS |body| NIL)))))) - (SETQ |value| (COND ((NULL |value|) 'NIL) ('T (CAR |value|)))) - (SETQ |exits| - (LIST 'COND - (LIST (|bfOR| |exits|) (LIST 'RETURN |value|)) - (LIST ''T |nbody|))) - (SETQ |loop| - (CONS (LIST 'LAMBDA |vars| - (CONS 'LOOP (CONS |exits| |sucs|))) - |inits|)) - |loop|)))) - -(DEFUN |bfLp2| (|extrait| |itl| |body|) - (PROG (|iters|) - (RETURN - (COND - ((EQCAR |itl| 'ITERATORS) - (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|)) - ('T - (PROGN - (SETQ |iters| (CDR |itl|)) - (|bfLpCross| - (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) - (CDR |iters|)) - |body|))))))) - -(DEFUN |bfOpReduce| (|op| |init| |y| |itl|) - (PROG (|extrait| |g1| |body| |g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (SETQ |body| - (COND - ((EQ |op| 'AND) - (|bfMKPROGN| - (LIST (LIST 'SETQ |g| |y|) - (LIST 'COND - (LIST (LIST 'NOT |g|) - (LIST 'RETURN 'NIL)))))) - ((EQ |op| 'OR) - (|bfMKPROGN| - (LIST (LIST 'SETQ |g| |y|) - (LIST 'COND (LIST |g| (LIST 'RETURN |g|)))))) - ('T (LIST 'SETQ |g| (LIST |op| |g| |y|))))) - (COND - ((NULL |init|) (SETQ |g1| (|bfGenSymbol|)) - (SETQ |init| (LIST 'CAR |g1|)) (SETQ |y| (LIST 'CDR |g1|)) - (SETQ |extrait| - (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL - (LIST |g|)))) - (|bfMKPROGN| - (LIST (LIST 'L%T |g1| |y|) - (|bfLp2| |extrait| |itl| |body|)))) - ('T (SETQ |init| (CAR |init|)) - (SETQ |extrait| - (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL - (LIST |g|)))) - (|bfLp2| |extrait| |itl| |body|))))))) - -(DEFUN |bfLoop1| (|body|) - (PROG () (RETURN (|bfLp| (|bfIterators| NIL) |body|)))) - -(DEFUN |bfSegment1| (|lo|) - (PROG () (RETURN (LIST 'SEGMENT |lo| NIL)))) - -(DEFUN |bfSegment2| (|lo| |hi|) - (PROG () (RETURN (LIST 'SEGMENT |lo| |hi|)))) - -(DEFUN |bfForInBy| (|variable| |collection| |step|) - (PROG () (RETURN (|bfFor| |variable| |collection| |step|)))) - -(DEFUN |bfForin| (|lhs| U) (PROG () (RETURN (|bfFor| |lhs| U 1)))) - -(DEFUN |bfLocal| (|a| |b|) - (PROG () - (RETURN - (COND - ((EQ |b| 'FLUID) (|compFluid| |a|)) - ((EQ |b| '|fluid|) (|compFluid| |a|)) - ((EQ |b| '|local|) (|compFluid| |a|)) - ('T |a|))))) - -(DEFUN |bfTake| (|n| |x|) - (PROG () - (RETURN - (COND - ((NULL |x|) |x|) - ((EQL |n| 0) NIL) - ('T (CONS (CAR |x|) (|bfTake| (- |n| 1) (CDR |x|)))))))) - -(DEFUN |bfDrop| (|n| |x|) - (PROG () - (RETURN - (COND - ((OR (NULL |x|) (EQL |n| 0)) |x|) - ('T (|bfDrop| (- |n| 1) (CDR |x|))))))) - -(DEFUN |bfDefSequence| (|l|) (PROG () (RETURN (CONS 'SEQ |l|)))) - -(DEFUN |bfReturnNoName| (|a|) (PROG () (RETURN (LIST 'RETURN |a|)))) - -(DEFUN |bfSUBLIS| (|p| |e|) - (PROG () - (RETURN - (COND - ((ATOM |e|) (|bfSUBLIS1| |p| |e|)) - ((EQCAR |e| 'QUOTE) |e|) - ('T - (CONS (|bfSUBLIS| |p| (CAR |e|)) (|bfSUBLIS| |p| (CDR |e|)))))))) - -(DEFUN |bfSUBLIS1| (|p| |e|) - (PROG (|f|) - (RETURN - (COND - ((NULL |p|) |e|) - ('T - (PROGN - (SETQ |f| (CAR |p|)) - (COND - ((EQ (CAR |f|) |e|) (CDR |f|)) - ('T (|bfSUBLIS1| (CDR |p|) |e|))))))))) - -(DEFUN |defSheepAndGoats| (|x|) - (PROG (|defstack| |op1| |opassoc| |argl| |body| |args| |op| |def|) - (DECLARE (SPECIAL |$op|)) - (RETURN - (COND - ((EQCAR |x| 'DEF) - (PROGN - (SETQ |def| (CAR |x|)) - (SETQ |op| (CADR |x|)) - (SETQ |args| (CADDR |x|)) - (SETQ |body| (CADDDR |x|)) - (SETQ |argl| - (COND - ((|bfTupleP| |args|) (CDR |args|)) - ('T (LIST |args|)))) - (COND - ((NULL |argl|) (SETQ |opassoc| (LIST (CONS |op| |body|))) - (LIST |opassoc| NIL NIL)) - ('T - (SETQ |op1| - (INTERN (CONCAT (PNAME |$op|) "," (PNAME |op|)))) - (SETQ |opassoc| (LIST (CONS |op| |op1|))) - (SETQ |defstack| (LIST (LIST 'DEF |op1| |args| |body|))) - (LIST |opassoc| |defstack| NIL))))) - ((EQCAR |x| 'SEQ) (|defSheepAndGoatsList| (CDR |x|))) - ('T (LIST NIL NIL (LIST |x|))))))) - -(DEFUN |defSheepAndGoatsList| (|x|) - (PROG (|nondefs1| |defs1| |opassoc1| |nondefs| |defs| |opassoc| - |LETTMP#1|) - (RETURN - (COND - ((NULL |x|) (LIST NIL NIL NIL)) - ('T (SETQ |LETTMP#1| (|defSheepAndGoats| (CAR |x|))) - (SETQ |opassoc| (CAR |LETTMP#1|)) - (SETQ |defs| (CADR |LETTMP#1|)) - (SETQ |nondefs| (CADDR |LETTMP#1|)) - (SETQ |LETTMP#1| (|defSheepAndGoatsList| (CDR |x|))) - (SETQ |opassoc1| (CAR |LETTMP#1|)) - (SETQ |defs1| (CADR |LETTMP#1|)) - (SETQ |nondefs1| (CADDR |LETTMP#1|)) - (LIST (APPEND |opassoc| |opassoc1|) (APPEND |defs| |defs1|) - (APPEND |nondefs| |nondefs1|))))))) - -(DEFUN |bfLetForm| (|lhs| |rhs|) - (PROG () (RETURN (LIST 'L%T |lhs| |rhs|)))) - -(DEFUN |bfLET1| (|lhs| |rhs|) - (PROG (|let1| |g| |l2| |l1| |name| |rhs1| |ISTMP#1|) - (DECLARE (SPECIAL |$letGenVarCounter|)) - (RETURN - (COND - ((IDENTP |lhs|) (|bfLetForm| |lhs| |rhs|)) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL)))) - (|bfLetForm| |lhs| |rhs|)) - ((AND (IDENTP |rhs|) (NULL (|bfCONTAINED| |rhs| |lhs|))) - (PROGN - (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) - (COND - ((EQCAR |rhs1| 'L%T) (|bfMKPROGN| (LIST |rhs1| |rhs|))) - ((EQCAR |rhs1| 'PROGN) (APPEND |rhs1| (LIST |rhs|))) - ('T - (PROGN - (COND - ((IDENTP (CAR |rhs1|)) - (SETQ |rhs1| (CONS |rhs1| NIL)))) - (|bfMKPROGN| (APPEND |rhs1| (CONS |rhs| NIL)))))))) - ((AND (CONSP |rhs|) (EQCAR |rhs| 'L%T) - (IDENTP (SETQ |name| (CADR |rhs|)))) - (PROGN - (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) - (SETQ |l2| (|bfLET1| |lhs| |name|)) - (COND - ((EQCAR |l2| 'PROGN) (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) - ('T - (PROGN - (COND - ((IDENTP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) - (|bfMKPROGN| - (CONS |l1| (APPEND |l2| (CONS |name| NIL))))))))) - ('T - (PROGN - (SETQ |g| - (INTERN (CONCAT "LETTMP#" - (STRINGIMAGE |$letGenVarCounter|)))) - (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) - (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) - (SETQ |let1| (|bfLET1| |lhs| |g|)) - (COND - ((EQCAR |let1| 'PROGN) - (|bfMKPROGN| (CONS |rhs1| (CDR |let1|)))) - ('T - (PROGN - (COND - ((IDENTP (CAR |let1|)) - (SETQ |let1| (CONS |let1| NIL)))) - (|bfMKPROGN| - (CONS |rhs1| (APPEND |let1| (CONS |g| NIL))))))))))))) - -(DEFUN |bfCONTAINED| (|x| |y|) - (PROG () - (RETURN - (COND - ((EQ |x| |y|) T) - ((ATOM |y|) NIL) - ('T - (OR (|bfCONTAINED| |x| (CAR |y|)) - (|bfCONTAINED| |x| (CDR |y|)))))))) - -(DEFUN |bfLET2| (|lhs| |rhs|) - (PROG (|val1| |ISTMP#3| |g| |rev| |patrev| |l2| |l1| |var2| |var1| - |b| |ISTMP#2| |a| |ISTMP#1|) - (DECLARE (SPECIAL |$letGenVarCounter|)) - (RETURN - (COND - ((IDENTP |lhs|) (|bfLetForm| |lhs| |rhs|)) - ((NULL |lhs|) NIL) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL)))) - (|bfLetForm| |lhs| |rhs|)) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |a| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |b| (CAR |ISTMP#2|)) 'T)))))) - (PROGN - (SETQ |a| (|bfLET2| |a| |rhs|)) - (COND - ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|) - ((ATOM |b|) (LIST |a| |b|)) - ((CONSP (CAR |b|)) (CONS |a| |b|)) - ('T (LIST |a| |b|))))) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'CONS) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |var1| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |var2| (CAR |ISTMP#2|)) 'T)))))) - (COND - ((OR (EQ |var1| 'DOT) - (AND (CONSP |var1|) (EQCAR |var1| 'QUOTE))) - (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) - ('T - (PROGN - (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) - (COND - ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|) - ('T - (PROGN - (COND - ((AND (CONSP |l1|) (ATOM (CAR |l1|))) - (SETQ |l1| (CONS |l1| NIL)))) - (COND - ((IDENTP |var2|) - (APPEND |l1| - (CONS (|bfLetForm| |var2| - (|addCARorCDR| 'CDR |rhs|)) - NIL))) - ('T - (PROGN - (SETQ |l2| - (|bfLET2| |var2| - (|addCARorCDR| 'CDR |rhs|))) - (COND - ((AND (CONSP |l2|) (ATOM (CAR |l2|))) - (SETQ |l2| (CONS |l2| NIL)))) - (APPEND |l1| |l2|))))))))))) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'APPEND) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |var1| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |var2| (CAR |ISTMP#2|)) 'T)))))) - (PROGN - (SETQ |patrev| (|bfISReverse| |var2| |var1|)) - (SETQ |rev| (LIST 'REVERSE |rhs|)) - (SETQ |g| - (INTERN (CONCAT "LETTMP#" - (STRINGIMAGE |$letGenVarCounter|)))) - (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) - (SETQ |l2| (|bfLET2| |patrev| |g|)) - (COND - ((AND (CONSP |l2|) (ATOM (CAR |l2|))) - (SETQ |l2| (CONS |l2| NIL)))) - (COND - ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|)) - ((PROGN - (SETQ |ISTMP#1| (|last| |l2|)) - (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T) - (PROGN - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQUAL (CAR |ISTMP#2|) |var1|) - (PROGN - (SETQ |ISTMP#3| (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CDR |ISTMP#3|) NIL) - (PROGN - (SETQ |val1| (CAR |ISTMP#3|)) - 'T))))))) - (CONS (LIST 'L%T |g| |rev|) - (APPEND (REVERSE (CDR (REVERSE |l2|))) - (CONS (|bfLetForm| |var1| - (LIST 'NREVERSE |val1|)) - NIL)))) - ('T - (CONS (LIST 'L%T |g| |rev|) - (APPEND |l2| - (CONS (|bfLetForm| |var1| - (LIST 'NREVERSE |var1|)) - NIL))))))) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |var1| (CAR |ISTMP#1|)) 'T)))) - (LIST 'COND (LIST (LIST 'EQUAL |var1| |rhs|) |var1|))) - ('T - (PROGN - (|bpSpecificErrorHere| - "unexpected LET code is generated in this line") - (REALLYPRETTYPRINT |lhs|) - (|bpTrap|))))))) - -(DEFUN |bfLET| (|lhs| |rhs|) - (PROG (|$letGenVarCounter|) - (DECLARE (SPECIAL |$letGenVarCounter|)) - (RETURN - (PROGN (SETQ |$letGenVarCounter| 1) (|bfLET1| |lhs| |rhs|))))) - -(DEFUN |addCARorCDR| (|acc| |expr|) - (PROG (|funsR| |funsA| |p| |funs|) - (RETURN - (COND - ((NULL (CONSP |expr|)) (LIST |acc| |expr|)) - ((AND (EQ |acc| 'CAR) (EQCAR |expr| 'REVERSE)) - (LIST 'CAR (CONS 'LAST (CDR |expr|)))) - ('T - (PROGN - (SETQ |funs| - '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR - CDAAR CDDAR CDADR CDDDR)) - (SETQ |p| (|bfPosition| (CAR |expr|) |funs|)) - (COND - ((EQUAL |p| (- 1)) (LIST |acc| |expr|)) - ('T - (PROGN - (SETQ |funsA| - '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR - CAAADR CAADDR CADAAR CADDAR CADADR CADDDR)) - (SETQ |funsR| - '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR - CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR)) - (COND - ((EQ |acc| 'CAR) - (CONS (ELT |funsA| |p|) (CDR |expr|))) - ('T (CONS (ELT |funsR| |p|) (CDR |expr|))))))))))))) - -(DEFUN |bfPosition| (|x| |l|) (PROG () (RETURN (|bfPosn| |x| |l| 0)))) - -(DEFUN |bfPosn| (|x| |l| |n|) - (PROG () - (RETURN - (COND - ((NULL |l|) (- 1)) - ((EQUAL |x| (CAR |l|)) |n|) - ('T (|bfPosn| |x| (CDR |l|) (+ |n| 1))))))) - -(DEFUN |bfISApplication| (|op| |left| |right|) - (PROG () - (RETURN - (COND - ((EQ |op| 'IS) (|bfIS| |left| |right|)) - ((EQ |op| 'ISNT) (|bfNOT| (|bfIS| |left| |right|))) - ('T (LIST |op| |left| |right|)))))) - -(DEFUN |bfIS| (|left| |right|) - (PROG (|$inDefIS| |$isGenVarCounter|) - (DECLARE (SPECIAL |$isGenVarCounter| |$inDefIS|)) - (RETURN - (PROGN - (SETQ |$isGenVarCounter| 1) - (SETQ |$inDefIS| T) - (|bfIS1| |left| |right|))))) - -(DEFUN |bfISReverse| (|x| |a|) - (PROG (|y|) - (RETURN - (COND - ((AND (CONSP |x|) (EQ (CAR |x|) 'CONS)) - (COND - ((NULL (CADDR |x|)) (LIST 'CONS (CADR |x|) |a|)) - ('T - (PROGN - (SETQ |y| (|bfISReverse| (CADDR |x|) NIL)) - (RPLACA (CDDR |y|) (LIST 'CONS (CADR |x|) |a|)) - |y|)))) - ('T - (PROGN - (|bpSpecificErrorHere| "Error in bfISReverse") - (|bpTrap|))))))) - -(DEFUN |bfIS1| (|lhs| |rhs|) - (PROG (|l2| |rev| |patrev| |cls| |b1| |a1| |b| |g| |l| |d| |ISTMP#2| - |c| |a| |ISTMP#1|) - (DECLARE (SPECIAL |$isGenVarCounter|)) - (RETURN - (COND - ((NULL |rhs|) (LIST 'NULL |lhs|)) - ((STRINGP |rhs|) (LIST 'EQ |lhs| (LIST 'QUOTE (INTERN |rhs|)))) - ((NUMBERP |rhs|) (LIST 'EQUAL |lhs| |rhs|)) - ((ATOM |rhs|) (LIST 'PROGN (|bfLetForm| |rhs| |lhs|) ''T)) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |rhs|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) 'T)))) - (COND - ((IDENTP |a|) (LIST 'EQ |lhs| |rhs|)) - ('T (LIST 'EQUAL |lhs| |rhs|)))) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T) - (PROGN - (SETQ |ISTMP#1| (CDR |rhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |c| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |d| (CAR |ISTMP#2|)) 'T)))))) - (PROGN - (SETQ |l| (|bfLET| |c| |lhs|)) - (LIST 'AND (|bfIS1| |lhs| |d|) (|bfMKPROGN| (LIST |l| ''T))))) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'EQUAL) - (PROGN - (SETQ |ISTMP#1| (CDR |rhs|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) 'T)))) - (LIST 'EQUAL |lhs| |a|)) - ((CONSP |lhs|) - (PROGN - (SETQ |g| - (INTERN (CONCAT "ISTMP#" - (STRINGIMAGE |$isGenVarCounter|)))) - (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) - (|bfMKPROGN| - (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|))))) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'CONS) - (PROGN - (SETQ |ISTMP#1| (CDR |rhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |a| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |b| (CAR |ISTMP#2|)) 'T)))))) - (COND - ((EQ |a| 'DOT) - (COND - ((NULL |b|) - (LIST 'AND (LIST 'CONSP |lhs|) - (LIST 'EQ (LIST 'CDR |lhs|) 'NIL))) - ('T - (LIST 'AND (LIST 'CONSP |lhs|) - (|bfIS1| (LIST 'CDR |lhs|) |b|))))) - ((NULL |b|) - (LIST 'AND (LIST 'CONSP |lhs|) - (LIST 'EQ (LIST 'CDR |lhs|) 'NIL) - (|bfIS1| (LIST 'CAR |lhs|) |a|))) - ((EQ |b| 'DOT) - (LIST 'AND (LIST 'CONSP |lhs|) - (|bfIS1| (LIST 'CAR |lhs|) |a|))) - ('T - (PROGN - (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|)) - (SETQ |b1| (|bfIS1| (LIST 'CDR |lhs|) |b|)) - (COND - ((AND (CONSP |a1|) (EQ (CAR |a1|) 'PROGN) - (PROGN - (SETQ |ISTMP#1| (CDR |a1|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |c| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (EQUAL (CAR |ISTMP#2|) ''T))))) - (CONSP |b1|) (EQ (CAR |b1|) 'PROGN) - (PROGN (SETQ |cls| (CDR |b1|)) 'T)) - (LIST 'AND (LIST 'CONSP |lhs|) - (|bfMKPROGN| (CONS |c| |cls|)))) - ('T (LIST 'AND (LIST 'CONSP |lhs|) |a1| |b1|))))))) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'APPEND) - (PROGN - (SETQ |ISTMP#1| (CDR |rhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |a| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |b| (CAR |ISTMP#2|)) 'T)))))) - (PROGN - (SETQ |patrev| (|bfISReverse| |b| |a|)) - (SETQ |g| - (INTERN (CONCAT "ISTMP#" - (STRINGIMAGE |$isGenVarCounter|)))) - (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) - (SETQ |rev| - (LIST 'AND (LIST 'CONSP |lhs|) - (LIST 'PROGN - (LIST 'L%T |g| (LIST 'REVERSE |lhs|)) ''T))) - (SETQ |l2| (|bfIS1| |g| |patrev|)) - (COND - ((AND (CONSP |l2|) (ATOM (CAR |l2|))) - (SETQ |l2| (CONS |l2| NIL)))) - (COND - ((EQ |a| 'DOT) (CONS 'AND (CONS |rev| |l2|))) - ('T - (CONS 'AND - (CONS |rev| - (APPEND |l2| - (CONS (LIST 'PROGN - (|bfLetForm| |a| - (LIST 'NREVERSE |a|)) - ''T) - NIL)))))))) - ('T - (PROGN - (|bpSpecificErrorHere| "bad IS code is generated") - (|bpTrap|))))))) - -(DEFUN |bfApplication| (|bfop| |bfarg|) - (PROG () - (RETURN - (COND - ((|bfTupleP| |bfarg|) (CONS |bfop| (CDR |bfarg|))) - ('T (CONS |bfop| (LIST |bfarg|))))))) - -(DEFUN |bfReName| (|x|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (GET |x| 'SHOERENAME)) - (COND (|a| (CAR |a|)) ('T |x|)))))) - -(DEFUN |bfInfApplication| (|op| |left| |right|) - (PROG () - (RETURN - (COND - ((EQ |op| 'EQUAL) (|bfQ| |left| |right|)) - ((EQ |op| '/=) (|bfNOT| (|bfQ| |left| |right|))) - ((EQ |op| '>) (|bfLessp| |right| |left|)) - ((EQ |op| '<) (|bfLessp| |left| |right|)) - ((EQ |op| '<=) (|bfNOT| (|bfLessp| |right| |left|))) - ((EQ |op| '>=) (|bfNOT| (|bfLessp| |left| |right|))) - ((EQ |op| 'OR) (|bfOR| (LIST |left| |right|))) - ((EQ |op| 'AND) (|bfAND| (LIST |left| |right|))) - ('T (LIST |op| |left| |right|)))))) - -(DEFUN |bfNOT| (|x|) - (PROG (|a| |ISTMP#1|) - (RETURN - (COND - ((AND (CONSP |x|) (EQ (CAR |x|) 'NOT) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) 'T)))) - |a|) - ((AND (CONSP |x|) (EQ (CAR |x|) 'NULL) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) 'T)))) - |a|) - ('T (LIST 'NOT |x|)))))) - -(DEFUN |bfFlatten| (|op| |x|) - (PROG () - (RETURN (COND ((EQCAR |x| |op|) (CDR |x|)) ('T (LIST |x|)))))) - -(DEFUN |bfOR| (|l|) - (PROG () - (RETURN - (COND - ((NULL |l|) NIL) - ((NULL (CDR |l|)) (CAR |l|)) - ('T - (CONS 'OR - ((LAMBDA (|bfVar#8| |bfVar#7| |c|) - (LOOP - (COND - ((OR (ATOM |bfVar#7|) - (PROGN (SETQ |c| (CAR |bfVar#7|)) NIL)) - (RETURN (NREVERSE |bfVar#8|))) - ('T - (SETQ |bfVar#8| - (APPEND (REVERSE (|bfFlatten| 'OR |c|)) - |bfVar#8|)))) - (SETQ |bfVar#7| (CDR |bfVar#7|)))) - NIL |l| NIL))))))) - -(DEFUN |bfAND| (|l|) - (PROG () - (RETURN - (COND - ((NULL |l|) 'T) - ((NULL (CDR |l|)) (CAR |l|)) - ('T - (CONS 'AND - ((LAMBDA (|bfVar#10| |bfVar#9| |c|) - (LOOP - (COND - ((OR (ATOM |bfVar#9|) - (PROGN (SETQ |c| (CAR |bfVar#9|)) NIL)) - (RETURN (NREVERSE |bfVar#10|))) - ('T - (SETQ |bfVar#10| - (APPEND (REVERSE (|bfFlatten| 'AND |c|)) - |bfVar#10|)))) - (SETQ |bfVar#9| (CDR |bfVar#9|)))) - NIL |l| NIL))))))) - -(DEFUN |defQuoteId| (|x|) - (PROG () (RETURN (AND (EQCAR |x| 'QUOTE) (IDENTP (CADR |x|)))))) - -(DEFUN |bfSmintable| (|x|) - (PROG () - (RETURN - (OR (INTEGERP |x|) - (AND (CONSP |x|) (MEMQ (CAR |x|) '(SIZE LENGTH))))))) - -(DEFUN |bfQ| (|l| |r|) - (PROG () - (RETURN - (COND - ((OR (|bfSmintable| |l|) (|bfSmintable| |r|)) - (LIST 'EQL |l| |r|)) - ((OR (|defQuoteId| |l|) (|defQuoteId| |r|)) (LIST 'EQ |l| |r|)) - ((NULL |l|) (LIST 'NULL |r|)) - ((NULL |r|) (LIST 'NULL |l|)) - ('T (LIST 'EQUAL |l| |r|)))))) - -(DEFUN |bfLessp| (|l| |r|) - (PROG () - (RETURN - (COND ((EQL |r| 0) (LIST 'MINUSP |l|)) ('T (LIST '< |l| |r|)))))) - -(DEFUN |bfMDef| (|defOp| |op| |args| |body|) - (PROG (|def| |lamex| |sb2| |sb| |largl| |nargl| |sgargl| |gargl| - |LETTMP#1| |argl|) - (DECLARE (SPECIAL |$wheredefs|)) - (RETURN - (PROGN - (SETQ |argl| - (COND - ((|bfTupleP| |args|) (CDR |args|)) - ('T (LIST |args|)))) - (SETQ |LETTMP#1| (|bfGargl| |argl|)) - (SETQ |gargl| (CAR |LETTMP#1|)) - (SETQ |sgargl| (CADR |LETTMP#1|)) - (SETQ |nargl| (CADDR |LETTMP#1|)) - (SETQ |largl| (CADDDR |LETTMP#1|)) - (SETQ |sb| - ((LAMBDA (|bfVar#13| |bfVar#11| |i| |bfVar#12| |j|) - (LOOP - (COND - ((OR (ATOM |bfVar#11|) - (PROGN (SETQ |i| (CAR |bfVar#11|)) NIL) - (ATOM |bfVar#12|) - (PROGN (SETQ |j| (CAR |bfVar#12|)) NIL)) - (RETURN (NREVERSE |bfVar#13|))) - ('T - (SETQ |bfVar#13| - (CONS (CONS |i| |j|) |bfVar#13|)))) - (SETQ |bfVar#11| (CDR |bfVar#11|)) - (SETQ |bfVar#12| (CDR |bfVar#12|)))) - NIL |nargl| NIL |sgargl| NIL)) - (SETQ |body| (SUBLIS |sb| |body|)) - (SETQ |sb2| - ((LAMBDA (|bfVar#16| |bfVar#14| |i| |bfVar#15| |j|) - (LOOP - (COND - ((OR (ATOM |bfVar#14|) - (PROGN (SETQ |i| (CAR |bfVar#14|)) NIL) - (ATOM |bfVar#15|) - (PROGN (SETQ |j| (CAR |bfVar#15|)) NIL)) - (RETURN (NREVERSE |bfVar#16|))) - ('T - (SETQ |bfVar#16| - (CONS (LIST 'CONS (LIST 'QUOTE |i|) |j|) - |bfVar#16|)))) - (SETQ |bfVar#14| (CDR |bfVar#14|)) - (SETQ |bfVar#15| (CDR |bfVar#15|)))) - NIL |sgargl| NIL |largl| NIL)) - (SETQ |body| - (LIST 'SUBLIS (CONS 'LIST |sb2|) (LIST 'QUOTE |body|))) - (SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|)) - (SETQ |def| (LIST |op| |lamex|)) - (|bfTuple| - (CONS (|shoeComp| |def|) - ((LAMBDA (|bfVar#18| |bfVar#17| |d|) - (LOOP - (COND - ((OR (ATOM |bfVar#17|) - (PROGN (SETQ |d| (CAR |bfVar#17|)) NIL)) - (RETURN (NREVERSE |bfVar#18|))) - ('T - (SETQ |bfVar#18| - (APPEND (REVERSE - (|shoeComps| (|bfDef1| |d|))) - |bfVar#18|)))) - (SETQ |bfVar#17| (CDR |bfVar#17|)))) - NIL |$wheredefs| NIL))))))) - -(DEFUN |bfGargl| (|argl|) - (PROG (|f| |d| |c| |b| |a| |LETTMP#1|) - (RETURN - (COND - ((NULL |argl|) (LIST NIL NIL NIL NIL)) - ('T (SETQ |LETTMP#1| (|bfGargl| (CDR |argl|))) - (SETQ |a| (CAR |LETTMP#1|)) (SETQ |b| (CADR |LETTMP#1|)) - (SETQ |c| (CADDR |LETTMP#1|)) (SETQ |d| (CADDDR |LETTMP#1|)) - (COND - ((EQ (CAR |argl|) '&REST) - (LIST (CONS (CAR |argl|) |b|) |b| |c| - (CONS (LIST 'CONS (LIST 'QUOTE 'LIST) (CAR |d|)) - (CDR |d|)))) - ('T (SETQ |f| (|bfGenSymbol|)) - (LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|) - (CONS |f| |d|))))))))) - -(DEFUN |bfDef1| (|bfVar#19|) - (PROG (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args| - |op| |defOp|) - (RETURN - (PROGN - (SETQ |defOp| (CAR |bfVar#19|)) - (SETQ |op| (CADR |bfVar#19|)) - (SETQ |args| (CADDR |bfVar#19|)) - (SETQ |body| (CADDDR |bfVar#19|)) - (SETQ |argl| - (COND - ((|bfTupleP| |args|) (CDR |args|)) - ('T (LIST |args|)))) - (SETQ |LETTMP#1| (|bfInsertLet| |argl| |body|)) - (SETQ |quotes| (CAR |LETTMP#1|)) - (SETQ |control| (CADR |LETTMP#1|)) - (SETQ |arglp| (CADDR |LETTMP#1|)) - (SETQ |body| (CADDDR |LETTMP#1|)) - (COND - (|quotes| (|shoeLAM| |op| |arglp| |control| |body|)) - ('T (LIST (LIST |op| (LIST 'LAMBDA |arglp| |body|))))))))) - -(DEFUN |shoeLAM| (|op| |args| |control| |body|) - (PROG (|innerfunc| |margs|) - (RETURN - (PROGN - (SETQ |margs| (|bfGenSymbol|)) - (SETQ |innerfunc| (INTERN (CONCAT (PNAME |op|) '|,LAM|))) - (LIST (LIST |innerfunc| (LIST 'LAMBDA |args| |body|)) - (LIST |op| - (LIST 'MLAMBDA (LIST '&REST |margs|) - (LIST 'CONS (LIST 'QUOTE |innerfunc|) - (LIST 'WRAP |margs| - (LIST 'QUOTE |control|)))))))))) - -(DEFUN |bfDef| (|defOp| |op| |args| |body|) - (PROG (|body1| |arg1| |op1| |LETTMP#1|) - (DECLARE (SPECIAL |$wheredefs| |$bfClamming|)) - (RETURN - (COND - (|$bfClamming| - (PROGN - (SETQ |LETTMP#1| - (|shoeComp| - (CAR (|bfDef1| - (LIST |defOp| |op| |args| |body|))))) - (SETQ |op1| (CADR |LETTMP#1|)) - (SETQ |arg1| (CADDR |LETTMP#1|)) - (SETQ |body1| (CDDDR |LETTMP#1|)) - (|bfCompHash| |op1| |arg1| |body1|))) - ('T - (|bfTuple| - ((LAMBDA (|bfVar#21| |bfVar#20| |d|) - (LOOP - (COND - ((OR (ATOM |bfVar#20|) - (PROGN (SETQ |d| (CAR |bfVar#20|)) NIL)) - (RETURN (NREVERSE |bfVar#21|))) - ('T - (SETQ |bfVar#21| - (APPEND (REVERSE - (|shoeComps| (|bfDef1| |d|))) - |bfVar#21|)))) - (SETQ |bfVar#20| (CDR |bfVar#20|)))) - NIL (CONS (LIST |defOp| |op| |args| |body|) |$wheredefs|) - NIL))))))) - -(DEFUN |shoeComps| (|x|) - (PROG () - (RETURN - ((LAMBDA (|bfVar#23| |bfVar#22| |def|) - (LOOP - (COND - ((OR (ATOM |bfVar#22|) - (PROGN (SETQ |def| (CAR |bfVar#22|)) NIL)) - (RETURN (NREVERSE |bfVar#23|))) - ('T - (SETQ |bfVar#23| (CONS (|shoeComp| |def|) |bfVar#23|)))) - (SETQ |bfVar#22| (CDR |bfVar#22|)))) - NIL |x| NIL)))) - -(DEFUN |shoeComp| (|x|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|shoeCompTran| (CADR |x|))) - (COND - ((EQCAR |a| 'LAMBDA) - (CONS 'DEFUN (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|))))) - ('T - (CONS 'DEFMACRO - (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|)))))))))) - -(DEFUN |bfInsertLet| (|x| |body|) - (PROG (|body2| |name2| |norq1| |b1| |body1| |name1| |norq| |LETTMP#1| - |b| |a| |ISTMP#1|) - (RETURN - (COND - ((NULL |x|) (LIST NIL NIL |x| |body|)) - ((AND (CONSP |x|) (EQ (CAR |x|) '&REST) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) 'T)))) - (COND - ((AND (CONSP |a|) (EQ (CAR |a|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |a|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |b| (CAR |ISTMP#1|)) 'T)))) - (LIST T 'QUOTE (LIST '&REST |b|) |body|)) - ('T (LIST NIL NIL |x| |body|)))) - ('T (SETQ |LETTMP#1| (|bfInsertLet1| (CAR |x|) |body|)) - (SETQ |b| (CAR |LETTMP#1|)) (SETQ |norq| (CADR |LETTMP#1|)) - (SETQ |name1| (CADDR |LETTMP#1|)) - (SETQ |body1| (CADDDR |LETTMP#1|)) - (SETQ |LETTMP#1| (|bfInsertLet| (CDR |x|) |body1|)) - (SETQ |b1| (CAR |LETTMP#1|)) (SETQ |norq1| (CADR |LETTMP#1|)) - (SETQ |name2| (CADDR |LETTMP#1|)) - (SETQ |body2| (CADDDR |LETTMP#1|)) - (LIST (OR |b| |b1|) (CONS |norq| |norq1|) - (CONS |name1| |name2|) |body2|)))))) - -(DEFUN |bfInsertLet1| (|y| |body|) - (PROG (|g| |b| |r| |ISTMP#2| |l| |ISTMP#1|) - (RETURN - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'L%T) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |l| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T)))))) - (LIST NIL NIL |l| - (|bfMKPROGN| (LIST (|bfLET| |r| |l|) |body|)))) - ((IDENTP |y|) (LIST NIL NIL |y| |body|)) - ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |b| (CAR |ISTMP#1|)) 'T)))) - (LIST T 'QUOTE |b| |body|)) - ('T (SETQ |g| (|bfGenSymbol|)) - (COND - ((ATOM |y|) (LIST NIL NIL |g| |body|)) - ('T - (LIST NIL NIL |g| - (|bfMKPROGN| - (LIST (|bfLET| (|compFluidize| |y|) |g|) |body|)))))))))) - -(DEFUN |shoeCompTran| (|x|) - (PROG (|$dollarVars| |$locVars| |$fluidVars| |fvs| |fl| |fvars| - |lvars| |body| |args| |lamtype|) - (DECLARE (SPECIAL |$typings| |$dollarVars| |$fluidVars| |$locVars|)) - (RETURN - (PROGN - (SETQ |lamtype| (CAR |x|)) - (SETQ |args| (CADR |x|)) - (SETQ |body| (CDDR |x|)) - (SETQ |$fluidVars| NIL) - (SETQ |$locVars| NIL) - (SETQ |$dollarVars| NIL) - (|shoeCompTran1| |body|) - (SETQ |$locVars| - (SETDIFFERENCE (SETDIFFERENCE |$locVars| |$fluidVars|) - (|shoeATOMs| |args|))) - (SETQ |body| - (COND - ((OR |$fluidVars| |$locVars| |$dollarVars| |$typings|) - (SETQ |lvars| (APPEND |$fluidVars| |$locVars|)) - (SETQ |$fluidVars| (UNION |$fluidVars| |$dollarVars|)) - (COND - ((NULL |$fluidVars|) - (COND - ((NULL |$typings|) (|shoePROG| |lvars| |body|)) - ('T - (|shoePROG| |lvars| - (CONS (CONS 'DECLARE |$typings|) |body|))))) - ('T - (SETQ |fvars| - (LIST 'DECLARE (CONS 'SPECIAL |$fluidVars|))) - (COND - ((NULL |$typings|) - (|shoePROG| |lvars| (CONS |fvars| |body|))) - ('T - (|shoePROG| |lvars| - (CONS |fvars| - (CONS (CONS 'DECLARE |$typings|) - |body|)))))))) - ('T (|shoePROG| NIL |body|)))) - (SETQ |fl| (|shoeFluids| |args|)) - (SETQ |body| - (COND - (|fl| (SETQ |fvs| (LIST 'DECLARE (CONS 'SPECIAL |fl|))) - (CONS |fvs| |body|)) - ('T |body|))) - (CONS |lamtype| (CONS |args| |body|)))))) - -(DEFUN |shoePROG| (|v| |b|) - (PROG (|blist| |blast| |LETTMP#1|) - (RETURN - (COND - ((NULL |b|) (LIST (LIST 'PROG |v|))) - ('T - (PROGN - (SETQ |LETTMP#1| (REVERSE |b|)) - (SETQ |blast| (CAR |LETTMP#1|)) - (SETQ |blist| (NREVERSE (CDR |LETTMP#1|))) - (LIST (CONS 'PROG - (CONS |v| - (APPEND |blist| - (CONS (LIST 'RETURN |blast|) NIL))))))))))) - -(DEFUN |shoeFluids| (|x|) - (PROG () - (RETURN - (COND - ((NULL |x|) NIL) - ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) (LIST |x|)) - ((EQCAR |x| 'QUOTE) NIL) - ((ATOM |x|) NIL) - ('T (APPEND (|shoeFluids| (CAR |x|)) (|shoeFluids| (CDR |x|)))))))) - -(DEFUN |shoeATOMs| (|x|) - (PROG () - (RETURN - (COND - ((NULL |x|) NIL) - ((ATOM |x|) (LIST |x|)) - ('T (APPEND (|shoeATOMs| (CAR |x|)) (|shoeATOMs| (CDR |x|)))))))) - -(DEFUN |shoeCompTran1| (|x|) - (PROG (|res| |newbindings| |r| |ISTMP#2| |l| |ISTMP#1| U) - (DECLARE (SPECIAL |$fluidVars| |$locVars| |$dollarVars|)) - (RETURN - (COND - ((ATOM |x|) - (COND - ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) - (SETQ |$dollarVars| - (COND - ((MEMQ |x| |$dollarVars|) |$dollarVars|) - ('T (CONS |x| |$dollarVars|))))) - ('T NIL))) - ('T - (PROGN - (SETQ U (CAR |x|)) - (COND - ((EQ U 'QUOTE) NIL) - ((AND (CONSP |x|) (EQ (CAR |x|) 'L%T) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |l| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T)))))) - (PROGN - (RPLACA |x| 'SETQ) - (|shoeCompTran1| |r|) - (COND - ((IDENTP |l|) - (COND - ((NULL (|bfBeginsDollar| |l|)) - (SETQ |$locVars| - (COND - ((MEMQ |l| |$locVars|) |$locVars|) - ('T (CONS |l| |$locVars|))))) - ('T - (SETQ |$dollarVars| - (COND - ((MEMQ |l| |$dollarVars|) |$dollarVars|) - ('T (CONS |l| |$dollarVars|))))))) - ((EQCAR |l| 'FLUID) - (PROGN - (SETQ |$fluidVars| - (COND - ((MEMQ (CADR |l|) |$fluidVars|) - |$fluidVars|) - ('T (CONS (CADR |l|) |$fluidVars|)))) - (RPLACA (CDR |x|) (CADR |l|))))))) - ((MEMQ U '(PROG LAMBDA)) - (PROGN - (SETQ |newbindings| NIL) - ((LAMBDA (|bfVar#24| |y|) - (LOOP - (COND - ((OR (ATOM |bfVar#24|) - (PROGN (SETQ |y| (CAR |bfVar#24|)) NIL)) - (RETURN NIL)) - ('T - (COND - ((NULL (MEMQ |y| |$locVars|)) - (IDENTITY - (PROGN - (SETQ |$locVars| - (CONS |y| |$locVars|)) - (SETQ |newbindings| - (CONS |y| |newbindings|)))))))) - (SETQ |bfVar#24| (CDR |bfVar#24|)))) - (CADR |x|) NIL) - (SETQ |res| (|shoeCompTran1| (CDDR |x|))) - (SETQ |$locVars| - ((LAMBDA (|bfVar#26| |bfVar#25| |y|) - (LOOP - (COND - ((OR (ATOM |bfVar#25|) - (PROGN - (SETQ |y| (CAR |bfVar#25|)) - NIL)) - (RETURN (NREVERSE |bfVar#26|))) - ('T - (AND (NULL (MEMQ |y| |newbindings|)) - (SETQ |bfVar#26| - (CONS |y| |bfVar#26|))))) - (SETQ |bfVar#25| (CDR |bfVar#25|)))) - NIL |$locVars| NIL)))) - ('T - (PROGN - (|shoeCompTran1| (CAR |x|)) - (|shoeCompTran1| (CDR |x|))))))))))) - -(DEFUN |bfTagged| (|a| |b|) - (PROG () - (DECLARE (SPECIAL |$typings|)) - (RETURN - (COND - ((IDENTP |a|) - (COND - ((EQ |b| 'FLUID) (|bfLET| (|compFluid| |a|) NIL)) - ((EQ |b| '|fluid|) (|bfLET| (|compFluid| |a|) NIL)) - ((EQ |b| '|local|) (|bfLET| (|compFluid| |a|) NIL)) - ('T - (PROGN - (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|)) - |a|)))) - ('T (LIST 'THE |b| |a|)))))) - -(DEFUN |bfAssign| (|l| |r|) - (PROG () - (RETURN - (COND - ((|bfTupleP| |l|) (|bfSetelt| (CADR |l|) (CDDR |l|) |r|)) - ('T (|bfLET| |l| |r|)))))) - -(DEFUN |bfSetelt| (|e| |l| |r|) - (PROG () - (RETURN - (COND - ((NULL (CDR |l|)) (|defSETELT| |e| (CAR |l|) |r|)) - ('T (|bfSetelt| (|bfElt| |e| (CAR |l|)) (CDR |l|) |r|)))))) - -(DEFUN |bfElt| (|expr| |sel|) - (PROG (|y|) - (RETURN - (PROGN - (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION))) - (COND - (|y| (COND - ((INTEGERP |y|) (LIST 'ELT |expr| |y|)) - ('T (LIST |y| |expr|)))) - ('T (LIST 'ELT |expr| |sel|))))))) - -(DEFUN |defSETELT| (|var| |sel| |expr|) - (PROG (|y|) - (RETURN - (PROGN - (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION))) - (COND - (|y| (COND - ((INTEGERP |y|) - (LIST 'SETF (LIST 'ELT |var| |y|) |expr|)) - ('T (LIST 'SETF (LIST |y| |var|) |expr|)))) - ('T (LIST 'SETF (LIST 'ELT |var| |sel|) |expr|))))))) - -(DEFUN |bfIfThenOnly| (|a| |b|) - (PROG (|b1|) - (RETURN - (PROGN - (SETQ |b1| - (COND ((EQCAR |b| 'PROGN) (CDR |b|)) ('T (LIST |b|)))) - (LIST 'COND (CONS |a| |b1|)))))) - -(DEFUN |bfIf| (|a| |b| |c|) - (PROG (|c1| |b1|) - (RETURN - (PROGN - (SETQ |b1| - (COND ((EQCAR |b| 'PROGN) (CDR |b|)) ('T (LIST |b|)))) - (COND - ((EQCAR |c| 'COND) - (CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|)))) - ('T - (PROGN - (SETQ |c1| - (COND - ((EQCAR |c| 'PROGN) (CDR |c|)) - ('T (LIST |c|)))) - (LIST 'COND (CONS |a| |b1|) (CONS ''T |c1|))))))))) - -(DEFUN |bfExit| (|a| |b|) - (PROG () (RETURN (LIST 'COND (LIST |a| (LIST 'IDENTITY |b|)))))) - -(DEFUN |bfMKPROGN| (|l|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| - ((LAMBDA (|bfVar#27| |c|) - (LOOP - (COND - ((ATOM |c|) (RETURN (NREVERSE |bfVar#27|))) - ('T - (SETQ |bfVar#27| - (APPEND (REVERSE (|bfFlattenSeq| |c|)) - |bfVar#27|)))) - (SETQ |c| (CDR |c|)))) - NIL |l|)) - (COND - ((NULL |a|) NIL) - ((NULL (CDR |a|)) (CAR |a|)) - ('T (CONS 'PROGN |a|))))))) - -(DEFUN |bfFlattenSeq| (|x|) - (PROG (|f|) - (RETURN - (COND - ((NULL |x|) NIL) - ('T - (PROGN - (SETQ |f| (CAR |x|)) - (COND - ((ATOM |f|) (COND ((CDR |x|) NIL) ('T (LIST |f|)))) - ((EQCAR |f| 'PROGN) - (COND - ((CDR |x|) - ((LAMBDA (|bfVar#29| |bfVar#28| |i|) - (LOOP - (COND - ((OR (ATOM |bfVar#28|) - (PROGN (SETQ |i| (CAR |bfVar#28|)) NIL)) - (RETURN (NREVERSE |bfVar#29|))) - ('T - (AND (NULL (ATOM |i|)) - (SETQ |bfVar#29| (CONS |i| |bfVar#29|))))) - (SETQ |bfVar#28| (CDR |bfVar#28|)))) - NIL (CDR |f|) NIL)) - ('T (CDR |f|)))) - ('T (LIST |f|))))))))) - -(DEFUN |bfSequence| (|l|) - (PROG (|f| |aft| |before| |no| |transform| |b| |ISTMP#5| |ISTMP#4| - |ISTMP#3| |a| |ISTMP#2| |ISTMP#1|) - (RETURN - (COND - ((NULL |l|) NIL) - ('T - (PROGN - (SETQ |transform| - ((LAMBDA (|bfVar#31| |bfVar#30| |x|) - (LOOP - (COND - ((OR (ATOM |bfVar#30|) - (PROGN (SETQ |x| (CAR |bfVar#30|)) NIL) - (NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (EQ (CDR |ISTMP#1|) NIL) - (PROGN - (SETQ |ISTMP#2| - (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |a| - (CAR |ISTMP#2|)) - (SETQ |ISTMP#3| - (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CDR |ISTMP#3|) - NIL) - (PROGN - (SETQ |ISTMP#4| - (CAR |ISTMP#3|)) - (AND - (CONSP |ISTMP#4|) - (EQ (CAR |ISTMP#4|) - 'IDENTITY) - (PROGN - (SETQ |ISTMP#5| - (CDR |ISTMP#4|)) - (AND - (CONSP |ISTMP#5|) - (EQ - (CDR |ISTMP#5|) - NIL) - (PROGN - (SETQ |b| - (CAR - |ISTMP#5|)) - 'T)))))))))))))) - (RETURN (NREVERSE |bfVar#31|))) - ('T - (SETQ |bfVar#31| - (CONS (LIST |a| |b|) |bfVar#31|)))) - (SETQ |bfVar#30| (CDR |bfVar#30|)))) - NIL |l| NIL)) - (SETQ |no| (LENGTH |transform|)) - (SETQ |before| (|bfTake| |no| |l|)) - (SETQ |aft| (|bfDrop| |no| |l|)) - (COND - ((NULL |before|) - (COND - ((NULL (CDR |l|)) - (PROGN - (SETQ |f| (CAR |l|)) - (COND - ((EQCAR |f| 'PROGN) (|bfSequence| (CDR |f|))) - ('T |f|)))) - ('T - (|bfMKPROGN| - (LIST (CAR |l|) (|bfSequence| (CDR |l|))))))) - ((NULL |aft|) (CONS 'COND |transform|)) - ('T - (CONS 'COND - (APPEND |transform| - (CONS (LIST ''T (|bfSequence| |aft|)) NIL))))))))))) - -(DEFUN |bfWhere| (|context| |expr|) - (PROG (|a| |body| |ISTMP#3| |args| |ISTMP#2| |op| |ISTMP#1| |def| - |nondefs| |defs| |opassoc| |LETTMP#1|) - (DECLARE (SPECIAL |$wheredefs|)) - (RETURN - (PROGN - (SETQ |LETTMP#1| (|defSheepAndGoats| |context|)) - (SETQ |opassoc| (CAR |LETTMP#1|)) - (SETQ |defs| (CADR |LETTMP#1|)) - (SETQ |nondefs| (CADDR |LETTMP#1|)) - (SETQ |a| - ((LAMBDA (|bfVar#33| |bfVar#32| |d|) - (LOOP - (COND - ((OR (ATOM |bfVar#32|) - (PROGN (SETQ |d| (CAR |bfVar#32|)) NIL)) - (RETURN (NREVERSE |bfVar#33|))) - ('T - (AND (CONSP |d|) - (PROGN - (SETQ |def| (CAR |d|)) - (SETQ |ISTMP#1| (CDR |d|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |op| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |args| (CAR |ISTMP#2|)) - (SETQ |ISTMP#3| (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CDR |ISTMP#3|) NIL) - (PROGN - (SETQ |body| (CAR |ISTMP#3|)) - 'T))))))) - (SETQ |bfVar#33| - (CONS (LIST |def| |op| |args| - (|bfSUBLIS| |opassoc| |body|)) - |bfVar#33|))))) - (SETQ |bfVar#32| (CDR |bfVar#32|)))) - NIL |defs| NIL)) - (SETQ |$wheredefs| (APPEND |a| |$wheredefs|)) - (|bfMKPROGN| - (|bfSUBLIS| |opassoc| (NCONC |nondefs| (LIST |expr|)))))))) - -(DEFUN |bfReadLisp| (|string|) - (PROG () (RETURN (|bfTuple| (|shoeReadLispString| |string| 0))))) - -;;(DEFUN |shoeReadLispString| (|s| |n|) -;; (PROG (|ind| |exp| |LETTMP#1|) -;; (RETURN -;; (COND -;; ((NOT (< |n| (LENGTH |s|))) NIL) -;; ('T -;; (PROGN -;; (SETQ |LETTMP#1| (|shoeReadLisp| |s| |n|)) -;; (SETQ |exp| (CAR |LETTMP#1|)) -;; (SETQ |ind| (CADR |LETTMP#1|)) -;; (COND -;; ((NULL |exp|) NIL) -;; ('T (CONS |exp| (|shoeReadLispString| |s| |ind|)))))))))) - -(DEFUN |shoeReadLispString| (|s| |n|) - (PROG (|l|) - (RETURN - (PROGN - (SETQ |l| (LENGTH |s|)) - (COND - ((NOT (< |n| |l|)) NIL) - ('T - (READ-FROM-STRING - (CONCAT '|(| (SUBSTRING |s| |n| (- |l| |n|)) '|)|)))))))) - -(DEFUN |bfCompHash| (|op| |argl| |body|) - (PROG (|computeFunction| |auxfn|) - (RETURN - (PROGN - (SETQ |auxfn| (INTERN (CONCAT (PNAME |op|) ";"))) - (SETQ |computeFunction| - (CONS 'DEFUN (CONS |auxfn| (CONS |argl| |body|)))) - (|bfTuple| (CONS |computeFunction| (|bfMain| |auxfn| |op|))))))) - -(DEFUN |bfMain| (|auxfn| |op|) - (PROG (|cacheVector| |cacheCountCode| |cacheResetCode| |cacheType| - |mainFunction| |codeBody| |thirdPredPair| |putCode| - |secondPredPair| |getCode| |g2| |cacheName| |computeValue| - |arg| |g1|) - (RETURN - (PROGN - (SETQ |g1| (|bfGenSymbol|)) - (SETQ |arg| (LIST '&REST |g1|)) - (SETQ |computeValue| - (LIST 'APPLY (LIST 'FUNCTION |auxfn|) |g1|)) - (SETQ |cacheName| (INTERN (CONCAT (PNAME |op|) ";AL"))) - (SETQ |g2| (|bfGenSymbol|)) - (SETQ |getCode| (LIST 'GETHASH |g1| |cacheName|)) - (SETQ |secondPredPair| (LIST (LIST 'SETQ |g2| |getCode|) |g2|)) - (SETQ |putCode| (LIST 'SETF |getCode| |computeValue|)) - (SETQ |thirdPredPair| (LIST ''T |putCode|)) - (SETQ |codeBody| - (LIST 'PROG (LIST |g2|) - (LIST 'RETURN - (LIST 'COND |secondPredPair| |thirdPredPair|)))) - (SETQ |mainFunction| (LIST 'DEFUN |op| |arg| |codeBody|)) - (SETQ |cacheType| '|hash-table|) - (SETQ |cacheResetCode| - (LIST 'SETQ |cacheName| - (LIST 'MAKE-HASHTABLE (LIST 'QUOTE 'UEQUAL)))) - (SETQ |cacheCountCode| (LIST '|hashCount| |cacheName|)) - (SETQ |cacheVector| - (LIST |op| |cacheName| |cacheType| |cacheResetCode| - |cacheCountCode|)) - (LIST |mainFunction| - (|shoeEVALANDFILEACTQ| - (LIST 'SETF - (LIST 'GET (LIST 'QUOTE |op|) - (LIST 'QUOTE '|cacheInfo|)) - (LIST 'QUOTE |cacheVector|))) - (|shoeEVALANDFILEACTQ| |cacheResetCode|)))))) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document}