Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.

Dismiss

IVY version 2

5 views

Skip to first unread message

Joseph H Allen

unread,

Sep 30, 1993, 1:07:41 PM9/30/93

Archive-name: ivy2/part1
Submitted-by: jha...@world.std.com

---- Cut Here and feed the following to sh ----
#!/bin/sh
# This is a shell archive (produced by shar 3.50)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 09/30/1993 17:04 UTC by jhallen@world
# Source directory /home/foyer/jhallen/ivy
#
# existing files will NOT be overwritten unless -c is specified
#
# This is part 1 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
#
# This shar contains:
# length mode name
# ------ ---------- ------------------------------------------
# 14619 -rw------- README
# 778 -rw------- TODO
# 18616 -rw------- codegen.c
# 945 -rw------- codegen.h
# 21335 -rw------- compile.c
# 3553 -rw------- compile.h
# 1549 -rw------- main.c
# 111 -rw------- makefile
# 2055 -rw------- rtlib.c
# 20966 -rw------- run.c
# 4994 -rw------- run.h
# 377 -rw------- sort.i
#
if test -r _shar_seq_.tmp; then
echo 'Must unpack archives in sequence!'
echo Please unpack part `cat _shar_seq_.tmp` next
exit 1
fi
# ============= README ==============
if test -f 'README' -a X"$1" != X"-c"; then
echo 'x - skipping README (File already exists)'
rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting README (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'README' &&
X Ivy (version 2)
X Preliminary Manual
X
INTRODUCTION
X
X Ivy is an embeddable byte-code compiled/interpreted language which
is useful as both an extension and a command language. Its syntax is
designed to be easy to learn and to be fairly good looking. Ivy currently
supports four data types: integers, strings, functions and objects. Objects
are late-binding storage devices which take the role of arrays, structures
and simple look-up tables. Floating point or arbitrary length floating
point numbers will be available in a future implementation. Ivy comes
packaged as an interactive language like BASIC and LISP. You can either
execute language statements immediately from the keyboard or run a program
stored in a file. Ivy is also easy to embed into another program. Calls
are provided to execute Ivy code and to add C function extensions to Ivy's
interpreter.
X
X
COMMAND FORMAT
X
X ivy [-u] [-t] [filenames...]
X
X If no filenames are given, ivy takes input from the keyboard
X
X -t is a debugging aid which displays the parse tree as
X commands are entered
X
X -u is a debugging aid which unassembles the byte-code as
X it's made
X
PROGRAM STRUCTURE
X
X Whenever a command or expression is encounted outside of a block, it
is executed immediately. A command is a function or statement name followed
by expressions.
X
X command-name expr expr expr ...
X
X print "Hello world"
X
X The expressions get evaluated and their results are passed to the
command as arguments. Multiple expressions or multiple expressions followed
by a command may be placed on a line:
X
X expr expr expr ...
X expr expr expr ... command-name expr expr expr ...
X
X a="Hello" b="World" print a b
X
X Multiple commands may also be placed on a line, but they must be
separated by semicolons (the ';' can be dropped if the command happens to
begin with a keyword):
X
X command ; command ; ...
X
X print "Hello" ; print "World"
X
X A command is really a function call and may be placed in an
expression as one:
X
X command-name[expr expr expr ...]
X
X print["Hello" "World"]
X
X Some statements also require a block of commands to follow them
('if' for example). Such statements can still be formulated as function
calls, but they may not be used inside of an expression unless they are
enclosed within parenthesis.
X
X print (if[1==1] "One equals one" else "One equals two")
X
X Commas may be used to separate the expressions, but they are not
needed. Ambiguities between operators which take multiple roles are
resolved by measuring how close the operators are to their operands. For
example:
X
X a + b - c # Two expressions, a+b and -c
X a + b - c # One expression, a+b-c
X
X In other words, the code is parsed how it looks (TABs are treated as
if there were tab stops every eight columns. A parser directive will be
added later to allow this to be changed).
X
X Expressions may also cross lines if it is necessary to do so for
them to complete:
X
X a + b # Two expressions, a+b and -c
X - c
X
X a + b - # One expression, a+b-c
X c
X
X When a statement requires a block of commands to follow it, two
options are available. The block may be composed of a single command on the
same line as the statement:
X
X if 1==1 print "One equals one"
X
X Or the block may be composed of multiple commands beginning on the
line following the statement:
X
X if 1==1
X print "One equals one"
X print "It certainly doesn't equal 2"
X
X Blocks end when there is no more input (in interactive mode, hit ^D
to end the current block) or, in keeping with the philosophy of having the
code parsed the way it looks, when the "indentation level" (the number of
columns at the beginning of the line) returns to that of the line containing
the command requiring the block. For example:
X
X if x==1
X print "X equals 1, not two"
X print "or three or anything else"
X if x==2
X print "X equals 2"
X
X Else associates with the if with the same indentation level, not, as
is usual, with the latest if. Thus the following code works as it is
printed:
X
X if x!=1
X if x==2
X print "X equals two"
X else
X print "X equals one"
X
CONSTANTS
X
X Integers may be entered in a variety of bases:
X
X x=0128 # Decimal
X x=$80 # Hexadecimal
X x=@200 # Octal
X x=%10000000 # Binary
X
X Also the ASCII value of a character may be taken as an integer:
X
X x='A # The value 65
X x='C' # The value 67 (the second ' is optional)
X x='' # The ASCII value for '
X x=''' # The ASCII value for '
X
X The following "escape sequences" may also be used in place of a
character:
X
X x='\n # New-line
X x='\r # Return
X x='\b # Backspace
X x='\t # Tab
X x='\a # Alert (bell)
X x='\e # ESC
X x='\f # Form-feed
X x='\^A # Ctrl-A (works for ^@ to ^_ and ^?)
X x='\010 # Octal for 8
X x='\xFF # Hexadecimal for 255
X x='\X # Any other character is returned as itself
X
X String constants are enclosed in double-quotes:
X
X
X x="Hello there"
X
X Escape sequences may also be used inside of strings.
X
EXPRESSIONS
X
X An expression is a single or dual operand operator, a constant, a
variable, a lambda function, commands enclosed within parenthesis, a
function call, or an object. Examples of each of these cases follow:
X
X ~expr Single operand
X
X expr+expr Dual operand
X
X 25 Constant
X
X (command ; ...) Commands or expressions inside of
X parenthesis (evaluates to the last
X expression or command)
X
X expr[expr ...] Function call
X
X {1, 2, 3, 4} An array object
X
X {`next=item `value=1} A structure object
X
X (::x y ; x*y)[3, 5] Calling a lambda function
X
OPERATORS
X
X Ivy uses a superset of operators from C but with the precedence
fixed. Here are the operators grouped from highest precedence to lowest:
X
X ` # Named argument
X
X . # Member selection
X
X [ ] # Function call
X
X - ~ ! ++ -- # Single operand
X
X << >> # Shift group
X
X * / & % # Multiply group
X
X + - | ^ # Add group
X
X == > < >= <= != # Comparison group
X
X && # Logical and
X
X || # Logical or
X
X = <<= >>= *= /= %= += -= |= ^= .= # Pre-assignments
X : <<: >>: *: /: %: +: -: |: ^: .: # Post-assignments
X
X \ # Sequential evaluation
X
X , # Sequential evaluation or argument
X # separation
X
X
X A detailed description of each operator follows:
X
X ` Named argument
X
X This operator can be used to explicitly state the argument
or member name in a command, function call or object. For example:
X
X open `name="joe.c", `mode="r"
X square[`x=5, `y=6]
X {`1=5 `0=7} # Array object
X {`x=10 `y=10} # Structure object
X
X . Member selection
X
X This operator is used to select a named member from an
object. For example:
X
X o={`x=5, `y=10} # Create an object
X print o.x # Print member x
X print o["x"] # Equivalent to above
X
X [ ] Function call
X
X This operator calls the function resulting from the
expression on the left with the argument inside of the brackets. This
operator can also be used for object member selection and for string
character selection and substring operations. Examples of each of these
follow:
X
X x.y[5] # Call function y in object x
X
X z[0]=1, z[1]=2 # Set numbered members of an object
X
X z["foo"]=3, z["bar"]=4 # Set named member of an object
X
X print "Hello"[0] # Prints 72
X
X print "Hello"[1,3] # Prints "el" (selects substring
X # beginning with first index and
X # end before second).
X
X a="Hello"
X a[0]='G
X a[5]=" there"
X print a # Prints "Gello there"
X # Overwrites characters in the
X # destination string and space-fills
X # if necessary.
X
X
X
X - Negate
X
X ~ Bit-wise one's complement
X
X ! Logical not
X
X ++ Pre or post increment depending on whether it precedes or follows
X a variable
X
X -- Pre or post decrement
X
X << Bit-wise shift left
X
X >> Bit-wise shift right
X
X * Multiply
X
X / Divide
X
X & Bit-wise AND
X
X % Modulus (Remainder)
X
X + Add or concatenate
X
X In addition to adding integers, this operand concatenates
X strings if strings are passed to it. For example:
X
X print "Hello"+" There" # Prints "Hello There"
X
X Add also adds a single item onto the end of an array. For
X example:
X
X a={1 2 3}
X a+=4 # a now is { 1 2 3 4 }
X
X - Subtract
X
X | Bit-wise OR
X
X If objects are given as arguments to OR, OR unions the
X objects together into a single object. If the objects have
X numerically referenced members, OR will append the array on the
X right to the array on the left. For example:
X
X a={1 2 3}
X b={4 5 6}
X a|=b # a now is {1 2 3 4 5 6}
X
X ^ Bit-wise Exclusive OR
X
X == Returns 1 (true) if arguments are equal or 0 (false) if arguments
X are not equal. Can be used for strings and numbers.
X
X > Greater than
X >= Greater than or equal to
X < Less than
X <= Less than or equal to
X != Not equal to
X
X && Logical and
X
X The right argument is only evaluated if the left argument is
X true (non-zero).
X
X || Logical or
X
X The right argument is evaluated only if the left argument is
X false (zero).
X
X \ Sequential evaluation
X
X The left and then the right argument are evaluated and the
X result of the right argument is returned.
X
X , Sequential evaluation or argument separator
X
X When this is used inside of [ ] or { } it is an argument
X separator. In those cases, \ should be used for sequential
X evaluation.
X
X = Pre assignment
X
X The right side is evaluated and the result is stored in the
X variable specified on the left side. The right side's result is
X also returned.
X
X : Post assignment
X
X The right side is evaluated and the result is stored in the
X variable specified on the left side. The left side's original value
X is returned.
X
X X= Pre-assignment group
X
X These translate directly into: "left = left X right"
X
X X: Post-assignment group
X
X These translate directly into: "left : left X right"
X
X Notes on assignment groups:
X
X .= translates into "left = left . right" and is
X useful for traversing linked lists. For example:
X
X for list=0\ x=0, x!=10, ++x # Build list
X list={`next=list, `value=x}
X
X for a=list, a, a.=next # Print list
X print a.value
X
X x+:1 Is the same as x++
X x+=1 Is the same as ++x
X
X a:b:c:5
X ':' is useful for shifting the value of variables
X around. In this example, a gets b, b gets c, and
X c gets 5.
X
X a:b:a
X ':' is also useful for swapping the values of
X variables. In this example, a gets swapped with
X b.
X
X
STATEMENTS
X
Function declaration:
X
X :name expr expr expr ... ; body
X
X :name expr expr expr ...
X body
X
X These declare functions. Here are some examples:
X
X :square x ; x*x
X
X :square[x] x*x
X
X :square x
X x*x
X
X square=(::x ; x*x)
X
X The last form uses "Lambda" (nameless) functions. You can
X also use lambda functions without assigning them:
X
X x=(::x ; x*x)[6] # x gets assigned 36
X
X You can also enclose the function arguments in square
X backets:
X
X x=(::[x] x*x)[6] # ; not needed
X
X
If statement
X
X if expr block
X else if expr block
X else block
X
X Note that 'else' does not work unless it is in a block.
X
Loop statement
X
X loop block
X
X The block gets repeatedly executed until a 'break' or
X 'until' statement within the block terminates the loop.
X
While statement
X
X while expr block
X
X The block is repeatedly executed if the expression is true.
X
For statement
X
X for expr1, expr2, expr3 block
X
X This is a shorthand for the follow while statement:
X
X expr1 while expr2
X block
X expr3
X
X Thus,
X expr1 is usually used as an index variable initializer
X expr2 is the loop test
X expr3 is the index variable incrementer
X
Return statement
X
X return
X
X return expr
X
X This exits the function it is executed in with the given
X return value or with the value of the last expression
X preceeding the return.
X
Break statement
X
X break
X
X break n
X
X This aborts the innermost or nth innermost loop
X
Continue statement
X
X continue
X
X continue n
X
X This jumps the beginning of the innermost or nth loop.
X
Until statement
X
X until expr
X
X This exits the loop it's in if the expression is true.
X
Local statement
X
X local a, b, c,... block
X
X This declares variables which are local to the block
X
With statement
X
X with x block
X
X The members of the object x look like local variables inside
X of the block.
X
Include statement
X
X include "string"
X
X Executes the file specified by the string.
X
X
FUNCTIONS
X
X When the block inside of a function gets control a special
variable becomes visible:
X
X argv Contains an object containing numbered members
X which are each set the arguments passed to the
X function.
X
X So for example, if the function:
X
X :x
X for a=0, a!=len[argv], ++a
X print argv[a]
X
X gets called as follows:
X
X x[1 2 3]
X
X The following gets printed:
X
X 1
X 2
X 3
X
X Default values may be specified for missing arguments in function
calls. For example if this function:
X
X :func x=5, y=6
X x*y
X
X Is called as follows:
X
X print func[1] # '6' is printed
X print func[] # '30' is printed
X print func[`y=7] # '35' is printed
X
X
X Functions may be assigned to variables and passed to functions. For
example you can define a function 'apply' which applies a function to an
argument:
X
X :apply x y
X return x[y]
X
X :square x
X return x*x
X
X print apply[square,5] # Prints 25
X
X
X Functions can return other functions. To do this 'return' must be
used since it forces its argument to be an expression (otherwise the
returned function name would look like a function call). For example:
X
X :square x
X return x*x
X
X :foo
X return square
X
X print foo[][4] # Prints 16
X
VARIABLES
X
X Variables set outside of functions are global variables. They will
be visible in any block unless 'local' is used to make local variables.
X
X If a variable is set inside of a function and there is no global
variable of the same name, that variable will be local to the block it was
assigned in.
X
X
OBJECTS
X
X Objects can be created either member by member:
X
X o.a=5
X o.b=6
X
X or all at once:
X
X o={`a=5, `b=6}
X
X Objects are assigned by reference. This means that if you have an
object in one variable:
X
X x={1 2 3}
X
X And you assign it to another:
X
X y=x
X
X And then change one of the members of x:
X
X x[0]=5
X
X Then the change will appear both in x and in y
X
X
COMMENTS
X
X Everything from any # not in a string or string constant to the
end of the line is a comment.
X
X
FUNCTION LIBRARY
X
X len[a]
X
X Returns the length of string 'a' or number of element in
X array 'a'
X
X print[...]
X
X Prints the arguments
X
X a=get[]
X
X Get a line of input as a string
X
X x=atoi["2"]
X
X Converts a string to a number
X
X s=itoa[20]
X
X Convert a number to a string
SHAR_EOF
chmod 0600 README ||
echo 'restore of README failed'
Wc_c="`wc -c < 'README'`"
test 14619 -eq "$Wc_c" ||
echo 'README: original size 14619, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= TODO ==============
if test -f 'TODO' -a X"$1" != X"-c"; then
echo 'x - skipping TODO (File already exists)'
rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting TODO (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'TODO' &&
=-=-=-=-=
# Need simple data object initialization syntax
X
.name Create object called 'name' set to...
X inherit name
X clear name
X name 5
X name 10
X .name
X name 10
X name 20
X
- Should do set subtraction on arrays
X
& Should do set intersection on arrays
X
clear x Fee a variable: Need by reference args to do this
X
dup(x) Copy an object non-recusively
X
foreach Need by reference args to do this
X
make include take an expression instead of a string
X
should make an eval() function of some sort
X
=-=-=-=-=
Get stack depth recording straigtened out
X
=-=-=-=-=
Errors should fail a compile
Should either return a parse-tree or not return one.
X
=-=-=-=-=
By-reference variables? function args?
X
=-=-=-=-=
User definable function operators
User adjustable tab width
SHAR_EOF
chmod 0600 TODO ||
echo 'restore of TODO failed'
Wc_c="`wc -c < 'TODO'`"
test 778 -eq "$Wc_c" ||
echo 'TODO: original size 778, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= codegen.c ==============
if test -f 'codegen.c' -a X"$1" != X"-c"; then
echo 'x - skipping codegen.c (File already exists)'
rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting codegen.c (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'codegen.c' &&
/* Code generator
X Copyright (C) 1993 Joseph H. Allen
X
This file is part of IVY
X
IVY is free software; you can redistribute it and/or modify it under the
terms of the GNU General Public License as published by the Free Software
Foundation; either version 1, or (at your option) any later version.
X
IVY is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
details.
X
You should have received a copy of the GNU General Public License along with
IVY; see the file COPYING. If not, write to the Free Software Foundation,
675 Mass Ave, Cambridge, MA 02139, USA. */
X
#include <string.h>
#include <stdio.h>
#include "run.h"
#include "compile.h"
#include "codegen.h"
X
/* Code block being built */
static int *begcode; /* Start of the current block of code */
static int *code; /* Current address we're writing to */
static int codesize; /* Size of code-block */
X
static int rtn; /* List of offsets to return point */
X
static int curdepth; /* Stack depth recorder */
static int maxdepth;
static int itmdepth;
X
static int scopelvl; /* Current scoping level */
X
static int genl();
static void setlist();
static void addlist();
static int genbra();
static void gen();
static int genn();
X
/* Code block building functions */
X
/* Create a new code block */
X
void newcode()
X {
X begcode=code=(int *)malloc(sizeof(int)*(codesize=128));
X }
X
/* Append an integer to the code block */
X
int exemit(z)
X {
X int cod=code-begcode;
X begcode=(int *)realloc(begcode,sizeof(int)*(codesize+=128));
X code=begcode+cod;
X return *code++=z;
X }
X
#define emit(z) ((code==begcode+codesize)?exemit(z):(*code++=(z)))
X
/* Append a string to the code block */
X
void emits(s,len)
char *s;
X {
X int size=(len+sizeof(int))/sizeof(int);
X int x;
X emit(len);
X if(code+size>begcode+codesize)
X {
X int cod=code-begcode;
X begcode=(int *)realloc(begcode,sizeof(int)*(codesize+=128+size));
X code=begcode+cod;
X }
X for(x=0;x!=len;++x) ((char *)code)[x]=s[x];
X ((char *)code)[x]=0;
X code+=size;
X }
X
/* Stack depth recorder */
X
void psh(x)
X {
X emit(iPSH);
X emit(x);
X ++curdepth;
X ++itmdepth;
X if(curdepth>maxdepth) maxdepth=curdepth;
X }
X
void pop()
X {
X curdepth-=itmdepth;
X itmdepth=0;
X }
X
/* Tree printer */
X
void indent(x) { while(x--) printf(" "); }
X
void prtree(n,lvl)
NODE *n;
X {
X int x;
X if(n->what==&nNUM) indent(lvl), printf("%d",n->n);
X else if(n->what==&nSTR) indent(lvl), printf("\"%s\"",n->s);
X else if(n->what==&nVOID) indent(lvl), printf("VOID");
X else if(n->s) indent(lvl), printf("%s",n->s);
X else
X {
X indent(lvl), printf("(%s\n",n->what->name);
X if(n->l) prtree(n->l,lvl+2);
X if(n->r) prtree(n->r,lvl+2);
X indent(lvl), printf(")");
X }
X printf("\n");
X }
X
/* Disassembler */
X
void disasm(c)
int *c;
X {
X printf("; Max stack depth %d\n",*c++);
X for(;;) switch(*c++)
X {
X case iBRA: printf(" bra %d\n",*c++); break;
X case iBEQ: printf(" beq %d\n",*c++); break;
X case iBNE: printf(" bne %d\n",*c++); break;
X case iBGT: printf(" bgt %d\n",*c++); break;
X case iBLT: printf(" blt %d\n",*c++); break;
X case iBGE: printf(" bge %d\n",*c++); break;
X case iBLE: printf(" ble %d\n",*c++); break;
X case iCOM: printf(" com\n"); break;
X case iNEG: printf(" neg\n"); break;
X case iSHL: printf(" shl\n"); break;
X case iSHR: printf(" shr\n"); break;
X case iMUL: printf(" mul\n"); break;
X case iDIV: printf(" div\n"); break;
X case iMOD: printf(" mod\n"); break;
X case iAND: printf(" and\n"); break;
X case iADD: printf(" add\n"); break;
X case iSUB: printf(" sub\n"); break;
X case iOR: printf(" or\n"); break;
X case iXOR: printf(" xor\n"); break;
X case iCMP: printf(" cmp\n"); break;
X case iBEG: printf(" beg\n"); break;
X case iEND: printf(" end\n"); break;
X case iLOC: printf(" loc\n"); break;
X case iWTH: printf(" wth\n"); break;
X case iGET: printf(" get\n"); break;
X case iLEA: printf(" lea\n"); break;
X case iSET: printf(" set\n"); break;
X case iCALL: printf(" call\n"); break;
X case iCALLA: printf(" calla\n"); break;
X case iRTS: printf(" rts\n"); return;
X case iPOP: printf(" pop\n"); break;
X case iPSH:
X switch(*c++)
X {
X case tNUM: printf(" psh %d\n",*c++); break;
X case tSTR: printf(" psh \"%s\"\n",c+1); c+=(*c+sizeof(int))/sizeof(int)+1;
X break;
X case tVOID: printf(" psh void\n"); break;
X case tLST: printf(" pshlist %d\n",*c++); break;
X }
X }
X }
X
/* Loop break/continue point list */
X
static struct looplvl
X {
X struct looplvl *next; /* Next level */
X int cont; /* List of continue destinations */
X int brk; /* List of brk destinations */
X int scopelvl; /* Scoping level */
X } *looplvls=0;
X
void mklooplvl(cont,brk)
X {
X struct looplvl *ll=(struct looplvl *)malloc(sizeof(struct looplvl));
X ll->cont=cont;
X ll->brk=brk;
X ll->next=looplvls;
X ll->scopelvl=scopelvl;
X looplvls=ll;
X }
X
void rmlooplvl(cont,brk)
X {
X struct looplvl *ll=looplvls;
X looplvls=ll->next;
X setlist(ll->cont,cont);
X setlist(ll->brk,brk);
X free(ll);
X }
X
struct looplvl *findlvl(n)
X {
X struct looplvl *ll;
X if(!n) return 0;
X ll=looplvls; while(ll && --n) ll=ll->next;
X return ll;
X }
X
/* Generate an address */
X
static void gena(n)
NODE *n;
X {
X if(n->what==&nVOID) error(n->name,n->line,"incomplete expression");
X else if(n->what==&nPAREN) gena(n->r);
X else if(n->what==&nCOMMA || n->what==&nEXTEND) genn(n->l), gena(n->r);
X else if(n->what==&nNAM)
X {
X psh(tSTR);
X emits(n->s,n->n);
X emit(iLEA);
X }
X else if(n->what==&nDEFUN && !n->l) gen(n);
X else if(n->what==&nCALL)
X {
X int nargs;
X nargs=genl(n->r);
X psh(tLST);
X emit(nargs);
X gena(n->l);
X emit(iCALLA);
X }
X else if(n->what==&nCALL1)
X {
X if(n->r->what!=&nNAM) error(n->r->name,n->r->line,"Invalid member name");
X psh(tSTR);
X emits(n->r->s,n->r->n);
X psh(tLST);
X emit(1);
X gena(n->l);
X emit(iCALLA);
X }
X else gen(n);
X /*error(n->name,n->line,"Invalid LVALUE"); */
X }
X
/* Count no. of comma seperated elements. Use for args and 1st expr of FOR */
X
static int cntlst(n)
NODE *n;
X {
X if(n->what==&nVOID) return 0;
X else if(n->what==&nCOMMA) return cntlst(n->l)+cntlst(n->r);
X else return 1;
X }
X
/* Generate list of comma seperated names (for function args) */
X
static int genlst(argv,initv,n)
char **argv;
int **initv;
NODE *n;
X {
X if(n->what==&nVOID) return 0;
X else if(n->what==&nCOMMA)
X {
X int x=genlst(argv,initv,n->l);
X return x+genlst(argv+x,initv+x,n->r);
X }
X else if(n->what==&nCALL && n->l->what==&nNAM && n->r->what==&nVOID)
X return argv[0]=strdup(n->l->s), initv[0]=0, 1;
X else if(n->what==&nNAM) return argv[0]=strdup(n->s), initv[0]=0, 1;
X else if(n->what==&nSET && n->l->what==&nNAM)
X return argv[0]=strdup(n->l->s), initv[0]=codegen(n->r), 1;
X else return error(n->name,n->line,"incorrect argument list %s",n->what->name), 0;
X }
X
/* Generate and count list (used to generate arg lists) */
X
static int genl(n)
NODE *n;
X {
X int result;
X if(n->what==&nVOID) return 0;
X else if(n->what==&nCOMMA)
X {
X result=genl(n->r);
X return result+genl(n->l);
X }
X else if(n->what==&nSET && n->l->what==&nQUOTE && n->l->r->what==&nNAM)
X {
X gen(n->r);
X psh(tSTR);
X emits(n->l->r->s,n->l->r->n);
X psh(tNARG);
X return 1;
X }
X else
X {
X gen(n);
X return 1;
X }
X }
X
/* Generate and count local command, don't emit initializers */
X
static int genll(n)
NODE *n;
X {
X if(n->what==&nVOID) return 0;
X else if(n->what==&nCOMMA)
X {
X int result=genll(n->r);
X return result+genll(n->l);
X }
X else if(n->what==&nNAM)
X {
X psh(tSTR);
X emits(n->s,n->n);
X return 1;
X }
X else if(n->what==&nSET && n->l->what==&nNAM)
X {
X psh(tSTR);
X emits(n->l->s,n->l->n);
X return 1;
X }
X else error(n->name,n->line,"incorrect local list");
X }
X
/* Generate initializers for local list */
X
static int genla(n)
NODE *n;
X {
X if(n->what==&nVOID) return 0;
X else if(n->what==&nCOMMA)
X {
X int result=genla(n->r);
X return result+genla(n->l);
X }
X else if(n->what==&nNAM) return 1;
X else if(n->what==&nSET && n->l->what==&nNAM)
X {
X genn(n);
X return 1;
X }
X else error(n->name,n->line,"incorrect local list");
X }
X
/* Generate if..elif..elif.. with no return value */
/* Returns list of branch offsets which should be set past final else */
X
genelif(n,v)
NODE *n;
X {
X if(n->what==&nVOID) return 0;
X else if(n->what==&nIF)
X {
X int els=genbra(n->l,1);
X int rtval;
X emit(iBEG);
X if(v) gen(n->r); else genn(n->r);
X emit(iEND);
X emit(iBRA);
X emit(0);
X rtval=code-1-begcode;
X setlist(els,code-begcode);
X return rtval;
X }
X else if(n->what==&nCOMMA && n->r->what==&nELSE && n->r->r->what==&nIF)
X {
X int z=genelif(n->l,v);
X if(!z) error(n->r->name,n->r->line,"else without if");
X else addlist(z,genelif(n->r->r,v));
X return z;
X }
X if(v) gen(n); else genn(n);
X return 0;
X }
X
/* Generate a value */
X
static void gen(n)
NODE *n;
X {
X if(n->what==&nEXTEND)
X genn(n->l), gen(n->r);
X else if(n->what==&nPAREN) gen(n->r);
X else if(n->what==&nLIST)
X {
X int amnt=genl(n->r);
X psh(tLST);
X emit(amnt);
X }
X else if(n->what==&nNUM)
X {
X psh(tNUM);
X emit(n->n);
X }
X else if(n->what==&nSTR)
X {
X psh(tSTR);
X emits(n->s,n->n);
X }
X else if(n->what==&nNAM)
X {
X psh(tSTR);
X emits(n->s,n->n);
X emit(iGET);
X }
X else if(n->what==&nSET)
X {
X int sv;
X gen(n->r); sv=itmdepth;
X itmdepth=0; gena(n->l); pop();
X emit(iSET); itmdepth=sv;
X }
X else if(n->what==&nPOST)
X {
X int sv;
X gen(n->l); sv=itmdepth;
X itmdepth=0; gen(n->r);
X gena(n->l); pop();
X emit(iSET);
X emit(iPOP);
X itmdepth=sv;
X }
X else if(n->what==&nDEFUN && !n->l)
X {
X NODE *args=n->r->l;
X int *cod=codegen(n->r->r);
X OBJ *o;
X int argc=cntlst(args);
X char **argv=(char **)malloc(argc*sizeof(char *));
X int **initv=(int **)malloc(argc*sizeof(int *));
X genlst(argv,initv,args);
X o=mkobj(tFUNC,(void *)0,0,cod,argc,argv,initv);
X psh(tFUNC);
X emit((int)o);
X }
X else if(n->what==&nCOMMA)
X if(n->r->what==&nELSE)
X {
X int done=genelif(n->l,1);
X if(!done) error(n->r->name,n->r->line,"else w/o if error");
X if(n->r->r->what==&nIF)
X {
X addlist(done,genbra(n->r->r->l,1));
X n=n->r;
X }
X emit(iBEG);
X gen(n->r->r);
X emit(iEND);
X setlist(done,code-begcode);
X }
X else
X {
X genn(n->l);
X gen(n->r);
X }
X else if(n->what==&nEQ || n->what==&nNE ||
X n->what==&nGT || n->what==&nLT ||
X n->what==&nGE || n->what==&nLE ||
X n->what==&nLAND || n->what==&nLOR || n->what==&nNOT)
X {
X int b=genbra(n,1);
X psh(tNUM);
X emit(1);
X emit(iBRA);
X emit(4);
X setlist(b,code-begcode);
X psh(tNUM);
X emit(0);
X }
X else if(n->what==&nCALL)
X {
X int nargs=genl(n->r);
X psh(tLST);
X emit(nargs);
X gena(n->l);
X emit(iCALL);
X }
X else if(n->what==&nCALL1)
X {
X if(n->r->what!=&nNAM) error(n->r->name,n->r->line,"Invalid member name");
X psh(tSTR);
X emits(n->r->s,n->r->n);
X psh(tLST);
X emit(1);
X gena(n->l);
X emit(iCALL);
X }
X else if(n->what==&nCOM || n->what==&nNEG || n->what==&nSHL ||
X n->what==&nSHR || n->what==&nMUL || n->what==&nDIV ||
X n->what==&nMOD || n->what==&nAND || n->what==&nADD ||
X n->what==&nSUB || n->what==&nOR || n->what==&nXOR)
X {
X if(n->l) gen(n->l);
X if(n->r) gen(n->r);
X emit(n->what->i);
X if(n->r && n->l) pop();
X }
X else
X if(!genn(n)) psh(tVOID);
X }
X
/* Generate nothing (returns true if guarenteed to branch) */
X
static int genn(n)
NODE *n;
X {
X if(n->what==&nPAREN) genn(n->r);
X else if(n->what==&nWITH)
X if(n->r->r)
X {
X int amnt;
X emit(iBEG); ++scopelvl;
X amnt=genl(n->l);
X psh(tLST);
X emit(amnt);
X emit(iWTH);
X genn(n->r);
X emit(iEND); --scopelvl;
X }
X else
X {
X int amnt=genl(n->l);
X psh(tLST);
X emit(amnt);
X emit(iWTH);
X }
X else if(n->what==&nLOCAL)
X if(n->r->r)
X {
X int amnt;
X emit(iBEG); ++scopelvl;
X amnt=genll(n->l);
X psh(tLST);
X emit(amnt);
X emit(iLOC);
X genla(n->l);
X genn(n->r);
X emit(iEND); --scopelvl;
X }
X else
X {
X int amnt=genll(n->l);
X psh(tLST);
X emit(amnt);
X emit(iLOC);
X genla(n->l);
X }
X else if(n->what==&nFOR)
X {
X int top, cont;
/* if(cntlst(n->l)!=3)
X error(n->l->name,n->l->line,"Incorrect no. args to FOR"); */
X genn(n->l->l->l);
X emit(iBEG); ++scopelvl;
X emit(iBRA);
X mklooplvl(code-begcode,0);
X emit(0);
X top=code-begcode;
X genn(n->r);
X genn(n->l->r);
X cont=code-begcode;
X setlist(genbra(n->l->l->r,0),top);
X rmlooplvl(cont,code-begcode);
X emit(iEND); --scopelvl;
X }
X else if(n->what==&nWHILE)
X {
X int top, cont;
X dowhile:
X emit(iBEG); ++scopelvl;
X emit(iBRA);
X mklooplvl(code-begcode,0);
X emit(0);
X top=code-begcode;
X genn(n->r);
X cont=code-begcode;
X setlist(genbra(n->l,0),top);
X rmlooplvl(cont,code-begcode);
X emit(iEND); --scopelvl;
X }
X else if(n->what==&nRETURN)
X {
X int z;
X if(n->r) gen(n->r);
X else psh(tVOID);
X for(z=0;z!=scopelvl;++z) emit(iEND);
X emit(iBRA);
X emit(0);
X if(rtn) addlist(rtn,code-1-begcode);
X else rtn=code-1-begcode;
X return 1;
X }
X else if(n->what==&nLOOP)
X {
X int cont;
X emit(iBEG); ++scopelvl;
X cont=code-begcode;
X mklooplvl((void *)0,(void *)0);
X genn(n->r);
X emit(iBRA); emit(cont-(code-begcode));
X rmlooplvl(cont,code-begcode);
X emit(iEND); --scopelvl;
X }
X else if(n->what==&nBREAK)
X {
X int nlvls=1;
X struct looplvl *ll;
X if(n->r->r)
X if(n->r->r->what==&nNUM) nlvls=n->r->r->n;
X else error(n->r->r->name,n->r->line,"Invalid argument to break");
X ll=findlvl(nlvls);
X if(ll)
X {
X int z;
X for(z=ll->scopelvl;z!=scopelvl;++z) emit(iEND);
X emit(iBRA);
X emit(0);
X if(ll->brk) addlist(ll->brk,code-begcode-1);
X else ll->brk=code-begcode-1;
X }
X else error(n->name,n->line,"break with no loop");
X return 1;
X }
X else if(n->what==&nCONT)
X {
X int nlvls=1;
X struct looplvl *ll;
X if(n->r->r)
X if(n->r->r->what==&nNUM) nlvls=n->r->r->n;
X else error(n->r->r->name,n->r->line,"Invalid argument to continue");
X ll=findlvl(nlvls);
X if(ll)
X {
X int z;
X for(z=ll->scopelvl;z!=scopelvl;++z) emit(iEND);
X emit(iBRA);
X emit(0);
X if(ll->cont) addlist(ll->cont,code-begcode-1);
X else ll->cont=code-begcode-1;
X }
X else error(n->name,n->line,"continue with no loop");
X return 1;
X }
X else if(n->what==&nUNTIL)
X {
X if(!looplvls) error(n->name,n->line,"until with no loop");
X if(looplvls->brk) addlist(looplvls->brk,genbra(n->r,0));
X else looplvls->brk=genbra(n->r,0);
X }
X else if(n->what==&nIF)
X {
X int no=genbra(n->l,1);
X emit(iBEG);
X genn(n->r);
X emit(iEND);
X setlist(no,code-begcode);
X }
X else if(n->what==&nELSE)
X {
X error(n->name,n->line,"else with no if");
X }
X else if(n->what==&nCOMMA)
X if(n->r->what==&nELSE)
X {
X int done=genelif(n->l,0);
X if(!done) error(n->r->name,n->r->line,"Else w/o if error");
X if(n->r->r->what==&nIF)
X {
X addlist(done,genbra(n->r->r->l,1));
X n=n->r;
X }
X emit(iBEG);
X genn(n->r->r);
X emit(iEND);
X setlist(done,code-begcode);
X }
X else
X {
X genn(n->l);
X genn(n->r);
X }
X else if(n->what==&nDEFUN)
X {
X char *name=n->l->s;
X NODE *args=n->r->l;
X int *cod=codegen(n->r->r);
X OBJ *o, *p;
X int argc=cntlst(args);
X char **argv=(char **)malloc(argc*sizeof(char *));
X int **initv=(int **)malloc(argc*sizeof(int *));
X genlst(argv,initv,args);
X o=mkobj(tFUNC,(void *)0,0,cod,argc,argv,initv);
X if(!sp) izrun();
X p=set(&vars->obj.v,name);
X rmval(&p->obj.v);
X p->obj.v.type=tFUNC;
X p->obj.v.v.obj=o;
X }
X else if(n->what==&nVOID) return 0;
X else
X {
X gen(n);
X emit(iPOP); pop();
X }
X return 0;
X }
X
/* Generate a branch. If 't' is set, then the block falls through if the result
X * is true and takes the branch if the result is false.
X *
X * If 't' is clear, then the block falls through if the result is false and
X * takes the branch if the reuslt is true.
X *
X * Return the address of the value which should be set to the branch offset
X */
X
/* Add branch list 'b' to end of branch list 'a' */
X
static void addlist(a,b)
X {
X while(begcode[a]) a= begcode[a];
X begcode[a]=b;
X }
X
/* Set each value in branch list 'a' to destination 'b' */
X
static void setlist(a,b)
X {
X int c;
X while(a) c= begcode[a], begcode[a]=b-a, a=c;
X }
X
static int genbra(n,t)
NODE *n;
X {
X if(n->what==&nEQ)
X {
X gen(n->l); gen(n->r);
X emit(iCMP);
X if(t) emit(iBNE); else emit(iBEQ);
X emit(0);
X pop();
X return code-begcode-1;
X }
X else if(n->what==&nNE)
X {
X gen(n->l); gen(n->r);
X emit(iCMP);
X if(t) emit(iBEQ); else emit(iBNE);
X emit(0);
X pop();
X return code-begcode-1;
X }
X else if(n->what==&nGT)
X {
X gen(n->l); gen(n->r);
X emit(iCMP);
X if(t) emit(iBLE); else emit(iBGT);
X emit(0);
X pop();
X return code-begcode-1;
X }
X else if(n->what==&nGE)
X {
X gen(n->l); gen(n->r);
X emit(iCMP);
X if(t) emit(iBLT); else emit(iBGE);
X emit(0);
X pop();
X return code-begcode-1;
X }
X else if(n->what==&nLT)
X {
X gen(n->l); gen(n->r);
X emit(iCMP);
X if(t) emit(iBGE); else emit(iBLT);
X emit(0);
X pop();
X return code-begcode-1;
X }
X else if(n->what==&nLE)
X {
X gen(n->l); gen(n->r);
X emit(iCMP);
X if(t) emit(iBGT); else emit(iBLE);
X emit(0);
X pop();
X return code-begcode-1;
X }
X else if(n->what==&nNOT)
X return genbra(n->r,!t);
X else if(n->what==&nLAND)
X {
X int b1=genbra(n->l,1);
X int b2;
X if(t) b2=genbra(n->r,1), addlist(b2,b1);
X else b2=genbra(n->r,0), addlist(b1,code-begcode);
X return b2;
X }
X else if(n->what==&nLOR)
X {
X int b1=genbra(n->l,0);
X int b2;
X if(t) b2=genbra(n->r,1), setlist(b1,code-begcode);
X else b2=genbra(n->r,0), addlist(b2,b1);
X return b2;
X }
X else
X {
X gen(n);
X if(t) emit(iBEQ); else emit(iBNE);
X emit(0);
X pop();
X return code-begcode-1;
X }
X }
X
/* Code generator: convert a parse-tree into pseudo-machine code */
X
int ptree=0;
int unasm=0;
X
int *codegen(n)
NODE *n;
X {
X int *ocode=code, *obegcode=begcode, ortn=rtn;
X int ocodesize=codesize, oscopelvl=scopelvl;
X int omax=maxdepth, ocur=curdepth, oitm=itmdepth;
X int *rtval;
X if(ptree) prtree(n,0), printf("\n");
X newcode();
X emit(0);
X rtn=0;
X maxdepth=0;
X curdepth=0;
X itmdepth=0;
X scopelvl=0;
X gen(n);
X if(rtn) setlist(rtn,code-begcode);
X emit(iRTS);
X rtval=begcode;
X *begcode=maxdepth;
X if(unasm) disasm(begcode);
X code=ocode; begcode=obegcode; codesize=ocodesize; rtn=ortn;
X scopelvl=oscopelvl;
X maxdepth=omax; curdepth=ocur; itmdepth=oitm;
X return rtval;
X }
X
/* Add a C function to the table */
X
void addfunc(name,argstr,cfunc)
char *name, *argstr;
void (*cfunc)();
X {
X char bf[1024];
X NODE *args;
X OBJ *o, *p;
X int argc;
X char **argv;
X int **initv;
X strcpy(bf,argstr);
X args=compargs(bf);
X argc=cntlst(args);
X argv=(char **)malloc(argc*sizeof(char *));
X initv=(int **)malloc(argc*sizeof(int *));
X genlst(argv,initv,args);
X o=mkobj(tFUNC,(void *)0,0,(void *)0,argc,argv,initv);
X o->obj.func.cfunc=cfunc;
X /* Put new function in table */
X p=set(&vars->obj.v,name);
X rmval(&p->obj.v);
X p->obj.v.type=tFUNC;
X p->obj.v.v.obj=o;
X }
SHAR_EOF
chmod 0600 codegen.c ||
echo 'restore of codegen.c failed'
Wc_c="`wc -c < 'codegen.c'`"
test 18616 -eq "$Wc_c" ||
echo 'codegen.c: original size 18616, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= codegen.h ==============
if test -f 'codegen.h' -a X"$1" != X"-c"; then
echo 'x - skipping codegen.h (File already exists)'
rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting codegen.h (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'codegen.h' &&
/* Code generator
X Copyright (C) 1993 Joseph H. Allen
X
This file is part of IVY
X
IVY is free software; you can redistribute it and/or modify it under the
terms of the GNU General Public License as published by the Free Software
Foundation; either version 1, or (at your option) any later version.
X
IVY is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
details.
X
You should have received a copy of the GNU General Public License along with
IVY; see the file COPYING. If not, write to the Free Software Foundation,
675 Mass Ave, Cambridge, MA 02139, USA. */
X
#ifndef _Icodegen
#define _Icodegen 1
X
/* Convert a parse-tree into pseudo-machine code */
int *codegen();
X
/* A a C-function to the global table */
void addfunc();
X
extern int unasm;
extern int ptree;
X
#endif
SHAR_EOF
chmod 0600 codegen.h ||
echo 'restore of codegen.h failed'
Wc_c="`wc -c < 'codegen.h'`"
test 945 -eq "$Wc_c" ||
echo 'codegen.h: original size 945, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= compile.c ==============
if test -f 'compile.c' -a X"$1" != X"-c"; then
echo 'x - skipping compile.c (File already exists)'
rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting compile.c (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'compile.c' &&
/* Compiler
X Copyright (C) 1993 Joseph H. Allen
X
This file is part of IVY
X
IVY is free software; you can redistribute it and/or modify it under the
terms of the GNU General Public License as published by the Free Software
Foundation; either version 1, or (at your option) any later version.
X
IVY is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
details.
X
You should have received a copy of the GNU General Public License along with
IVY; see the file COPYING. If not, write to the Free Software Foundation,
675 Mass Ave, Cambridge, MA 02139, USA. */
X
#include <stdio.h>
#include <ctype.h>
#include <string.h>
#include "run.h"
#include "codegen.h"
#include "compile.h"
X
char *(*getmore)()=0; /* Function to get another line of input */
X
static char *ptr=""; /* Input pointer */
static int col=0; /* Column no. 'ptr' is at. 0 is first */
static int lvl= -1; /* Indentation level of current line */
static int line=0; /* Line number 'ptr' is on. 0 is first */
static char *name="stdin"; /* File name of current input file */
static int eof=0; /* Set when EOF encountered */
X
FILE *infile; /* Input file/buffer for 'include' command */
char inbuf[1024];
X
/* Print an error message */
X
void error(name,line,str,a,b,c,d)
char *name, *str;
X {
X fprintf(stderr,"\"%s\" %d: error: ",name,line);
X fprintf(stderr,str,a,b,c,d);
X fprintf(stderr,"\n");
X }
X
/* Skip over whitespace. Don't attempt to get more input */
X
void skipws()
X {
X while(1) switch(*ptr)
X {
X case ' ': ++ptr; ++col;
X break;
X
X case '\t': ++ptr; col+=8-col%8;
X break;
X
X case '#':
X case '\n': *ptr=0;
X case 0: return;
X
X default: if(lvl== -1) lvl=col;
X return;
X }
X }
X
/* Skip whitespace including ; */
X
void skipwss()
X {
X loop:
X skipws();
X if(*ptr==';')
X {
X ++ptr;
X goto loop;
X }
X }
X
/* Skip whitespace; get new lines if needed */
X
void skipwsm()
X {
X loop:
X skipws();
X if(!*ptr && getmore && !eof)
X if(ptr=getmore())
X {
X col=0;
X lvl= -1;
X ++line;
X goto loop;
X }
X else eof=1, ptr="";
X }
X
/* Skip whitespace; including ; */
X
void skipwssm()
X {
X loop:
X skipwsm();
X if(*ptr==';')
X {
X ++ptr, ++col;
X goto loop;
X }
X }
X
/* Table of operators and parse-tree node types */
X
/* NAME PREFIX INFIX POSTFIX PREC ASS METH INST ATOM */
/* Constants */
ATOM nNAM ={"nam" ,0 ,0 ,0 ,120 ,0 ,0 ,0 ,0};
ATOM nNUM ={"num" ,0 ,0 ,0 ,120 ,0 ,0 ,0 ,0};
ATOM nSTR ={"str" ,0 ,0 ,0 ,120 ,0 ,0 ,0 ,0};
X
ATOM nQUOTE ={"`" ,&nQUOTE,0 ,0 ,120 ,0 ,1 ,0 ,&nQUOTE};
X
ATOM nCALL1 ={"." ,0 ,&nCALL1,0 ,110 ,0 ,2 ,0 ,0};
X
ATOM nCALL ={"[" ,0 ,&nCALL ,0 ,100 ,0 ,66 ,0 ,0};
X
extern ATOM nPOINC, nPODEC;
ATOM nPRINC ={"++" ,&nPRINC,0 ,&nPOINC,90 ,0 ,5 ,0 ,&nADD};
ATOM nPRDEC ={"--" ,&nPRDEC,0 ,&nPODEC,90 ,0 ,5 ,0 ,&nSUB};
ATOM nPOINC ={"++" ,&nPRINC,0 ,&nPOINC,90 ,0 ,13 ,0 ,&nADD};
ATOM nPODEC ={"--" ,&nPRDEC,0 ,&nPODEC,90 ,0 ,13 ,0 ,&nSUB};
ATOM nCOM ={"~" ,&nCOM ,0 ,0 ,90 ,0 ,1 ,iCOM ,0};
ATOM nNEG ={"neg" ,&nNEG ,&nSUB ,0 ,90 ,0 ,1 ,iNEG ,0};
ATOM nNOT ={"!" ,&nNOT ,0 ,0 ,90 ,0 ,1 ,0 ,0};
X
ATOM nSHR ={">>" ,0 ,&nSHR ,0 ,80 ,0 ,2 ,iSHR ,0};
ATOM nSHL ={"<<" ,0 ,&nSHL ,0 ,80 ,0 ,2 ,iSHL ,0};
X
ATOM nMUL ={"*" ,0 ,&nMUL ,0 ,70 ,0 ,2 ,iMUL ,0};
ATOM nDIV ={"/" ,0 ,&nDIV ,0 ,70 ,0 ,2 ,iDIV ,0};
ATOM nMOD ={"%" ,&nMOD ,&nMOD ,0 ,70 ,0 ,2 ,iMOD ,0};
ATOM nAND ={"&" ,0 ,&nAND ,0 ,70 ,0 ,2 ,iAND ,0};
X
ATOM nADD ={"+" ,0 ,&nADD ,0 ,60 ,0 ,2 ,iADD ,0};
ATOM nSUB ={"-" ,&nNEG ,&nSUB ,0 ,60 ,0 ,2 ,iSUB ,0};
ATOM nOR ={"|" ,0 ,&nOR ,0 ,60 ,0 ,2 ,iOR ,0};
ATOM nXOR ={"^" ,0 ,&nXOR ,0 ,60 ,0 ,2 ,iXOR ,0};
X
ATOM nEQ ={"==" ,0 ,&nEQ ,0 ,50 ,0 ,2 ,iBEQ ,0};
ATOM nNE ={"!=" ,0 ,&nNE ,0 ,50 ,0 ,2 ,iBNE ,0};
ATOM nLT ={"<" ,0 ,&nLT ,0 ,50 ,0 ,2 ,iBLT ,0};
ATOM nGT ={">" ,0 ,&nGT ,0 ,50 ,0 ,2 ,iBGT ,0};
ATOM nLE ={"<=" ,0 ,&nLE ,0 ,50 ,0 ,2 ,iBLE ,0};
ATOM nGE ={">=" ,0 ,&nGE ,0 ,50 ,0 ,2 ,iBGE ,0};
X
ATOM nLAND ={"&&" ,0 ,&nLAND ,0 ,40 ,0 ,2 ,0 ,0};
X
ATOM nLOR ={"||" ,0 ,&nLOR ,0 ,30 ,0 ,2 ,0 ,0};
X
ATOM nSET ={"=" ,0 ,&nSET ,0 ,20 ,1 ,2 ,iSET ,0};
ATOM nDOTTO ={".=" ,0 ,&nDOTTO,0 ,20 ,1 ,6 ,0 ,&nCALL1};
ATOM nSHLTO ={"<<=" ,0 ,&nSHLTO,0 ,20 ,1 ,6 ,0 ,&nSHL};
ATOM nSHRTO ={">>=" ,0 ,&nSHRTO,0 ,20 ,1 ,6 ,0 ,&nSHR};
ATOM nMULTO ={"*=" ,0 ,&nMULTO,0 ,20 ,1 ,6 ,0 ,&nMUL};
ATOM nDIVTO ={"/=" ,0 ,&nDIVTO,0 ,20 ,1 ,6 ,0 ,&nDIV};
ATOM nMODTO ={"%=" ,0 ,&nMODTO,0 ,20 ,1 ,6 ,0 ,&nMOD};
ATOM nANDTO ={"&=" ,0 ,&nANDTO,0 ,20 ,1 ,6 ,0 ,&nAND};
ATOM nADDTO ={"+=" ,0 ,&nADDTO,0 ,20 ,1 ,6 ,0 ,&nADD};
ATOM nSUBTO ={"-=" ,0 ,&nSUBTO,0 ,20 ,1 ,6 ,0 ,&nSUB};
ATOM nXORTO ={"^=" ,0 ,&nXORTO,0 ,20 ,1 ,6 ,0 ,&nXOR};
ATOM nORTO ={"|=" ,0 ,&nORTO ,0 ,20 ,1 ,6 ,0 ,&nOR};
ATOM nPOST ={":" ,0 ,&nPOST ,0 ,20 ,1 ,10 ,0 ,0};
ATOM nDOTPO ={".:" ,0 ,&nDOTPO,0 ,20 ,1 ,14 ,0 ,&nCALL1};
ATOM nSHLPO ={"<<:" ,0 ,&nSHLPO,0 ,20 ,1 ,14 ,0 ,&nSHL};
ATOM nSHRPO ={">>:" ,0 ,&nSHRPO,0 ,20 ,1 ,14 ,0 ,&nSHR};
ATOM nMULPO ={"*:" ,0 ,&nMULPO,0 ,20 ,1 ,14 ,0 ,&nMUL};
ATOM nDIVPO ={"/:" ,0 ,&nDIVPO,0 ,20 ,1 ,14 ,0 ,&nDIV};
ATOM nMODPO ={"%:" ,0 ,&nMODPO,0 ,20 ,1 ,14 ,0 ,&nMOD};
ATOM nANDPO ={"&:" ,0 ,&nANDPO,0 ,20 ,1 ,14 ,0 ,&nAND};
ATOM nADDPO ={"+:" ,0 ,&nADDPO,0 ,20 ,1 ,14 ,0 ,&nADD};
ATOM nSUBPO ={"-:" ,0 ,&nSUBPO,0 ,20 ,1 ,14 ,0 ,&nSUB};
ATOM nXORPO ={"^:" ,0 ,&nXORPO,0 ,20 ,1 ,14 ,0 ,&nXOR};
ATOM nORPO ={"|:" ,0 ,&nORPO ,0 ,20 ,1 ,14 ,0 ,&nOR};
X
ATOM nEXTEND ={"\\" ,0 ,&nEXTEND,0 ,15 ,0 ,2 ,0 ,0};
X
ATOM nCOMMA ={"," ,0 ,&nCOMMA,0 ,10 ,0 ,2 ,0 ,0};
X
/* Special parse tree nodes */
/* A function definition */
ATOM nDEFUN ={"FUN" ,0 ,&nDEFUN,0 ,5 ,0 ,2 ,0 ,&nDEFUN};
X
/* A list [...] */
ATOM nLIST ={"LST" ,0 ,0 ,0 ,0 ,0 ,1 ,0 ,0};
X
/* Parenthasis */
ATOM nPAREN ={"(" ,0 ,0 ,0 ,0 ,0 ,1 ,0 ,0};
X
/* Nothing */
ATOM nVOID ={"VOID",0 ,0 ,0 ,0 ,0 ,1 ,0 ,0};
X
/* Statements */
ATOM nIF ={"if" ,0 ,0 ,0 ,0 ,0 ,1 ,0 ,0};
ATOM nFOR ={"for" ,0 ,0 ,0 ,0 ,0 ,1 ,0 ,0};
ATOM nWHILE ={"while",0 ,0 ,0 ,0 ,0 ,1 ,0 ,0};
ATOM nWITH ={"with",0 ,0 ,0 ,0 ,0 ,1 ,0 ,0};
ATOM nLOCAL ={"local",0 ,0 ,0 ,0 ,0 ,1 ,0 ,0};
ATOM nELSE ={"else",0 ,0 ,0 ,0 ,0 ,2 ,0 ,0};
ATOM nLOOP ={"loop",0 ,0 ,0 ,0 ,0 ,2 ,0 ,0};
ATOM nUNTIL ={"until",0 ,0 ,0 ,0 ,0 ,3 ,0 ,0};
ATOM nBREAK ={"break",0 ,0 ,0 ,0 ,0 ,4 ,0 ,0};
ATOM nCONT ={"continue",0 ,0 ,0 ,0 ,0 ,4 ,0 ,0};
ATOM nRETURN ={"return",0 ,0 ,0 ,0 ,0 ,4 ,0 ,0};
ATOM nFOREACH ={"foreach",0 ,0 ,0 ,0 ,0 ,5 ,0 ,0};
ATOM nINCLUDE ={"include",0 ,0 ,0 ,0 ,0 ,6 ,0 ,0};
X
/* Construct a two operand node */
X
NODE *cons2(what,left,right)
ATOM *what;
NODE *left, *right;
X {
X if(!left || !right) { rm(right); rm(left); return 0; }
X else
X {
X NODE *n=(NODE *)malloc(sizeof(NODE));
X n->what=what;
X n->l=left;
X n->r=right;
X n->s=0;
X n->line=line;
X n->name=name;
X return n;
X }
X }
X
/* Construct a single operand node */
X
NODE *cons1(what,right)
ATOM *what;
NODE *right;
X {
X if(!right) return 0;
X else
X {
X NODE *n=(NODE *)malloc(sizeof(NODE));
X n->what=what;
X n->l=0;
X n->r=right;
X n->s=0;
X n->name=name;
X n->line=line;
X return n;
X }
X }
X
/* Construct an integer constant */
X
NODE *consnum(v)
X {
X NODE *n=(NODE *)malloc(sizeof(NODE));
X n->what=&nNUM;
X n->l=0;
X n->r=0;
X n->n=v;
X n->s=0;
X n->line=line;
X n->name=name;
X return n;
X }
X
/* Construct a string constant */
X
NODE *consstr(v,len)
char *v;
X {
X NODE *n=(NODE *)malloc(sizeof(NODE));
X n->what=&nSTR;
X n->l=0;
X n->r=0;
X n->s=v;
X n->n=len;
X n->line=line;
X n->name=name;
X return n;
X }
X
/* Construct an identifier */
X
NODE *consnam(v)
char *v;
X {
X NODE *n=(NODE *)malloc(sizeof(NODE));
X n->what=&nNAM;
X n->l=0;
X n->r=0;
X n->s=v;
X n->n=strlen(v);
X n->line=line;
X n->name=name;
X return n;
X }
X
/* Construct a void */
X
NODE *consvoid()
X {
X NODE *n=(NODE *)malloc(sizeof(NODE));
X n->what=&nVOID;
X n->l=0;
X n->r=0;
X n->s=0;
X n->n=0;
X n->line=line;
X n->name=name;
X return n;
X }
X
/* Construct an optional node */
X
NODE *opt(n)
NODE *n;
X {
X if(n) return n;
X else return consvoid();
X }
X
/* Duplicate a tree */
X
NODE *dup(o)
NODE *o;
X {
X NODE *n;
X if(!o) return 0;
X n=(NODE *)malloc(sizeof(NODE));
X n->what=o->what;
X if(o->s)
X {
X int x;
X n->s=(char *)malloc(o->n+1);
X for(x=0;x!=o->n;++x) n->s[x]=o->s[x];
X n->s[x]=0;
X }
X else n->s=0;
X n->n=o->n;
X n->r=dup(o->r);
X n->l=dup(o->l);
X n->name=o->name;
X n->line=o->line;
X return n;
X }
X
/* Eliminate a tree */
X
void rm(n)
NODE *n;
X {
X if(n)
X {
X rm(n->l);
X rm(n->r);
X if(n->s) free(n->s);
X free(n);
X }
X }
X
/* Operator scanner */
X
#define OPRTLEN 64
#define OPRLTLEN 128
char oprltab[OPRLTLEN]; /* Hash table of operator left-substrings */
ATOM *oprtab[OPRTLEN]; /* Hash table of operators */
unsigned long accu; /* Hash value accumulator */
char *start; /* Pointer to operator in input string */
X
ATOM *ioprtab[]=
X { &nCALL1, &nCALL, &nPRINC, &nPRDEC, &nCOM, &nSUB, &nNOT, &nSHR, &nSHL,
X &nMUL, &nDIV, &nMOD, &nAND, &nADD, &nOR, &nXOR, &nEQ, &nNE, &nGE, &nLE,
X &nGT, &nLT, &nLAND, &nLOR, &nSET, &nDOTTO, &nSHLTO, &nSHRTO, &nMULTO,
X &nDIVTO, &nMODTO, &nANDTO, &nADDTO, &nSUBTO, &nXORTO, &nORTO, &nPOST,
X &nDOTPO, &nSHLPO, &nSHRPO, &nMULPO, &nDIVPO, &nMODPO, &nANDPO, &nADDPO,
X &nSUBPO, &nXORPO, &nORPO, &nQUOTE, &nEXTEND, 0 };
X
void izoprtab()
X {
X int x;
X ATOM *t;
X for(x=0;t=ioprtab[x];++x)
X {
X char *s=t->name;
X accu=0; while(*s)
X {
X accu=hnext(accu,*s++);
X if(*s) ++oprltab[accu%OPRLTLEN];
X }
X t->next=oprtab[accu%OPRTLEN];
X oprtab[accu%OPRTLEN]=t;
X }
X }
X
ATOM *doopr()
X {
X unsigned long oaccu=accu; char *oops=ptr; int oopscol=col;
X char c;
X ATOM *t;
X do
X {
X if(!*ptr) break;
X accu=hnext(accu,*ptr++);
X c= *ptr; *ptr=0;
X for(t=oprtab[accu%OPRTLEN];t;t=t->next)
X if(!strcmp(start,t->name))
X {
X ATOM *u;
X *ptr=c;
X if(u=doopr()) return u;
X else return t;
X }
X *ptr=c;
X } while(oprltab[accu%OPRLTLEN]);
X accu=oaccu; ptr=oops; col=oopscol;
X return 0;
X }
X
/* Look up an operator */
X
ATOM *opr()
X {
X if(!start) izoprtab();
X accu=0;
X start=ptr;
X return doopr();
X }
X
/* Get a character which might be an escape sequence */
X
int escape()
X {
X if(*ptr=='\\')
X {
X ++ptr; ++col;
X switch(*ptr)
X {
X case '^':
X ++ptr; ++col;
X if(*ptr>='@' && *ptr<='_') return ++col, *ptr++-'@';
X else if(*ptr=='?') return ++col, ++ptr, 127;
X else return escape();
X
X case '8': case '9':
X return ++col, *ptr++-'0';
X
X case 'x': case 'X':
X {
X int num=0;
X ++col; ++ptr;
X if(*ptr>='0' && *ptr<='9') num=(++col, *ptr++-'0');
X else if(*ptr>='a' && *ptr<='f') num=(++col, *ptr++-'a'+10);
X else if(*ptr>='A' && *ptr<='F') num=(++col, *ptr++-'A'+10);
X if(*ptr>='0' && *ptr<='9') num=num*16+(++col, *ptr++-'0');
X else if(*ptr>='a' && *ptr<='f') num=num*16+(++col, *ptr++-'a'+10);
X else if(*ptr>='A' && *ptr<='F') num=num*16+(++col, *ptr++-'A'+10);
X return num;
X }
X
X case '0': case '1': case '2': case '3':
X case '4': case '5': case '6': case '7':
X {
X int num= *ptr++-'0'; ++col;
X if(*ptr>='0' && *ptr<='7')
X num=num*8+*ptr++-'0', ++col;
X if(*ptr>='0' && *ptr<='7')
X num=num*8+*ptr++-'0', ++col;
X return num;
X }
X
X case 'a': return ++ptr, ++col, 7;
X case 'b': return ++ptr, ++col, 8;
X case 'e': return ++ptr, ++col, 27;
X case 'f': return ++ptr, ++col, 12;
X case 'n': return ++ptr, ++col, 10;
X case 'r': return ++ptr, ++col, 13;
X case 't': return ++ptr, ++col, 9;
X
X case '\\': return ++col, *ptr++;
X
X default: return escape();
X }
X }
X else if(*ptr!='\t') return ++col, *ptr++;
X else return col+=8-col%8, *ptr++;
X }
X
/* Parse an expression. Returns parse-tree or NULL if there was an error.
X */
X
NODE *expr(prec)
X {
X NODE *n, *t;
X char *oops;
X int oopscol;
X int left, right;
X ATOM *op;
X
X /* Skip whitespace. Get more input if necessary */
X skipwsm();
X
X /* Constants/variables/parenthasis/prefix operators */
X switch(*ptr)
X {
X case '%': /* Binary */
X {
X int num=0;
X ++ptr, ++col;
X while(*ptr=='0' || *ptr=='1') num=num*2+*ptr++-'0', ++col;
X n=consnum(num);
X }
X break;
X
X case '@': /* Octal */
X {
X int num=0;
X ++ptr, ++col;
X while(*ptr>='0' && *ptr<='7') num=num*8+*ptr++-'0', ++col;
X n=consnum(num);
X }
X break;
X
X case '$': /* Hex */
X {
X int num=0;
X ++ptr, ++col;
X while(*ptr>='0' && *ptr<='9' ||
X *ptr>='a' && *ptr<='f' ||
X *ptr>='A' && *ptr<='F')
X if(*ptr>='0' && *ptr<='9') num=num*16+*ptr++-'0', ++col;
X else if(*ptr>='a' && *ptr<='f') num=num*16+*ptr++-'a'+10, ++col;
X else if(*ptr>='A' && *ptr<='F') num=num*16+*ptr++-'A'+10, ++col;
X n=consnum(num);
X }
X break;
X
X case '0': case '1': case '2': case '3': case '4': /* Decimal */
X case '5': case '6': case '7': case '8': case '9':
X {
X int num=0;
X do num=num*10+*ptr++-'0', ++col; while(isdigit(*ptr));
X n=consnum(num);
X }
X break;
X
X case '\'': /* Character */
X {
X int num=0;
X ++ptr, ++col;
X num=escape();
X if(*ptr=='\'') ++ptr, ++col;
X n=consnum(num);
X }
X break;
X
X case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': /* Name */
X case 'g': case 'h': case 'i': case 'j': case 'k': case 'l':
X case 'm': case 'n': case 'o': case 'p': case 'q': case 'r':
X case 's': case 't': case 'u': case 'v': case 'w': case 'x':
X case 'y': case 'z':
X case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
X case 'G': case 'H': case 'I': case 'J': case 'K': case 'L':
X case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R':
X case 'S': case 'T': case 'U': case 'V': case 'W': case 'X':
X case 'Y': case 'Z':
X case '_':
X {
X int d; char *str=ptr;
X do ++ptr, ++col; while(isalnum(*ptr) || *ptr=='_');
X d= *ptr; *ptr=0;
X n=consnam(strdup(str));
X *ptr=d;
X }
X break;
X
X case '"': /* String */
X {
X char buf[1024];
X int x;
X ++ptr; ++col;
X for(x=0;*ptr && *ptr!='"';buf[x++]=escape());
X if(*ptr!='"')
X {
X printf("Error: Missing \"\n");
X return 0;
X }
X else ++ptr, ++col;
X buf[x]=0;
X n=consstr(memcpy((char *)malloc(x+1),buf,x+1),x);
X }
X break;
X
X case '(': /* Prec. */
X {
X ++ptr, ++col;
X n=cons1(&nPAREN,paren());
X if(*ptr!=')') error(n->name,n->line,"missing )");
X else ++ptr, ++col;
X }
X break;
X
X case '{': /* List. */
X {
X ++ptr, ++col;
X n=cons1(&nLIST,opt(lst()));
X if(*ptr!='}') error(n->name,n->line,"missing }");
X else ++ptr, ++col;
X }
X break;
X
X default: /* Operator? */
X oops=ptr; oopscol=col; op=opr();
X if(op && (op=op->prefix))
X {
X if(op->meth&4) /* Make operator into an assignment? */
X n=expr(op->prec),
X n=cons2(&nSET,n,cons2(op->inst,dup(n),consnum(1)));
X else n=cons1(op,expr(op->prec));
X }
X else n=0, ptr=oops, col=oopscol;
X }
X if(!n) return 0; /* No expr */
X
X /* Infix/Postfix operators */
X loop:
X
X oops=ptr; oopscol=col;
X left=col;
X skipws();
X left=col-left;
X
X op=opr();
X
X right=col;
X skipws();
X if(*ptr && *ptr!=';') right=col-right;
X else right=32767;
X
X if(op && op->infix && (!op->prefix || left<=right) &&
X (op->infix->prec>prec || op->infix->prec==prec && op->infix->ass))
X {
X op=op->infix;
X if(op->meth&64) /* Function call? */
X {
X n=cons2(op,n,opt(lst()));
X skipwssm();
X if(*ptr==']') ++ptr, ++col;
X else error(n->name,n->line,"missing ]");
X }
X else if(op->meth&4) /* Make into assignment? */
X n=cons2((op->meth&8?&nPOST:&nSET), /* Post assignement? */
X n,
X cons2(op->inst,
X dup(n),
X expr(op->prec)
X )
X );
X else n=cons2(op,n,expr(op->prec)); /* Normal case */
X goto loop;
X }
X else if(op && op->postfix && (!op->prefix || left<=right) &&
X (op->postfix->prec>prec ||
X op->postfix->prec==prec && op->postfix->ass))
SHAR_EOF
true || echo 'restore of compile.c failed'
fi
echo 'End of part 1'
echo 'File compile.c is continued in part 2'
echo 2 > _shar_seq_.tmp
exit 0
--
/* jha...@world.std.com (192.74.137.5) */ /* Joseph H. Allen */
int a[1817];main(z,p,q,r){for(p=80;q+p-80;p-=2*a[p])for(z=9;z--;)q=3&(r=time(0)
+r*57)/7,q=q?q-1?q-2?1-p%79?-1:0:p%79-77?1:0:p<1659?79:0:p>158?-79:0,q?!a[p+q*2
]?a[p+=a[p+=q]=q]=q:0:0;for(;q++-1817;)printf(q%79?"%c":"%c\n"," #"[!a[q-1]]);}

Joseph H Allen

unread,

Sep 30, 1993, 1:09:20 PM9/30/93

Archive-name: ivy2/part2
Submitted-by: jha...@world.std.com

---- Cut Here and feed the following to sh ----
#!/bin/sh

# this is ivy.02 (part 2 of a multipart archive)

# do not concatenate these parts, unpack them in order with /bin/sh

# file compile.c continued
#
if test ! -r _shar_seq_.tmp; then
echo 'Please unpack part 1 first!'
exit 1
fi
(read Scheck
if test "$Scheck" != 2; then
echo Please unpack part "$Scheck" next!
exit 1
else
exit 0
fi
) < _shar_seq_.tmp || exit 1
if test ! -f _shar_wnt_.tmp; then
echo 'x - still skipping compile.c'
else
echo 'x - continuing file compile.c'

sed 's/^X//' << 'SHAR_EOF' >> 'compile.c' &&

X {
X op=op->postfix;
X if(op->meth&4) /* Make into an assignment? */
X n=cons2(&nPOST,

X n,
X cons2(op->inst,
X dup(n),

X consnum(1)
X )
X );
X else n=cons1(op,n); /* Normal case */
X goto loop;
X }
X else ptr=oops, col=oopscol;

X return n;
X }
X

/* Parse an expression. Allow commas in the expression */
X
NODE *exp()
X {
X NODE *e;
X skipwsm();
X if(*ptr==',') e=consvoid();
X else e=expr(0);
X if(e)
X while(skipws(), *ptr==',')
X ++col, ++ptr, skipws(),
X (e=cons2(&nCOMMA,e,opt((*ptr && *ptr!=';')?expr(0):0)));
X return e;
X }
X
/* Keyword (statement) table */
X
ATOM *ikwtab[]=
X { &nIF, &nELSE, &nFOR, &nWHILE, &nWITH, &nLOOP, &nLOCAL, &nUNTIL, &nBREAK,
X &nCONT, &nRETURN, &nFOREACH, &nINCLUDE, 0 };
X
#define KWHTLEN 32
ATOM *kwhtab[KWHTLEN];
int isinit=0;
X
void izkwtab()
X {
X int x, q;
X isinit=1;
X for(x=0;ikwtab[x];++x)
X {
X char *s=ikwtab[x]->name;
X accu=0; while(*s) accu=hnext(accu,*s++);
X ikwtab[x]->next=kwhtab[accu%KWHTLEN];
X kwhtab[accu%KWHTLEN]=ikwtab[x];
X }
X }
X
/* Look up a keyword (statement) */
X
ATOM *kw(name)
char *name;
X {
X char *s=name;
X ATOM *a;
X if(!isinit) izkwtab();
X accu=0; while(*s) accu=hnext(accu,*s++);
X for(a=kwhtab[accu%KWHTLEN];a;a=a->next) if(!strcmp(a->name,name)) return a;

X return 0;
X }
X

/* Parse command arg list */
X
NODE *cmdargs()
X {
X NODE *args=0, *e;
X char *org;
X int orgcol;
X if(skipws(), org=ptr, orgcol=col, *ptr && (args=exp()))
X {
X if(args->what==&nNAM && kw(args->s))
X { ptr=org, col=orgcol, args=0; return opt(0); }
X while(skipws(), org=ptr, orgcol=col, *ptr && (e=exp()))
X {
X if(e->what==&nNAM && kw(e->s)) { ptr=org, col=orgcol; break; }
X args=cons2(&nCOMMA,args,e);
X }
X }
X return opt(args);
X }
X
/* Parse a command or statement */
X
NODE *cmd()
X {
X int blvl;
X NODE *cmd, *e=0, *f;
X NODE *args=0;
X ATOM *k;
X skipwss();
X if(!*ptr) return 0;
X blvl=lvl;
X if(ptr[0]==':')
X if(ptr[1]==':')
X { /* A lamda function */
X ptr+=2, col+=2;

X skipwsm();
X if(*ptr=='[')
X {

X ++ptr; ++col;
X args=opt(lst());

X if(*ptr==']') ++ptr, ++col;

X else error(args->name,args->line,"missing ]");
X }
X else args=cmdargs();
X e=blk(blvl);
X return cons1(&nDEFUN,cons2(&nCOMMA,args,e));
X }
X else
X { /* A named function */
X ++ptr, ++col;
X e=exp();
X if(e && e->what==&nNAM) cmd=e, args=cmdargs();
X else if(e && e->what==&nCALL) args=e->r, e->r=0, cmd=e->l, e->l=0, rm(e);
X else
X {
X error(name,line,"invalid function name");
X rm(e);
X rm(blk(blvl));
X return 0;
X }
X return cons2(&nDEFUN,cmd,cons2(&nCOMMA,args,blk(blvl)));
X }
X cmd=exp();
X if(!cmd) return 0;
X if(cmd->what==&nCALL && cmd->l->what==&nNAM && kw(cmd->l->s))
X { /* If the user put parenthasis around an expression following
X * a statement, it looks like a function call */
X e=cmd->r; cmd->r=0;
X f=cmd->l; cmd->l=0;
X rm(cmd);
X cmd=f;
X }
X else if(cmd->what!=&nNAM) return cmd; /* If command was just an expression */
X if(k=kw(cmd->s))
X { /* Handle statements */
X rm(cmd);
X switch(k->meth)
X {
X case 1: if(!e) e=exp(); /* expr [block] */
X return cons2(k,e,opt(blk(blvl)));
X case 2: if(e) return cons1(k,opt(e)); /* [block] */
X return cons1(k,opt(blk(blvl)));
X case 3: if(e) return cons1(k,e);
X else return cons1(k,exp()); /* expr */
X case 4: if(e) return cons1(k,e);
X skipws(); /* [expr] */
X if(*ptr && *ptr!=';') return cons1(k,opt(exp()));
X else return cons1(k,consvoid());
X case 5: if(!e) e=exp(); f=exp(); /* expr expr [block] */
X return cons2(k,cons2(&nCOMMA,e,f),opt(blk(blvl)));
X case 6: if(!e) e=exp();
X if(e->what!=&nSTR)
X error(name,line,"argument to include not a string constant");
X else
X {
X FILE *f=fopen(e->s,"r");
X if(f) compfile(e->s,f), fclose(f);
X else error(name,line,"Couldn\'t open file \'%s\'",e->s);
X }
X rm(e);

X return 0;
X }
X }

X return cons2(&nCALL,cmd,cmdargs());
X }
X
/* Get a block */
X
NODE *blk(blvl)
X {
X NODE *e, *n;
X if(!(e=cmd()))
X if(skipwssm(), lvl>blvl && (e=cmd()))
X while(skipwssm(), lvl>blvl && (n=cmd())) e=cons2(&nCOMMA,e,n);
X return e;
X }
X
NODE *lblk()
X {
X NODE *e, *n;
X if(e=cmd())
X while(n=cmd()) e=cons2(&nCOMMA,e,n);
X return e;
X }
X
/* Get inside of parenthasis */
X
NODE *paren()
X {
X NODE *e, *n;
X if(skipwssm(), e=cmd())
X while(skipwssm(), n=cmd()) e=cons2(&nCOMMA,e,n);
X return e;
X }
X
/* Get list */
X
NODE *lst()
X {
X NODE *e, *n;
X if(skipwsm(), e=exp())
X while(skipwsm(), n=exp()) e=cons2(&nCOMMA,e,n);
X return e;
X }
X
/* Interpret a line of input. Requests more lines through 'more' if more is
X * needed to complete a command
X */
X
void interpret(buf,more)
char *buf, *(*more)();
X {
X NODE *n;
X long *c;
X ++line;
X getmore=more;
X ptr=buf; col=0; lvl= -1; eof=0;
X loop:
X if(n=lblk())
X {
X c=codegen(n);
X run(c);
X free(c);
X rm(n);
X goto loop;
X }
X else if(*ptr)
X {
X error(name,line,"unknown character");

X ++ptr, ++col;
X goto loop;
X }
X }
X

/* Compile argument string into a tree */
X
NODE *compargs(buf)
char *buf;
X {
X int olvl=lvl, oeof=eof, ocol=col, oline=line;
X char *optr=ptr, *(*omore)()=getmore;
X NODE *n;
X getmore=0;
X ptr=buf; col=0; lvl= -1; eof=0;
X n=opt(lst());
X lvl=olvl; eof=oeof; col=ocol; getmore=omore; ptr=optr; line=oline;

X return n;
X }
X

/* Compile an opened file */
X
static char *morefile() { return fgets(inbuf,1024,infile); }
X
void compfile(nam,f)
char *nam;
FILE *f;
X {
X FILE *oinfile=infile;
X int olvl=lvl, oeof=eof, ocol=col, oline=line;
X char *optr=ptr, *(*omore)()=getmore, *oname=name;
X infile=f; name=nam; line=0;
X while(fgets(inbuf,1024,infile)) interpret(inbuf,morefile);
X lvl=olvl; eof=oeof; col=ocol; getmore=omore; ptr=optr; infile=oinfile;
X name=oname; line=oline;
X }
SHAR_EOF
echo 'File compile.c is complete' &&
chmod 0600 compile.c ||

echo 'restore of compile.c failed'

Wc_c="`wc -c < 'compile.c'`"
test 21335 -eq "$Wc_c" ||
echo 'compile.c: original size 21335, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= compile.h ==============
if test -f 'compile.h' -a X"$1" != X"-c"; then
echo 'x - skipping compile.h (File already exists)'

rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp

echo 'x - extracting compile.h (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'compile.h' &&

/* Compiler
X Copyright (C) 1993 Joseph H. Allen
X
This file is part of IVY
X
IVY is free software; you can redistribute it and/or modify it under the
terms of the GNU General Public License as published by the Free Software
Foundation; either version 1, or (at your option) any later version.
X
IVY is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
details.
X
You should have received a copy of the GNU General Public License along with
IVY; see the file COPYING. If not, write to the Free Software Foundation,
675 Mass Ave, Cambridge, MA 02139, USA. */
X

#ifndef _Icompile
#define _Icompile 1
X
#include "run.h"
X
/* Parse tree nodes */
X
typedef struct node NODE;
typedef struct atom ATOM;
X
struct node
X {
X ATOM *what; /* What this node is */
X NODE *l; /* Left operand pointer */
X NODE *r; /* Right (single) operand pointer */
X char *s; /* If node is a string */
X int n; /* If node is an integer or size of string */
X int line; /* Line number this node is from */
X char *name; /* File this node is from */
X };
X
/* Atoms and terminals. The addresses of these are used for determining tree
X * node types */
X
struct atom
X {
X char *name; /* How it's scanned/printed */
X ATOM *prefix; /* Context dependant alternatives */
X ATOM *infix;
X ATOM *postfix;
X int prec; /* Precidence */
X int ass; /* Set for right-associative */
X int meth; /* Method to build parse tree out of it */
X int i; /* Which instruction to use */
X ATOM *inst; /* Which atom to use (for some meths) */
X ATOM *next; /* Next atom with same hash value */
X };
X
/* Methods for operators:
X * 1 2 No. args for operator. Can be ORed with one of the following:
X * 4 Make operator into an assignment
X * if operator is '*', it becomes '*='
X * 8 Post operation
X * if operator is '*=' if becomes '*:'
X * 64 Parse second arg up to ), use precidence of 0 for right side
X * I.E., arg is a function call
X *
X * Methods for statements:
X * 1 if expr [block]
X * 2 loop [block]
X * 3 until expr
X * 4 break [expr]
X * 5 foreach expr expr [block]
X * 6 include "string"
X */
X
extern ATOM nNAM, nNUM, nSTR, nCALL, nCOM, nNEG, nNOT, nSHR, nSHL, nMUL, nDIV,
X nMOD, nAND, nADD, nSUB, nOR, nXOR, nEQ, nNE, nLT, nGT, nLE, nGE,
X nLAND, nLOR, nSET, nPOST, nCOMMA, nSEQ, nDEFUN, nLIST, nIF, nELSE,
X nFOR, nWHILE, nWITH, nLOOP, nLOCAL, nUNTIL, nBREAK, nCONT, nRETURN,
X nFOREACH, nCALL1, nQUOTE, nPAREN, nEXTEND, nVOID, nPAREN;
X
/* Error message printer */
void error();
X
/* Skip whitespace */
void skipws(); /* Skip whitespace on line */
void skipwsm(); /* Skip whitespace on multiple lines */
void skipwssm(); /* Skip whitespace, including semicolons */
X
/* Tree constructors */
NODE *cons1();
NODE *cons2();
NODE *consnum();
NODE *consnam();
NODE *consstr();
NODE *consvoid();
NODE *opt();
X
/* Tree duplicator */
NODE *dup();
X
/* Tree eliminator */
void rm();
X
/* Parsing functions */
X
NODE *exp(); /* Parse an expression */
NODE *cmd(); /* Parse a single command/statement */
NODE *blk(); /* Parse a block of commands */
NODE *lst(); /* Parse list inside of [ ] or { } */
NODE *paren(); /* Parse commands inside of ( ) */
X
/* Interpret and execute a line immediately */
void interpret();
X
/* Compile and execute a file */
void compfile();
X
/* NODE *compargs(char *s); Compile argument string into a tree */
NODE *compargs();
X
#endif
SHAR_EOF
chmod 0600 compile.h ||
echo 'restore of compile.h failed'
Wc_c="`wc -c < 'compile.h'`"
test 3553 -eq "$Wc_c" ||
echo 'compile.h: original size 3553, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= main.c ==============
if test -f 'main.c' -a X"$1" != X"-c"; then
echo 'x - skipping main.c (File already exists)'

rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp

echo 'x - extracting main.c (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'main.c' &&
/* Main

X Copyright (C) 1993 Joseph H. Allen
X
This file is part of IVY
X
IVY is free software; you can redistribute it and/or modify it under the
terms of the GNU General Public License as published by the Free Software
Foundation; either version 1, or (at your option) any later version.
X
IVY is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
details.
X
You should have received a copy of the GNU General Public License along with
IVY; see the file COPYING. If not, write to the Free Software Foundation,
675 Mass Ave, Cambridge, MA 02139, USA. */
X
#include <stdio.h>

#include "compile.h"
#include "codegen.h"
#include "run.h"
X
/* Eliminate this if you're not on BSD */
char *strdup(a) char *a; { return strcpy((char *)malloc(strlen(a)+1),a); }

X
char buf[1024];
X

char *more()
X {
X return putchar(':'), fgets(buf,1024,stdin);
X }
X
main(argc,argv)
char *argv[];
X {
X int x;
X int ran=0;
X for(x=1;x!=argc;++x)
X if(argv[x][0]=='-') switch(argv[x][1])
X {
X case 'u': unasm=1; break; /* Unassemble */
X case 't': ptree=1; break; /* Print tree */
X case 'c': ptop=1; break; /* Print each result */
X }
X for(x=1;x!=argc;++x)
X if(argv[x][0]!='-')
X {
X FILE *f=fopen(argv[x],"r");
X ran=1;
X if(!f) fprintf(stderr,"Couldn\'t open file \'%s\'",argv[x]);
X else compfile(argv[x],f), fclose(f);
X }
X if(!ran)
X while(putchar('>'), fgets(buf,1024,stdin)) interpret(buf,more);
X }
SHAR_EOF
chmod 0600 main.c ||
echo 'restore of main.c failed'
Wc_c="`wc -c < 'main.c'`"
test 1549 -eq "$Wc_c" ||
echo 'main.c: original size 1549, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= makefile ==============
if test -f 'makefile' -a X"$1" != X"-c"; then
echo 'x - skipping makefile (File already exists)'

rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp

echo 'x - extracting makefile (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'makefile' &&
ivy: compile.o codegen.o run.o main.o rtlib.o
X $(CC) $(CFLAGS) -o ivy compile.o codegen.o run.o rtlib.o main.o
SHAR_EOF
chmod 0600 makefile ||
echo 'restore of makefile failed'
Wc_c="`wc -c < 'makefile'`"
test 111 -eq "$Wc_c" ||
echo 'makefile: original size 111, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= rtlib.c ==============
if test -f 'rtlib.c' -a X"$1" != X"-c"; then
echo 'x - skipping rtlib.c (File already exists)'

rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp

echo 'x - extracting rtlib.c (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'rtlib.c' &&
/* Run-time library

#include "run.h"
X
/* Write output */
X
void rtprint()
X {
X TAB *a=&getv("argv")->obj.v.v.obj->obj.tab;
X int x;
X for(x=0;x!=a->nitems;++x)
X {
X OBJ *v=getn(a,x);
X switch(v->obj.v.type)
X {
X case tSTR:printf("%s",v->obj.v.v.obj->obj.str.s); break;
X default: pr(&v->obj.v);
X }

X }
X printf("\n");

X (--sp)->type=tVOID;
X }
X
/* Get input */
X
void rtget()

X {
X char buf[1024];

X gets(buf);
X (--sp)->type=tSTR;
X sp->v.obj=mkobj(tSTR,strdup(buf),strlen(buf));
X }
X
void rtatoi()
X {
X OBJ *a=getv("a");
X if(a->obj.v.type==tSTR)
X {
X int num=atoi(a->obj.v.v.obj->obj.str.s);
X (--sp)->type=tNUM;
X sp->v.num=num;
X }
X else longjmp(err,1);
X }
X
void rtitoa()
X {
X OBJ *a=getv("a");
X if(a->obj.v.type==tNUM)
X {
X char buf[30];
X sprintf(buf,"%d",a->obj.v.v.num);
X (--sp)->type=tSTR;
X sp->v.obj=mkobj(tSTR,strdup(buf),strlen(buf));
X }
X else longjmp(err,1);
X }
X
/* Get length of string or array */
X
void rtlen()
X {
X OBJ *a=getv("a");
X if(a->obj.v.type==tSTR)
X {
X int num=a->obj.v.v.obj->obj.str.len;
X (--sp)->type=tNUM;
X sp->v.num=num;
X }
X else if(a->obj.v.type==tTAB)
X {
X (--sp)->type=tNUM;
X sp->v.num=a->obj.v.v.obj->obj.tab.nitems;
X }
X }
X
struct builtin builtins[]=
X {
X { "print", rtprint, "" },
X { "get", rtget, "" },
X { "atoi", rtatoi, "a" },
X { "itoa", rtitoa, "a" },
X { "len", rtlen, "a" },
X { 0, 0, 0 }
X };
SHAR_EOF
chmod 0600 rtlib.c ||
echo 'restore of rtlib.c failed'
Wc_c="`wc -c < 'rtlib.c'`"
test 2055 -eq "$Wc_c" ||
echo 'rtlib.c: original size 2055, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= run.c ==============
if test -f 'run.c' -a X"$1" != X"-c"; then
echo 'x - skipping run.c (File already exists)'

rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp

echo 'x - extracting run.c (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'run.c' &&
/* Interpreter

#include <varargs.h>
#include <string.h>
#include "run.h"
X
jmp_buf err; /* Error return point */
VAL *sptop; /* Top of stack */
VAL *sp=0; /* Stack */
int spsize; /* Stack size */
OBJ *glblvars; /* Outer-most scoping level: global variables */
OBJ *vars=0; /* Current deepest scoping level */
X
/** Stack grow function **/
X
void check(n)
X {
X if(sp+n-sptop>spsize)
X {
X int ss=sp-sptop;
X sptop=(VAL *)realloc(sptop,sizeof(VAL)*(spsize+=1024));
X sp=sptop+ss;
X }
X }
X
/*** Hash table functions ***/
X
/* Get object assigned to named variable in given table. If there is no such
X * variable, return NULL
X */
X
OBJ *get(t,name)
TAB *t;
char *name;
X {
X unsigned long hval=0;
X char *p=name;
X ENTRY *e;
X while(*p) hval=hnext(hval,*p++);
X for(e=t->tab[hval%t->size];e;e=e->next)
X if(e->name && !strcmp(e->name,name)) return e->obj;

X return 0;
X }
X

OBJ *getn(t,num)
TAB *t;
X {
X unsigned long hval=hashn(num);
X ENTRY *e;
X for(e=t->tab[hval%t->size];e;e=e->next)
X if(!e->name && e->num==num) return e->obj;

X return 0;
X }
X

ENTRY *eset(t,name)
TAB *t;
char *name;
X {
X unsigned long hval=0;
X char *p=name;
X ENTRY *e;
X while(*p) hval=hnext(hval,*p++);
X for(e=t->tab[hval%t->size];e;e=e->next)
X if(!strcmp(e->name,name))
X {
X rmobj(e->obj);
X return e;
X }
X e=(ENTRY *)malloc(sizeof(ENTRY));
X e->name=strdup(name);
X e->next=t->tab[hval%t->size];
X return t->tab[hval%t->size]=e;
X }
X
ENTRY *esetn(t,num)
TAB *t;
X {
X unsigned long hval=hashn(num);
X ENTRY *e;
X for(e=t->tab[hval%t->size];e;e=e->next)
X if(!e->name && e->num==num)
X {
X rmobj(e->obj);
X return e;
X }
X e=(ENTRY *)malloc(sizeof(ENTRY));
X if(num>=t->nitems) t->nitems=num+1;
X e->name=0;
X e->num=num;
X e->next=t->tab[hval%t->size];
X return t->tab[hval%t->size]=e;
X }
X
void setref(t,name,o)
TAB *t;
char *name;
OBJ *o;
X {
X eset(t,name)->obj=dupobj(o);
X }
X
void setrefn(t,num,o)
TAB *t;
OBJ *o;
X {
X esetn(t,num)->obj=dupobj(o);
X }
X
/* Get object assigned to named variable in given table. If there is no such
X * variable, create a new variable and return its object.
X */
X
OBJ *set(t,name)
TAB *t;
char *name;
X {
X unsigned long hval=0;
X char *p=name;
X ENTRY *e;
X while(*p) hval=hnext(hval,*p++);
X for(e=t->tab[hval%t->size];e;e=e->next)
X if(!strcmp(e->name,name)) return e->obj;
X e=(ENTRY *)malloc(sizeof(ENTRY));
X e->name=strdup(name);
X e->next=t->tab[hval%t->size];
X t->tab[hval%t->size]=e;
X return e->obj=mkobj(tVAR);
X }
X
OBJ *setn(t,num)
TAB *t;
X {
X unsigned long hval=hashn(num);
X ENTRY *e;
X for(e=t->tab[hval%t->size];e;e=e->next)
X if(!e->name && e->num==num) return e->obj;
X e=(ENTRY *)malloc(sizeof(ENTRY));
X if(num>=t->nitems) t->nitems=num+1;
X e->name=0;
X e->num=num;
X e->next=t->tab[hval%t->size];
X t->tab[hval%t->size]=e;
X return e->obj=mkobj(tVAR);
X }
X
/*** Variable management ***/
X
/* Lookup a variable. Check all scoping levels for the variable */
X
OBJ *getv(name)
char *name;
X {
X OBJ *o=vars, *e;
X do
X if(e=get(&o->obj.tab,name)) return e;
X while(o=o->obj.tab.next);

X return 0;
X }
X

/* Add a new level of local variables */
X
void addlvl()
X {
X OBJ *o=mkobj(tTAB,NULL,16);
X o->obj.tab.next=vars;
X vars=o;
X }
X
/* Remove a level of local variables */
X
void rmvlvl()
X {
X int amnt=vars->obj.tab.nnext;
X vars->obj.tab.nnext=0;
X do
X {
X OBJ *o=vars->obj.tab.next;
X vars->obj.tab.next=0;
X rmobj(vars);
X vars=o;
X }
X while(amnt--);
X }
X
/*** Object management ***/
X
/* Duplicate an object */
X
OBJ *dupobj(o)
OBJ *o;
X {
X ++o->ref;
X return o;
X }
X
/* Create a new object */
X
OBJ *mkobj(ty,s,size,code,nargs,args,init)
char *s, **args;
int *code, **init;
X {
X OBJ *o=(OBJ *)malloc(sizeof(OBJ));
X o->type=ty;
X o->ref=1;
X switch(ty)
X {
X case tTAB:
X o->obj.tab.size=size;
X o->obj.tab.next=0;
X o->obj.tab.nnext=0;
X o->obj.tab.nitems=0;
X o->obj.tab.tab=(ENTRY **)calloc(size,sizeof(ENTRY *));
X break;
X
X case tSTR:
X o->obj.str.s=s;
X o->obj.str.len=size;
X break;
X
X case tVAR:
X o->obj.v.type=tVOID;
X break;
X
X case tFUNC:
X o->obj.func.code=code;
X o->obj.func.nargs=nargs;
X o->obj.func.args=args;
X o->obj.func.inits=init;
X o->obj.func.cfunc=0;
X break;
X }
X return o;
X }
X
/* Eliminate an object */
X
void rmobj(o)
OBJ *o;
X {
X if(!o) return;
X if(!--o->ref)
X {
X int x;
X switch(o->type)
X {
X case tVAR:
X rmval(&o->obj.v);
X break;
X
X case tSTR:
X if(o->obj.str.s) free(o->obj.str.s);
X break;
X
X case tFUNC:
X if(o->obj.func.code) free(o->obj.func.code);
X for(x=0;x!=o->obj.func.nargs;++x)
X {
X free(o->obj.func.args[x]);
X if(o->obj.func.inits[x]) free(o->obj.func.inits[x]);
X }
X free(o->obj.func.args);
X free(o->obj.func.inits);
X break;
X
X case tTAB:
X {
X int x;
X ENTRY *e, *n;
X for(x=0;x!=o->obj.tab.size;++x)
X for(e=o->obj.tab.tab[x];e;e=n)
X {
X n=e->next;
X if(e->name) free(e->name);
X rmobj(e->obj);
X free(e);
X }
X free(o->obj.tab.tab);
X }
X }
X free(o);
X }
X }
X
/*** Value management ***/
X
/* Duplicate a value */
X
VAL *dupval(n,v)
VAL *n, *v;
X {
X switch(v->type)
X {
X case tLST:
X {
X int y=v->v.num, x, z;
X n->type=tTAB;
X n->v.obj=mkobj(tTAB,(void *)0,v->v.num);
X ++v;
X for(x=0,z=0;x!=y;++x)
X if(v->type==tNARG)
X v+=2, v=dupval(&set(&n->v.obj->obj.tab,v[-1].v.obj->obj.str.s)->obj.v,v);
X else v=dupval(&setn(&n->v.obj->obj.tab,z++)->obj.v,v);
X return v;
X }
X
X case tSTR:
X case tTAB:
X case tVAR:
X case tFUNC:
X dupobj(v->v.obj);
X default:
X *n= *v;
X return v+1;
X }
X }
X
/* Eliminate a value. Return pointer to after eliminated value */
X
VAL *rmval(v)
VAL *v;
X {
X switch(v->type)
X {
X case tLST:
X {
X int y=v->v.num, x;
X ++v;
X for(x=0;x!=y;++x) v=rmval(v);
X }
X break;
X
X case tNARG:
X v=rmval(rmval(++v));
X break;
X
X case tSTR:
X case tTAB:
X case tVAR:
X case tFUNC:
X rmobj(v->v.obj);
X default:
X ++v;
X }
X return v;
X }
X
/* Call a function */
X
static void callfunc(o)
OBJ *o;
X {
X OBJ *a;
X VAL *q;
X int x, argn;
X OBJ *argv; /* Argument vector and count */
X
X addlvl();
X argv=set(&vars->obj.tab,"argv");
X
X argv->obj.v.v.obj=mkobj(tTAB,NULL,16);
X argv->obj.v.type=tTAB;
X
X for(x=0,q=sp+1,argn=0;x!=sp[0].v.num;++x)
X if(q->type!=tNARG)
X if(argn>=o->obj.func.nargs)
X {
X /* if (var args not allowed) { printf("Too many args\n"); longjmp(err,1); } */
X a=setn(&argv->obj.v.v.obj->obj.tab,argn++);
X rmval(&a->obj.v);
X q=dupval(&a->obj.v,q);
X }
X else
X { /* Unnamed arg */
X a=set(&vars->obj.tab,o->obj.func.args[argn]);
X rmval(&a->obj.v);
X q=dupval(&a->obj.v,q);
X setrefn(&argv->obj.v.v.obj->obj.tab,argn++,a);
X }
X else
X { /* Named arg */
X int z;
X ++q;
X a=set(&vars->obj.tab,q->v.obj->obj.str.s);
X for(z=0;z!=o->obj.func.nargs;++z)
X if(!strcmp(o->obj.func.args[z],q->v.obj->obj.str.s))
X {
X setrefn(&argv->obj.v.v.obj->obj.tab,z,a);
X break;
X }
X rmval(&a->obj.v);
X q=dupval(&a->obj.v,++q);
X }
X for(x=0;x!=o->obj.func.nargs;++x)
X {
X a=set(&vars->obj.tab,o->obj.func.args[x]);
X if(a->obj.v.type==tVOID)
X if(o->obj.func.inits[x])
X {
X exe(o->obj.func.inits[x]);
X dupval(&a->obj.v,sp);
X setrefn(&argv->obj.v.v.obj->obj.tab,x,a);
X sp=rmval(sp);
X }
X else { printf("Arguments missing in function call\n"); longjmp(err,1); }
X }
X sp=rmval(sp);
X if(o->obj.func.code) exe(o->obj.func.code);
X else o->obj.func.cfunc();
X rmobj(o);
X rmvlvl();
X }
X
/* The interpreter itself */
X
void exe(pc)
int *pc;
X {
X /* Create local variables for args */
X /* Set args from what's given on stack */
X check(*pc++);
X for(;;) switch(*pc++)
X {
X case iBRA:
X pc+= *pc;
X break;
X
X case iBEQ:
X if(sp->type==tNUM)
X if(sp->v.num==0) ++sp, pc+= *pc;
X else ++sp, ++pc;
X else sp=rmval(sp), ++pc;
X break;
X
X case iBNE:
X if(sp->type!=tNUM) sp=rmval(sp), pc+= *pc;
X else if(sp->v.num) ++sp, pc+= *pc;
X else ++sp, ++pc;
X break;
X
X case iBGT:
X if(sp->type!=tNUM) longjmp(err,1);
X if(sp->v.num>0) ++sp, pc+= *pc;
X else ++sp, ++pc;
X break;
X
X case iBLT:
X if(sp->type!=tNUM) longjmp(err,1);
X if(sp->v.num<0) ++sp, pc+= *pc;
X else ++sp, ++pc;
X break;
X
X case iBGE:
X if(sp->type!=tNUM) longjmp(err,1);
X if(sp->v.num>=0) ++sp, pc+= *pc;
X else ++sp, ++pc;
X break;
X
X case iBLE:
X if(sp->type!=tNUM) longjmp(err,1);
X if(sp->v.num<=0) ++sp, pc+= *pc;
X else ++sp, ++pc;
X break;
X
X case iCOM:
X if(sp->type==tNUM) sp->v.num= ~sp->v.num;
X else longjmp(err,1);
X break;
X
X case iNEG:
X if(sp->type==tNUM) sp->v.num= -sp->v.num;
X else longjmp(err,1);
X break;
X
X case iSHL:
X if(sp[0].type==tNUM && sp[1].type==tNUM) sp[1].v.num<<=sp[0].v.num, ++sp;
X else longjmp(err,1);
X break;
X
X case iSHR:
X if(sp[0].type==tNUM && sp[1].type==tNUM) sp[1].v.num>>=sp[0].v.num, ++sp;
X else longjmp(err,1);
X break;
X
X case iMUL:
X if(sp[0].type==tNUM && sp[1].type==tNUM) sp[1].v.num*=sp[0].v.num, ++sp;
X else longjmp(err,1);
X break;
X
X case iDIV:
X if(sp[0].type==tNUM && sp[1].type==tNUM) sp[1].v.num/=sp[0].v.num, ++sp;
X else longjmp(err,1);
X break;
X
X case iMOD:
X if(sp[0].type==tNUM && sp[1].type==tNUM) sp[1].v.num%=sp[0].v.num, ++sp;
X else longjmp(err,1);
X break;
X
X case iAND:
X if(sp[0].type==tNUM && sp[1].type==tNUM) sp[1].v.num&=sp[0].v.num, ++sp;
X else longjmp(err,1);
X break;
X
X case iADD:
X if(sp[0].type==tNUM && sp[1].type==tNUM) sp[1].v.num+=sp[0].v.num, ++sp;
X else if(sp[0].type==tSTR && sp[1].type==tSTR)
X {
X int len;
X char *s=(char *)malloc((len=sp[0].v.obj->obj.str.len+
X sp[1].v.obj->obj.str.len)+1);
X OBJ *o=mkobj(tSTR,s,len);
X memcpy(s,sp[1].v.obj->obj.str.s,sp[1].v.obj->obj.str.len);
X memcpy(s+sp[1].v.obj->obj.str.len,sp[0].v.obj->obj.str.s,sp[0].v.obj->obj.str.len);
X s[len]=0;
X rmval(sp=rmval(sp));
X sp[0].v.obj=o;
X }
X else
X {
X VAL newv;
X dupval(&newv,sp);
X sp=rmval(sp);
X if(sp[0].type==tLST)
X {
X VAL vv;
X dupval(&vv,sp);
X sp=rmval(sp);
X *--sp=vv;
X }
X if(sp[0].type==tTAB)
X {
X OBJ *o=setn(&sp[0].v.obj->obj.tab,sp[0].v.obj->obj.tab.nitems);
X rmval(&o->obj.v);
X o->obj.v=newv;
X }
X else longjmp(err,1);
X }
X break;
X
X case iSUB:
X if(sp[0].type==tNUM && sp[1].type==tNUM) sp[1].v.num-=sp[0].v.num, ++sp;
X else longjmp(err,1);
X break;
X
X case iOR:
X if(sp[0].type==tNUM && sp[1].type==tNUM)
X {
X sp[1].v.num|=sp[0].v.num, ++sp;
X break;
X }
X if(sp[0].type==tLST)
X {
X VAL vv;
X dupval(&vv,sp);
X sp=rmval(sp);
X if(sp[0].type==tLST)
X {
X VAL vv;
X dupval(&vv,sp);
X sp=rmval(sp);
X *--sp=vv;
X }
X *--sp=vv;
X }
X if(sp[0].type==tTAB && sp[1].type==tTAB)
X {
X int x;
X TAB *t=&sp[0].v.obj->obj.tab;
X ENTRY *e;
X int a=sp[1].v.obj->obj.tab.nitems;
X for(x=0;x!=t->nitems;++x)
X {
X OBJ *o=setn(&sp[1].v.obj->obj.tab,x+a);
X OBJ *n=getn(t,x);
X rmval(&o->obj.v);
X dupval(&o->obj.v,&n->obj.v);
X }
X for(x=0;x!=t->size;++x)
X for(e=t->tab[x];e;e=e->next)
X if(e->name)
X {
X OBJ *o=set(&sp[1].v.obj->obj.tab,e->name);
X rmval(&o->obj.v);
X dupval(&o->obj.v,&e->obj->obj.v);
X }
X sp=rmval(sp);
X break;
X }
X longjmp(err,1);
X break;
X
X case iXOR:
X if(sp[0].type==tNUM && sp[1].type==tNUM) sp[1].v.num^=sp[0].v.num, ++sp;
X else longjmp(err,1);
X break;
X
X case iCMP:
X if(sp[0].type==tNUM && sp[1].type==tNUM)
X {
X if(sp[1].v.num==sp[0].v.num) sp[1].v.num=0;
X else if(sp[1].v.num>sp[0].v.num) sp[1].v.num=1;
X else sp[1].v.num= -1;
X ++sp;
X }
X else if(sp[0].type==tSTR && sp[1].type==tSTR)
X {
X int c=strcmp(sp[1].v.obj->obj.str.s,sp[0].v.obj->obj.str.s);
X rmval(sp=rmval(sp));
X sp->type=tNUM;
X sp->v.num=c;
X }
X else longjmp(err,1);
X break;
X
X case iBEG:
X addlvl();
X break;
X
X case iEND:
X rmvlvl();
X break;
X
X case iLOC:
X {
X int y=sp++->v.num, x;
X for(x=0;x!=y;++x)
X if(sp->type==tSTR)
X set(&vars->obj.tab,sp->v.obj->obj.str.s), sp=rmval(sp);
X else { printf("Error: Need names for local\n"); longjmp(err,1); }
X }
X break;
X
X case iWTH:
X {
X int y=sp++->v.num, x;
X for(x=0;x!=y;++x)
X if(sp->type==tTAB)
X if(!sp->v.obj->obj.tab.next)
X {
X sp->v.obj->obj.tab.next=vars->obj.tab.next;
X vars->obj.tab.next=sp->v.obj;
X ++vars->obj.tab.nnext;
X ++sp;
X }
X else { printf("Error: Table already scoped in\n"); longjmp(err,1); }
X else { printf("Error: Need tables for with\n"); longjmp(err,1); }
X }
X break;
X
X case iGET: /* Replace variable's name with its value */
X if(sp->type!=tSTR) longjmp(err,1);
X {
X OBJ *o=getv(sp->v.obj->obj.str.s);
X if(!o) o=set(&vars->obj.tab,sp->v.obj->obj.str.s);
X rmval(sp);
X dupval(sp,&o->obj.v);
X }
X break;
X
X case iLEA: /* Replace variable's name with its address */
X if(sp->type!=tSTR) longjmp(err,1);
X {
X OBJ *o=getv(sp->v.obj->obj.str.s);
X if(!o) o=set(&vars->obj.tab,sp->v.obj->obj.str.s);
X rmval(sp);
X sp->type=tVAR;
X sp->v.obj=dupobj(o);
X }
X break;
X
X case iSET: /* Set addressed variable with a value */
X if(sp->type!=tVAR && sp->type!=tPOS) longjmp(err,1);
X {
X VAL newv;
X OBJ *o;
X if(sp->type==tPOS)
X { /* Create new string */
X int pos=sp++->v.num;
X int oldlen=sp->v.obj->obj.v.v.obj->obj.str.len;
X if(sp[1].type==tSTR)
X {
X int newlen=sp[1].v.obj->obj.str.len;
X int len;
X char *s;
X if(oldlen>newlen+pos) len=oldlen;
X else len=newlen+pos;
X s=(char *)malloc(len+1);
X s[len]=0;
X memcpy(s,sp->v.obj->obj.v.v.obj->obj.str.s,oldlen);
X if(len>oldlen) memset(s+oldlen,' ',len-oldlen);
X memcpy(s+pos,sp[1].v.obj->obj.str.s,newlen);
X rmval(sp+1);
X sp[1].type=tSTR;
X sp[1].v.obj=mkobj(tSTR,s,len);
X }
X else if(sp[1].type==tNUM)
X {
X int newlen=1;
X int len;
X char *s;
X if(oldlen>newlen+pos) len=oldlen;
X else len=newlen+pos;
X s=(char *)malloc(len+1);
X s[len]=0;
X memcpy(s,sp->v.obj->obj.v.v.obj->obj.str.s,oldlen);
X if(len>oldlen) memset(s+oldlen,' ',len-oldlen);
X s[pos]=sp[1].v.num;
X rmval(sp+1);
X sp[1].type=tSTR;
X sp[1].v.obj=mkobj(tSTR,s,len);
X }
X else longjmp(err,1);
X }
X dupval(&newv,sp+1); /* Duplicate value */
X o=sp->v.obj; /* o points to variable */
X rmval(&o->obj.v); /* Eliminate previous value */
X o->obj.v=newv; /* Set new value */
X sp=rmval(sp); /* POP address off stack */
X }
X break;
X
X case iCALLA: /* Get struct. member/array element address */
X if(sp->type==tVAR && sp->v.obj->obj.v.type!=tFUNC)
X {
X OBJ *r=sp->v.obj;
X if(sp[1].type==tLST && sp[1].v.num==1 && sp[2].type==tNUM &&
X r->obj.v.type==tSTR)
X {
X sp[1].type=tPOS;
X sp[1].v.num=sp[2].v.num;
X sp[2]=sp[0];
X ++sp;
X }
X else if(sp[1].type!=tLST || sp[1].v.num!=1 ||
X sp[2].type!=tSTR && sp[2].type!=tNUM)
X { printf("Error: incorrect index\n"); longjmp(err,1); }
X else
X {
X OBJ *t, *o;
X if(r->obj.v.type!=tTAB)
X { /* Create new table if what we're trying to access is not a table */
X rmval(&r->obj.v);
X r->obj.v.type=tTAB;
X t=r->obj.v.v.obj=mkobj(tTAB,NULL,16);
X }
X else t=r->obj.v.v.obj;
X if(sp[2].type==tNUM)
X { /* Get or create numbered element */
X if(!(o=getn(&t->obj.tab,sp[2].v.num))) o=setn(&t->obj.tab,sp[2].v.num);
X }
X else
X /* Get or create named element */
X if(!(o=get(&t->obj.tab,sp[2].v.obj->obj.str.s)))
X o=set(&t->obj.tab,sp[2].v.obj->obj.str.s);
X rmval(sp+2);
X sp[2].type=tVAR;
X sp[2].v.obj=dupobj(o);
X sp=rmval(sp);
X ++sp;

X }
X break;
X }
X

X case iCALL: /* Call function / Get struct. member/array element */
X if(sp->type==tLST)
X {
X VAL vv;
X dupval(&vv,sp);
X sp=rmval(sp);
X *--sp=vv;
X }
X if(sp->type==tFUNC) callfunc(sp++->v.obj);
X else if(sp->type==tSTR)
X {
X if(sp[1].v.num==1)
X {
X sp[2].v.num=sp->v.obj->obj.str.s[sp[2].v.num];
X sp=rmval(sp);
X ++sp;
X }
X else if(sp[1].v.num==2)
X {
X int a=sp[2].v.num;
X int b=sp[3].v.num;
X char *s=(char *)malloc(b-a+1);
X int x;
X memcpy(s,sp->v.obj->obj.str.s+a,b-a);
X s[b-a]=0;
X sp=rmval(sp);
X sp=rmval(sp);
X (--sp)->v.obj=mkobj(tSTR,s,b-a);
X sp->type=tSTR;
X }
X }
X else if(sp->type==tTAB)
X {
X if(!sp[1].v.num)
X {
X dupval(sp+1,&sp->v.obj->obj.v);
X sp=rmval(sp);
X }
X else if(sp[1].v.num!=1)
X { printf("Error: too many args for table\n"); longjmp(err,1); }
X else
X {
X OBJ *t=sp->v.obj;
X if(sp[2].type==tNUM)
X {
X OBJ *o=getn(&t->obj.tab,sp[2].v.num);
X if(!o)
X { printf("Error: no such member '%d'\n",sp[2].v.num); longjmp(err,1); }
X dupval(sp+2,&o->obj.v);
X sp=rmval(sp)+1;
X }
X else if(sp[2].type==tSTR)
X {
X OBJ *o=get(&t->obj.tab,sp[2].v.obj->obj.str.s);
X if(!o)
X { printf("Error: no such member \'%s\'\n",sp[2].v.obj->obj.str.s);
X longjmp(err,1); }
X rmval(sp+2);
X dupval(sp+2,&o->obj.v);
X sp=rmval(sp);
X ++sp;
X }
X else
X { printf("Error: invalid index type\n"); longjmp(err,1); }
X }
X }
X else if(sp->type==tVAR) switch(sp->v.obj->obj.v.type)
X {
X case tFUNC:
X {
X OBJ *o=dupobj(sp->v.obj->obj.v.v.obj);
X sp=rmval(sp);
X callfunc(o);
X }
X break;
X
X case tSTR:
X if(sp[1].v.num==1)
X {
X sp[2].v.num=sp->v.obj->obj.v.v.obj->obj.str.s[sp[2].v.num];
X sp=rmval(sp);
X ++sp;
X }
X else if(sp[1].v.num==2)
X {
X int a=sp[2].v.num;
X int b=sp[3].v.num;
X char *s=(char *)malloc(b-a+1);
X int x;
X memcpy(s,sp->v.obj->obj.v.v.obj->obj.str.s+a,b-a);
X s[b-a]=0;
X sp=rmval(sp);
X sp=rmval(sp);
X (--sp)->v.obj=mkobj(tSTR,s,b-a);
X sp->type=tSTR;
X }
X break;
X
X case tTAB:
X if(!sp[1].v.num)
X {
X dupval(sp+1,&sp->v.obj->obj.v);
X sp=rmval(sp);
X }
X else if(sp[1].v.num!=1)
X { printf("Error: too many args for table\n"); longjmp(err,1); }
X else
X {
X OBJ *t=sp->v.obj->obj.v.v.obj;
X if(sp[2].type==tNUM)
X {
X OBJ *o=getn(&t->obj.tab,sp[2].v.num);
X if(!o)
X { printf("Error: no such member '%d'\n",sp[2].v.num); longjmp(err,1); }
X dupval(sp+2,&o->obj.v);
X sp=rmval(sp)+1;
X }
X else if(sp[2].type==tSTR)
X {
X OBJ *o=get(&t->obj.tab,sp[2].v.obj->obj.str.s);
X if(!o)
X { printf("Error: no such member \'%s\'\n",sp[2].v.obj->obj.str.s);
X longjmp(err,1); }
X rmval(sp+2);
X dupval(sp+2,&o->obj.v);
X sp=rmval(sp);
X ++sp;
X }
X else
X { printf("Error: invalid index type\n"); longjmp(err,1); }

X }
X break;
X
X default:

X if(sp[1].v.num) { printf("No args allowed\n"); longjmp(err,1); }
X dupval(sp+1,&sp->v.obj->obj.v);
X sp=rmval(sp);
X }
X else longjmp(err,1);
X break;
X
X case iRTS:
X return;
X
X case iPOP:
X sp=rmval(sp);
X break;
X
X case iPSH:
X switch((--sp)->type= *pc++)
X {
X case tNUM:
X case tLST:
X sp->v.num= *pc++;
X break;
X
X case tSTR:
X sp->v.obj=mkobj(tSTR,memcpy((char *)malloc(*pc+1),pc+1,*pc+1),*pc);
X pc+=(*pc+sizeof(int))/sizeof(int)+1;
X break;
X
X case tFUNC:
X sp->v.obj=dupobj(*pc++);
X break;
X }
X break;
X }
X }
X
/* Print a value */
X
VAL *pr(v)
VAL *v;
X {
X switch(v->type)
X {
X case tNUM: printf("%d",v->v.num); return v+1;
X case tSTR: printf("\"%s\"",v->v.obj->obj.str.s); return v+1;
X case tVOID: printf("Void"); return v+1;
X case tFUNC: printf("Function %X",v->v.obj); return v+1;
X case tVAR: printf("Variable %X",v->v.obj); return v+1;
X case tTAB:
X {
X int x;
X ENTRY *e;
X printf("Object (");
X for(x=0;x!=v->v.obj->obj.tab.size;++x)
X for(e=v->v.obj->obj.tab.tab[x];e;e=e->next)
X (e->name?printf("`%s=",e->name):printf("`%d=",e->num)),
X pr(&e->obj->obj.v), printf(" ");
X printf(")");
X return v+1;
X }
X case tLST:
X {
X int y=v->v.num, x;
X ++v;
X printf("Stack list (");
X for(x=0;x!=y;++x)
X {
X if(v->type==tNARG) v+=2, printf("`%s=",v[-1].v.obj->obj.str.s);
X v=pr(v);
X if(x!=y-1) printf(", ");
X }
X printf(")");
X return v;
X }
X }
X }
X
/* Eliminate all current scoping levels and everything on the stack */
X
void zap()
X {
X while(sp!=sptop) sp=rmval(sp);
X while(vars!=glblvars) rmvlvl();
X }
X
/* Run some compiled code */
X
void izrun()
X {
X int x;
X sptop=sp=1024+(VAL *)malloc(sizeof(VAL)*(spsize=1024));
X addlvl(); glblvars=vars;
X for(x=0;builtins[x].name;++x)
X addfunc(builtins[x].name,builtins[x].args,builtins[x].cfunc);
X }
X
int ptop=0;
X
void run(code)
int *code;
X {
X if(!sp) izrun();
X if(!setjmp(err))
X {
X exe(code);
X if(ptop) pr(sp), printf("\n");
X zap();
X }
X else zap(), printf("\nError stop\n");
X }
SHAR_EOF
chmod 0600 run.c ||
echo 'restore of run.c failed'
Wc_c="`wc -c < 'run.c'`"
test 20966 -eq "$Wc_c" ||
echo 'run.c: original size 20966, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= run.h ==============
if test -f 'run.h' -a X"$1" != X"-c"; then
echo 'x - skipping run.h (File already exists)'

rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp

echo 'x - extracting run.h (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'run.h' &&
/* Interpreter

#ifndef _Irun
#define _Irun 1
X
#include <setjmp.h>
X
extern jmp_buf err;
X
/* Interpreter */
X
typedef struct entry ENTRY;
typedef struct val VAL;
typedef struct object OBJ;
typedef struct tab TAB;
X
/* Hash iterator */
X
#define hnext(accu,c) (((accu)<<4)+((accu)>>28)+(c))
#define hashn(num) ((num)+((num)<<4)+((num)<<12)+((num)<<20))
X
/* A hash table entry: for variables and structure members */
X
struct entry
X {
X unsigned long hval; /* Hashed version of 'id' */
X char *name;
X int num;
X ENTRY *next;
X OBJ *obj;
X };
X
/* A hash table */
X
struct tab
X {
X ENTRY **tab;
X OBJ *next;
X int nnext;
X int size;
X int nitems;
X };
X
/* A value */
X
struct val
X {
X int type; /* What type this thing is */
X union
X {
X int num; /* An integer */
X OBJ *obj; /* Some object more complex than an integer */
X } v;
X };
X
/* An automatic object. Object go away when their reference count goes to 0
X * When a complex object is eliminated, the objects to which it might refer
X * are recursively visited to decrease their reference count and delete them
X * if necessary
X */
X
struct object
X {
X int ref; /* Reference count */
X int type; /* What this thing is */
X union
X {
X VAL v; /* If object is a variable */
X
X struct
X {
X char *s;
X int len;
X } str; /* If object is a string */
X
X TAB tab; /* If object is a structure/array */
X
X struct
X {
X int *code; /* Code address */
X void (*cfunc)(); /* C function address */
X char **args; /* Arguments names */
X int **inits; /* Argument initializers */
X int nargs; /* No. args */
X } func; /* If object is a function */
X
X } obj;
X };
X
/* Type Codes */
X
/* An OBJ can be a: tSTR, tTAB, tFUNC or tVAR */
X
/* A VAL can be a: tINT, tSTR, tTAB, tLST, tVAR, tFUNC, or tVOID
X * When a VAL is a tSTR, tTAB, tFUNC, or tVAR, it refers to an OBJ */
X
enum
X {
X tNUM, /* Integer */
X tSTR, /* String */
X tTAB, /* Structure */
X tLST, /* List count (only on stack) */
X tNARG, /* Named argument */
X tVAR, /* A variable */
X tFUNC, /* A function */
X tPOS, /* A string position */
X tVOID /* Nothing */
X };
X
/* Pseudo-Instruction Set */
X
/* 1st refers to top of stack */
/* 2nd refers to second element on stack */
X
enum
X {
X /* Flow */
X iBRA, /* iBRA <offset> Add offset to PC */
X iBEQ, /* iBEQ <offset> POP, BRA if ==0 */
X iBNE, /* iBNE <offset> POP, BRA if !=0 */
X iBGT, /* iBGT <offset> POP, BRA if >0 */
X iBLT, /* iBLT <offset> POP, BRA if <0 */
X iBGE, /* iBGE <offset> POP, BRA if >=0 */
X iBLE, /* iBLE <offset> POP, BRA if <=0 */
X
X /* Basic operators */
X iCOM, /* iCOM 1s complement 1st */
X iNEG, /* iNEG 2s complement 1st */
X iSHL, /* iSHL Shift 2nd left by 1st, POP */
X iSHR, /* iSHR Shift 2nd right by 1st, POP */
X iMUL, /* iMUL 2nd*=1st, POP */
X iDIV, /* iDIV 2nd/=1st, POP */
X iMOD, /* iMOD 2nd%=1st, POP */
X iAND, /* iAND 2nd*=1st, POP */
X iADD, /* iADD 2nd+=1st, POP */
X /* iADD also concatenates strings */
X iSUB, /* iSUB 2nd-=1st, POP */
X iOR, /* iOR 2nd|=1st, POP */
X iXOR, /* iXOR 2nd^=1st, POP */
X iCMP, /* iCMP 2nd compared with 1st, POP */
X /* iCMP also works on strings */
X
X /* Block structuring */
X iBEG, /* iBEG Make new block level */
X iEND, /* iEND Remove 1 level of local vars */
X iLOC, /* iLOC Create local variable */
X iWTH, /* iWTH With statement */
X
X /* Variable lookup */
X iGET, /* iGET Get named variable's value */
X iLEA, /* iLEA Get named variable's address */
X
X /* Assignment */
X iSET, /* iSET Assign value to variable */
X
X /* Functions / Arrays / Structures */
X iCALL, /* iCALL Call or get member/element */
X iCALLA, /* iCALLA Get addr of member/element */
X iRTS, /* iRTS Return from subroutine */
X
X /* Stack */
X iPOP, /* iPOP Kill 1st */
X iPSH, /* iPSH <type> <const> Push constant onto stack */
X };
X
OBJ *get();
OBJ *getn();
OBJ *set();
OBJ *setn();
OBJ *getv();
void addlvl();
void rmvlvl();
OBJ *dupobj();
OBJ *mkobj();
void rmobj();
VAL *dupval();
VAL *rmval();
void exe();
VAL *pr();
void zap();
void run();
void izrun();
X
extern VAL *sp;
extern OBJ *vars;
extern OBJ *glblvars;
X
struct builtin
X {
X char *name; /* Function name */
X void (*cfunc)(); /* Function address */
X char *args; /* Argument list */
X };
X
extern struct builtin builtins[];
X
extern int ptop;
X
#endif
SHAR_EOF
chmod 0600 run.h ||
echo 'restore of run.h failed'
Wc_c="`wc -c < 'run.h'`"
test 4994 -eq "$Wc_c" ||
echo 'run.h: original size 4994, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= sort.i ==============
if test -f 'sort.i' -a X"$1" != X"-c"; then
echo 'x - skipping sort.i (File already exists)'

rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp

echo 'x - extracting sort.i (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'sort.i' &&
# Bubble sort function
X
:sort array
X loop # Loop until sorted
X flg=0
X for a=0, a!=len[array]-1, ++a # Check array
X if array[a]>array[a+1] # Element out of order?
X array[a]=array[a+1]:array[a] # Swap it...
X flg=1
X until !flg
X return array
X
# Example uses
X
print sort[{3 8 2 6 4 5 1 9}]
print sort[{"this" "is" "a" "test" "of" "this" "thing"}]
SHAR_EOF
chmod 0600 sort.i ||
echo 'restore of sort.i failed'
Wc_c="`wc -c < 'sort.i'`"
test 377 -eq "$Wc_c" ||
echo 'sort.i: original size 377, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
rm -f _shar_seq_.tmp
echo You have unpacked the last part

Joseph H Allen

unread,

Sep 30, 1993, 1:19:36 PM9/30/93

I've posted to alt.sources an other version of my new interpreted command
language.

This version includes a number of fixes:

- the atoi[] library function is fixed

- 'else' associates properly on single line commands:
if 1==2 print "One" else print "Two"

- you can access immediate objects like you can immediate strings:
for a=0,a!=3,++a print {"One","Two","Three"}[a]

- calling a returned function or object now works: foo[][5]

- lambda function syntax has been changed to look more like named-function
syntax: (:: x y z; x*y*z) or (::[x,y,z] x*y*z)

- some additional error checking has been added. More still needs to be
done

Oh, I forgot to do it to this version, but, as many people have suggested,
next version will not be GNU licensed.

0 new messages