games-request@tekred.TEK.COM (08/05/87)
Submitted by: cunniff%hpda@hplabs.HP.COM (Ross Cunniff)
Comp.sources.games: Volume 2, Issue 25
Archive-name: adl/Part08
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 8 (of 11)."
# Contents: adlcomp/adlobj.c adlcomp/predef.c adlcomp/routcomp.c
# adlrun/adlrun.c adlrun/adlspec.c adlrun/rtlex.c
# samples/aard/objects.adl
# Wrapped by billr@tekred on Tue Aug 4 16:27:46 1987
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f adlcomp/adlobj.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"adlcomp/adlobj.c\"
else
echo shar: Extracting \"adlcomp/adlobj.c\" \(6864 characters\)
sed "s/^X//" >adlcomp/adlobj.c <<'END_OF_adlcomp/adlobj.c'
X /***************************************************************\
X * *
X * adlobj.c - routines dealing with the compilation of *
X * object declaractions and assigments. *
X * Copyright 1987 by Ross Cunniff. *
X * *
X \***************************************************************/
X
X#include <stdio.h>
X
X#include "adltypes.h"
X#include "adlprog.h"
X#include "adldef.h"
X#include "adlcomp.h"
X
X
X /***************************************************************\
X * *
X * noun_exists( adj, noun ) - returns an object ID iff *
X * an object exists with noun ID noun and adjective id *
X * adj. Returns -1 otherwise. *
X * *
X \***************************************************************/
X
Xint16
Xnoun_exists( adj, noun )
Xint16
X adj,
X noun;
X{
X int16
X t;
X
X for( t = nounspace[ noun ]; t != 0; t = objspace[ t ].others )
X if( objspace[ t ].adj == adj )
X return t;
X return -1;
X}
X
X
X /***************************************************************\
X * *
X * move_obj( obj, dest ) - moves object obj to object *
X * dest, taking care to put obj at the END of the list *
X * of objects contained in dest. *
X * *
X \***************************************************************/
X
Xmove_obj( obj, dest )
Xint16
X obj, dest;
X{
X int16
X t;
X
X /* Find the object whose link is obj (if any) */
X t = objspace[ obj ].loc;
X if( objspace[ t ].cont != obj ) {
X /* Obj must be a link */
X t = objspace[ t ].cont;
X while( objspace[ t ].link != obj )
X t = objspace[ t ].link;
X objspace[ t ].link = objspace[ objspace[ t ].link ].link;
X }
X else
X /* Obj is the head of the list. */
X objspace[ t ].cont = objspace[ objspace[ t ].cont ].link;
X
X /* Seek to the end of the list and place obj there. */
X objspace[ obj ].loc = dest;
X t = objspace[ dest ].cont;
X objspace[ obj ].link = 0;
X if( t ) {
X /* Jump to the end of the list */
X while( objspace[ t ].link )
X t = objspace[ t ].link;
X objspace[ t ].link = obj;
X }
X else
X /* There is nothing in the list. */
X objspace[ dest ].cont = obj;
X}
X
X
X /***************************************************************\
X * *
X * new_noun( mod, noun ) - create a new object with *
X * modifier list mod and noun ID noun. The object is *
X * initially placed in .ALL. *
X * *
X \***************************************************************/
X
Xint16
Xnew_noun( mod, noun )
Xint16
X mod, noun;
X{
X int16
X obj;
X
X obj = NUMOBJ++;
X objspace[ obj ].others = nounspace[ noun ];
X nounspace[ noun ] = obj;
X objspace[ obj ].loc = _ALL;
X objspace[ obj ].link = objspace[ _ALL ].cont;
X objspace[ _ALL ].cont = obj;
X objspace[ obj ].adj = mod;
X objspace[ obj ].noun = noun;
X return obj;
X}
X
X
X /***************************************************************\
X * *
X * getnew( t_read ) - read a new modified object from the *
X * token stream and return its id. t_read is nonzero *
X * iff the first token in the list has already been read. *
X * *
X \***************************************************************/
X
Xint16
Xgetnew( t_read )
Xint16
X t_read;
X{
X int16
X t_save;
X
X if( !t_read )
X lexer();
X if( t_type == VERB ) {
X t_val = -t_val;
X t_type = ADJEC;
X }
X if( t_type == ADJEC ) {
X t_save = t_val;
X lexer();
X if( t_type == UNDECLARED ) {
X insertkey( token, NOUN, NUMNOUN, 1 );
X return new_noun( t_save, NUMNOUN++ );
X }
X else if( t_type == NOUN ) {
X if( (noun_exists( t_save, t_val ) >= 0) ||
X (noun_exists( 0, t_val ) >= 0) )
X error( "Attempt to redeclare a noun.\n" );
X else
X return new_noun( t_save, t_val );
X }
X else
X error( NOUN_WANTED );
X }
X else if( t_type == UNDECLARED ) {
X insertkey( token, NOUN, NUMNOUN, 1 );
X return new_noun( 0, NUMNOUN++ );
X }
X else
X error( ILLEGAL_SYMBOL );
X return -1;
X}
X
X
X /***************************************************************\
X * *
X * getold( t_read, t_save ) - read a previously declared *
X * object from the token string. t_read is the number *
X * of tokens already read, and t_save is the value of the *
X * previous token (if such exists). *
X * *
X \***************************************************************/
X
Xint16
Xgetold( t_read, t_save )
Xint16
X t_read,
X t_save;
X{
X if( t_read == 0 )
X lexer();
X if( t_read != 2 ) {
X if( t_type == NOUN_SYN )
X return t_val;
X if( t_type == VERB ) {
X t_type = ADJEC;
X t_val = -t_val;
X }
X if( t_type == ADJEC ) {
X t_save = t_val;
X lexer();
X }
X }
X if( t_type != NOUN ) {
X error( ILLEGAL_SYMBOL );
X return -1;
X }
X if( (t_save = noun_exists( t_save, t_val )) < 0 )
X error( ATTEMPT );
X return t_save;
X}
X
X
X /***************************************************************\
X * *
X * setprop( obj, which, val ) - set the which'th property *
X * of object obj to be val. *
X * *
X \***************************************************************/
X
Xsetprop( obj, which, val )
Xint16
X obj,
X which,
X val;
X{
X static char
X *ALREADY = "Noun property already assigned.\n";
X
X if( (which >=1) && (which <= 16) ) {
X /* Boolean property */
X if( objspace[ obj ].props1to16 & bitpat[ which - 1 ] )
X warning( ALREADY );
X if( val )
X objspace[ obj ].props1to16 |= bitpat[ which - 1 ];
X else
X objspace[ obj ].props1to16 &= ibitpat[ which - 1 ];
X }
X else if( (which >= 17) && (which <= _ACT ) ) {
X if( objspace[ obj ].props[ which - 17 ] )
X warning( ALREADY );
X objspace[ obj ].props[ which - 17 ] = val;
X }
X else
X error( "Invalid object property number.\n" );
X}
X
X
X/***************************************************************\
X* *
X* nounassign( t_read, t_save ) - parse and interpret a *
X* noun property assignment. *
X* *
X\***************************************************************/
X
Xnounassign( t_read, t_save )
Xint16
X t_read,
X t_save;
X{
X int16
X obj,
X which,
X getassign();
X
X obj = getold( t_read, t_save );
X lexer();
X if( t_type != '(' )
X _ERR_FIX( LEFT_EXPECTED, ';' );
X lexer();
X if( t_type != CONST )
X _ERR_FIX( CONST_EXPECTED, ';' );
X which = t_val;
X lexer();
X if( t_type != ')' )
X _ERR_FIX( RIGHT_EXPECTED, ';' );
X setprop( obj, which, getassign( 0 ) );
X}
X
X
X /***************************************************************\
X * *
X * getnouns() - parse and interpret a NOUN declaration. *
X * *
X \***************************************************************/
X
Xgetnouns()
X{
X int16
X obj, loc;
X
X while( t_type != ';' ) {
X if( (obj = getnew( 0 )) >= 0 ) {
X lexer();
X if( t_type == '(' ) {
X loc = getold( 0, 0 );
X move_obj( obj, loc );
X lexer();
X if( t_type != ')' )
X _ERR_FIX( RIGHT_EXPECTED, ';' );
X lexer();
X }
X else if( (t_type != ',') && (t_type != ';') )
X _ERR_FIX( COMMA_EXPECTED, ';' );
X }
X else
X eatuntil( ';' );
X }
X}
X
X/*** EOF adlobj.c ***/
END_OF_adlcomp/adlobj.c
if test 6864 -ne `wc -c <adlcomp/adlobj.c`; then
echo shar: \"adlcomp/adlobj.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f adlcomp/predef.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"adlcomp/predef.c\"
else
echo shar: Extracting \"adlcomp/predef.c\" \(4775 characters\)
sed "s/^X//" >adlcomp/predef.c <<'END_OF_adlcomp/predef.c'
X/* predef.c - predeclared symbols for adlcomp */
X#include <stdio.h> /* To get EOF */
X#include "adltypes.h"
X#include "adlprog.h"
X#include "adldef.h"
X#include "builtins.h"
X
Xinit_predefs()
X{
X insert_sys( ".ME", MYVAL, 0 );
X
X insert_sys( "INCLUDE", INCLUDE, 0 );
X insert_sys( "MESSAGE", MESSAGE, 0 );
X insert_sys( "VAR", VAR_D, 0 );
X insert_sys( "ROUTINE", ROUT_D, 0 );
X insert_sys( "LOCAL", LOCAL_D, 0 );
X
X insert_sys( "ARTICLE", ART_D, 0 );
X insert_sys( "PREP", PREP_D, 0 );
X insert_sys( "ADJEC", ADJEC_D, 0 );
X insert_sys( "NOUN", NOUN_D, 0 );
X insert_sys( "VERB", VERB_D, 0 );
X
X insert_sys( "DWIMD", ROUTINE, _DWIMD );
X insert_sys( "DWIMI", ROUTINE, _DWIMI );
X insert_sys( "START", ROUTINE, _START );
X
X insert_sys( "NOVERB", VERB, _NOVERB );
X insert_sys( "TELLER", VERB, _TELLER );
X
X insert_sys( "LDESC", CONST, _LD );
X insert_sys( "SDESC", CONST, _SD );
X insert_sys( "ACTION", CONST, _ACT );
X insert_sys( "PREACT", CONST, _PREACT );
X
X insert_sys( "Verb", VAR, _VERB_G );
X insert_sys( "Dobj", VAR, _DOBJ_G );
X insert_sys( "Iobj", VAR, _IOBJ_G );
X insert_sys( "Prep", VAR, _PREP_G );
X insert_sys( "Conj", VAR, _CONJ_G );
X insert_sys( "Numd", VAR, _NUMD_G );
X
X insert_sys( ".ALL", NOUN_SYN, _ALL );
X insert_sys( "STRING", NOUN_SYN, _STRING );
X
X insert_sys( "WHILE", WHILE, 0 );
X insert_sys( "DO", DO, 0 );
X insert_sys( "IF", IF, 0 );
X insert_sys( "THEN", THEN, 0 );
X insert_sys( "ELSEIF", ELSEIF, 0 );
X insert_sys( "ELSE", ELSE, 0 );
X
X insert_sys( "$loc", ROUTINE, _LOC );
X insert_sys( "$cont", ROUTINE, _CONT );
X insert_sys( "$link", ROUTINE, _LINK );
X insert_sys( "$ldesc", ROUTINE, _LDESC );
X insert_sys( "$sdesc", ROUTINE, _SDESC );
X insert_sys( "$action", ROUTINE, _ACTION );
X insert_sys( "$prop", ROUTINE, _PROP );
X insert_sys( "$setp", ROUTINE, _SETP );
X insert_sys( "$move", ROUTINE, _MOVE );
X insert_sys( "$modif", ROUTINE, _MODIF );
X
X insert_sys( "$vset", ROUTINE, _VSET );
X insert_sys( "$vprop", ROUTINE, _VPROP );
X
X insert_sys( "$plus", ROUTINE, _PLUS );
X insert_sys( "$minus", ROUTINE, _MINUS );
X insert_sys( "$times", ROUTINE, _TIMES );
X insert_sys( "$div", ROUTINE, _DIV );
X insert_sys( "$mod", ROUTINE, _MOD );
X insert_sys( "$rand", ROUTINE, _RAND );
X
X insert_sys( "$and", ROUTINE, _AND );
X insert_sys( "$or", ROUTINE, _OR );
X insert_sys( "$not", ROUTINE, _NOT );
X insert_sys( "$yorn", ROUTINE, _YORN );
X insert_sys( "$pct", ROUTINE, _PCT );
X insert_sys( "$eq", ROUTINE, _EQ );
X insert_sys( "$ne", ROUTINE, _NE );
X insert_sys( "$lt", ROUTINE, _LT );
X insert_sys( "$gt", ROUTINE, _GT );
X insert_sys( "$le", ROUTINE, _LE );
X insert_sys( "$ge", ROUTINE, _GE );
X
X insert_sys( "$say", ROUTINE, _SAY );
X insert_sys( "$arg", ROUTINE, _ARG );
X insert_sys( "$exit", ROUTINE, _EXIT );
X insert_sys( "$return", ROUTINE, _RETURN );
X insert_sys( "$val", ROUTINE, _VAL );
X insert_sys( "$phase", ROUTINE, _PHASE );
X insert_sys( "$spec", ROUTINE, _SPEC );
X
X insert_sys( "$setg", ROUTINE, _SETG );
X insert_sys( "$global", ROUTINE, _GLOBAL );
X insert_sys( "$verb", ROUTINE, _VERB );
X insert_sys( "$dobj", ROUTINE, _DOBJ );
X insert_sys( "$iobj", ROUTINE, _IOBJ );
X insert_sys( "$prep", ROUTINE, _PREP );
X insert_sys( "$conj", ROUTINE, _CONJ );
X insert_sys( "$numd", ROUTINE, _NUMD );
X
X insert_sys( "$setv", ROUTINE, _SETV );
X insert_sys( "$hit", ROUTINE, _HIT );
X insert_sys( "$miss", ROUTINE, _MISS );
X
X insert_sys( "$eqst", ROUTINE, _EQST );
X insert_sys( "$subs", ROUTINE, _SUBS );
X insert_sys( "$leng", ROUTINE, _LENG );
X insert_sys( "$cat", ROUTINE, _CAT );
X insert_sys( "$pos", ROUTINE, _POS );
X insert_sys( "$chr", ROUTINE, _CHR );
X insert_sys( "$ord", ROUTINE, _ORD );
X insert_sys( "$read", ROUTINE, _READ );
X insert_sys( "$savestr", ROUTINE, _SAVESTR );
X insert_sys( "$name", ROUTINE, _NAME );
X insert_sys( "$vname", ROUTINE, _VNAME );
X insert_sys( "$mname", ROUTINE, _MNAME );
X insert_sys( "$pname", ROUTINE, _PNAME );
X insert_sys( "$define", ROUTINE, _DEFINE );
X insert_sys( "$undef", ROUTINE, _UNDEF );
X insert_sys( "$str", ROUTINE, _STR );
X insert_sys( "$num", ROUTINE, _NUM );
X
X insert_sys( "$sdem", ROUTINE, _SDEM );
X insert_sys( "$ddem", ROUTINE, _DDEM );
X insert_sys( "$sfus", ROUTINE, _SFUS );
X insert_sys( "$dfus", ROUTINE, _DFUS );
X insert_sys( "$incturn", ROUTINE, _INCTURN );
X insert_sys( "$turns", ROUTINE, _TURNS );
X insert_sys( "$prompt", ROUTINE, _PROMPT );
X insert_sys( "$actor", ROUTINE, _ACTOR );
X insert_sys( "$delact", ROUTINE, _DELACT );
X}
X
X/*** EOF predef.c ***/
END_OF_adlcomp/predef.c
if test 4775 -ne `wc -c <adlcomp/predef.c`; then
echo shar: \"adlcomp/predef.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f adlcomp/routcomp.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"adlcomp/routcomp.c\"
else
echo shar: Extracting \"adlcomp/routcomp.c\" \(6801 characters\)
sed "s/^X//" >adlcomp/routcomp.c <<'END_OF_adlcomp/routcomp.c'
X /***************************************************************\
X * *
X * routcomp.c - routines to compile ADL routines. *
X * Copyright 1987 by Ross Cunniff. *
X * *
X \***************************************************************/
X
X#include <stdio.h>
X
X#include "adltypes.h"
X#include "adlprog.h"
X#include "builtins.h"
X#include "adldef.h"
X#include "adlcomp.h"
X
X
Xint16
X inrout; /* Are we inside a routine? */
Xextern int16
X filenum; /* Current file number */
X
Xint16 getargs(); /* Forward declaration for daisy chaining */
X
X
Xchar *UNDEC_ID = "Undeclared identifier\n";
X
X
X /***************************************************************\
X * *
X * getglob() - generate the instruction for the '@glob' *
X * construct. *
X * *
X \***************************************************************/
X
Xgetglob()
X{
X lexer();
X newcode( PUSH, _GLOBAL );
X if( t_type == VAR )
X newcode( PUSH, t_val );
X else if( t_type == LOCAL )
X newcode( PUSHLOCL, t_val );
X else if( t_type == ARGUMENT )
X newcode( PUSHARG, t_val );
X else if( t_type == UNDECLARED )
X error( UNDEC_ID );
X else
X error( "Illegal '@'.\n" );
X newcode( CALL, 2L );
X}
X
X
X /***************************************************************\
X * *
X * getpair() - generate code for the '[ mod noun ]' *
X * construct. *
X * *
X \***************************************************************/
X
Xgetpair()
X{
X int16
X getold();
X
X newcode( PUSH, getold( 0, 0 ) );
X lexer();
X if( t_type != ']' )
X _ERR_FIX( BRACKET_EXPECTED, ']' );
X}
X
X
X /***************************************************************\
X * *
X * getexpr( t_read ) - generates code for an ADL routine *
X * expression. t_read is 0 if a token has not already *
X * been read. *
X * *
X \***************************************************************/
X
Xgetexpr( t_read )
Xint16
X t_read;
X{
X if( !t_read )
X lexer();
X if( t_type == '(' )
X getform();
X else if( t_type == '@' )
X getglob();
X else if( t_type == '[' )
X getpair();
X else if( t_type == ARGUMENT )
X newcode( PUSHARG, t_val );
X else if( t_type == LOCAL )
X newcode( PUSHLOCL, t_val );
X else if( t_type == MYVAL )
X newcode( PUSHME, 0 );
X else if( t_type == NOUN) {
X if( (t_val = noun_exists( 0, t_val )) < 0 )
X error( ATTEMPT );
X else
X newcode( PUSH, t_val );
X }
X else if( (t_type >= MIN_LEGAL) && (t_type <= MAX_LEGAL) )
X newcode( PUSH, t_val );
X else if( t_type == UNDECLARED )
X error( UNDEC_ID );
X else
X error( ILLEGAL_SYMBOL );
X}
X
X
X /***************************************************************\
X * *
X * getform() - get a routine form such as *
X * (name arg arg...) *
X * or *
X * (IF expr THEN arg arg ... ELSEIF ......) *
X * or *
X * (WHILE expr DO arg arg ...) *
X * *
X \***************************************************************/
X
Xgetform()
X{
X int16
X t_save,
X getargs();
X
X lexer();
X if( t_type == IF )
X getif();
X else if( t_type == WHILE )
X getwhile();
X else {
X t_save = t_type;
X if( t_type == UNDECLARED )
X _ERR_FIX( UNDEC_ID, ')' ) /* Note - no semicolon! */
X else if( t_type == '(' )
X getform();
X else if( t_type == ARGUMENT )
X newcode( PUSHARG, t_val );
X else if( t_type == '@' )
X getglob();
X else
X newcode( PUSH, t_val );
X lexer();
X if( (t_save == '@') || (t_save == ROUTINE) ||
X (t_save == '(') || (t_save == ARGUMENT) )
X newcode( CALL, getargs() + 1 );
X else
X error( "Illegal function call.\n" );
X }
X}
X
X
X /***************************************************************\
X * *
X * getwhile() - generate code for the WHILE form. *
X * *
X \***************************************************************/
X
Xgetwhile()
X{
X address
X topaddr,
X breakaddr;
X
X topaddr = currcode(); /* Top of loop */
X getexpr( 0 ); /* Conditional */
X
X breakaddr = newcode( JMPZ, 0 ); /* If 0 then exit loop */
X newcode( POP, 0 ); /* Pop the condition code */
X
X lexer();
X if( t_type != DO )
X error( "'DO' expected in WHILE loop.\n" );
X
X getroutine( 0 );
X if( t_type != ')' )
X _ERR_FIX( RIGHT_EXPECTED, ')' );
X newcode( POP, 0 );
X newcode( JMP, topaddr );
X
X oldcode( breakaddr, JMPZ, currcode() ); /* Fix up the breakaddr */
X}
X
X
X /***************************************************************\
X * *
X * getif() - generate code for the IF...ELSEIF...ELSE form *
X * *
X \***************************************************************/
X
Xgetif()
X{
X address
X oldaddr,
X breakaddr;
X
X getexpr( 0 ); /* Get the conditional */
X oldaddr = newcode( JMPZ, 0 ); /* Save the cond. br. addr */
X
X lexer(); /* Read the THEN */
X if( t_type != THEN )
X error( "'THEN' expected.\n" );
X
X newcode( POP, 0 ); /* Pop the condition */
X getroutine( 0 ); /* Get the body of the IF */
X
X if( t_type == ')' ) {
X /* We're done reading the IF statement */
X oldcode( oldaddr, JMPZ, currcode() ); /* Fix up the IF jump */
X }
X
X else {
X /* There was an ELSE or ELSEIF somewhere */
X breakaddr = newcode( JMP, 0 ); /* Skip the ELSE or ELSEIF */
X oldcode( oldaddr, JMPZ, currcode() ); /* Fix up the IF jump */
X newcode( POP, 0 ); /* Pop the condition code */
X
X if( t_type == ELSEIF ) {
X /* This should be almost the same as an IF statement */
X getif(); /* Recursively read the ELSEIF...ELSE */
X oldcode( breakaddr, JMP, currcode() ); /* Fixup */
X }
X
X else if( t_type == ELSE ) {
X /* This is slightly different */
X getroutine( 0 ); /* Get the ELSE body */
X if( t_type != ')' )
X _ERR_FIX( RIGHT_EXPECTED, ')' );
X oldcode( breakaddr, JMP, currcode() ); /* Fixup */
X }
X
X else
X _ERR_FIX( ILLEGAL_SYMBOL, ')' );
X }
X}
X
X
X /***************************************************************\
X * *
X * getargs() - generate code for a list of arguments to *
X * a routine call. *
X * *
X \***************************************************************/
X
Xint16
Xgetargs()
X{
X int16
X temp = 0; /* Number of arguments found */
X
X while( 1 ) {
X if( t_type == ')' )
X /* We're done reading arguments */
X return temp;
X getexpr( 1 ); /* Get an argument */
X lexer(); /* Get the next token */
X temp++; /* Increment the number of args found */
X }
X}
X
X /***************************************************************\
X * *
X * getroutine( t_read ) - parse and generate code for *
X * an ADL routine. *
X * *
X \***************************************************************/
X
Xgetroutine( t_read )
Xint16
X t_read;
X{
X int16
X irsave;
X
X irsave = inrout;
X if( !inrout ) {
X inrout = 1;
X emit_file();
X }
X if( !t_read )
X lexer();
X while( t_type == '(' ) {
X getform();
X lexer();
X if( t_type == '(' )
X newcode( POP, 0 );
X }
X inrout = irsave;
X}
X
X/*** EOF routcomp.c ***/
END_OF_adlcomp/routcomp.c
if test 6801 -ne `wc -c <adlcomp/routcomp.c`; then
echo shar: \"adlcomp/routcomp.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f adlrun/adlrun.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"adlrun/adlrun.c\"
else
echo shar: Extracting \"adlrun/adlrun.c\" \(8493 characters\)
sed "s/^X//" >adlrun/adlrun.c <<'END_OF_adlrun/adlrun.c'
X#include <stdio.h>
X#include <fcntl.h>
X
X#include "adltypes.h"
X#include "adlprog.h"
X#include "adlrun.h"
X#include "adldef.h"
X#include "virtmem.h"
X#include "vstring.h"
X
Xstruct pagetab
X codetab;
Xstruct actrec
X actlist[ 10 ];
Xaddress
X ip;
Xint16
X stack[ STACKSIZE ],
X sp,
X bp,
X numact,
X curract,
X Verb,
X Prep,
X Iobj,
X Inoun,
X Imod,
X NumDobj,
X Conj[ NUMDO ],
X Dnoun[ NUMDO ],
X Dobj[ NUMDO ],
X Dmod[ NUMDO ],
X vecverb[ 10 ],
X demons[ 10 ],
X fuses[ 10 ],
X ftimes[ 10 ],
X f_actors[ 10 ],
X numd,
X numf,
X currturn,
X prompter,
X wordwrite,
X numsave,
X restarted,
X debug,
X header,
X#if AMIGA
X scrwidth = 70,
X#else
X scrwidth = 79,
X#endif
X numcol,
X Phase,
X /* The following 6 vars are not actually used in adlrun,
X but we need to define them for the loader. */
X NUM_VARS,
X NUM_ROUTS,
X NUM_OBJS,
X NUM_VERBS,
X NUM_PREP;
Xchar
X *inname = "adlcomp.out",
X *r_name = "\0",
X *USAGE = "Usage: adlrun [filename] [-d] [-h] [-r savefile]\n",
X *H_STR = "%-48sScore: %-4d Moves: %-4d\n",
X tempc[ 4096 ], /* Temporary strings */
X savec[ 1024 ]; /* "Permanent" strings */
Xint
X infile = -1;
XFILE
X#if MULTIPLEX
X *CURRTTY, /* Current output file */
X *SYSTTY, /* Default output file */
X#endif
X *wordfile = (FILE *)0,
X *scriptfile = (FILE *)0;
X
Xstruct exit_place
X exits[ 5 ];
X
X#if MSDOS
X extern char
X *getml();
X# define calloc( size, num ) getml( (long)(size * num) )
X#else
X extern char
X *calloc();
X#endif
X
X#define islegal(c) (c&&(c!=' ')&&(c!='\t')&&(c!='\n')&&(c!='-'))
X
X
Xmain( argc, argv )
Xint argc;
Xchar *argv[];
X{
X getadlargs( argc, argv );
X while( 1 )
X if( SET_EXIT( 4 ) == 0 )
X break;
X if( restarted )
X init( 0 );
X else
X init( 1 );
X driver();
X}
X
X
Xgetadlargs( argc, argv )
Xint
X argc;
Xchar
X *argv[];
X{
X int
X i;
X char
X *getnext();
X
X for( i = 1; i < argc; i++ ) {
X if( *argv[ i ] == '-' )
X switch( *++argv[ i ] ) {
X case 'd' :
X debug = 1;
X break;
X case 'h' :
X header = 1;
X break;
X case 'r' :
X r_name = getnext( &i, argv );
X break;
X default :
X fputs( USAGE, stderr );
X exit( -1 );
X }
X else if( !strcmp( inname, "adlcomp.out" ) )
X inname = argv[ i ];
X else {
X fputs( USAGE, stderr );
X exit( -1 );
X }
X }
X}
X
X
Xinit( first )
Xint16
X first;
X{
X int16
X me,
X *temp;
X
X if( first ) {
X insertkey( ",", COMMA, 0, 0 );
X insertkey( "and", CONJ, 0, 0 );
X insertkey( "but", CONJ, 1, 0 );
X insertkey( ".", SEP, 0, 0 );
X insertkey( "!", SEP, 0, 0 );
X insertkey( "?", SEP, 0, 0 );
X insertkey( "then", SEP, 0, 0 );
X
X SRAND( rand_seed() );
X if( (infile = open( inname, RB )) < 0 ) {
X fprintf( stderr, "Error opening file %s\n", inname );
X exit( -1 );
X }
X
X#if MULTIPLEX
X SYSTTY = fopen( "/dev/tty", "r+" );
X if( SYSTTY == (FILE *)0 ) {
X fprintf( stderr, "Unable to open output device.\n" );
X exit( -1 );
X }
X CURRTTY = SYSTTY;
X#endif
X
X head_setup();
X sayer( "ADL interpreter - Version 3.2 - June 7, 1987\n" );
X sayer( "Copyright 1985, 1986, 1987 by Ross Cunniff\n" );
X sayer( "All rights reserved.\n" );
X
X /* Read in the input file */
X lseek( infile, 0L, 0 );
X read( infile, &hdr, sizeof( struct header ) );
X if( hdr.magic != M_ADL ) {
X fprintf( stderr, "%s: Not an ADL datafile.\n", inname );
X head_term();
X exit( -1 );
X }
X
X /* Read the arrays */
X
X read_symtab( infile, &hdr.symindex );
X loadarray( (char **)&routspace, &hdr.routindex, 1 );
X loadarray( (char **)&str_tab, &hdr.strtabindex, 1 );
X loadarray( (char **)&prepspace, &hdr.prepindex, 1 );
X loadarray( (char **)&verbsyn, &hdr.vsindex, 1 );
X loadarray( (char **)&nounspace, &hdr.nounindex, 1 );
X
X /* Initialize virtual code and string stuff */
X vsinit( infile, hdr.strindex.ptr, 1, tempc, savec, &numsave, str_tab );
X vm_init( infile, hdr.codeindex.ptr, &codetab );
X
X } /* if( first ) */
X
X temp = stack;
X loadarray( (char **)&temp, &hdr.varindex, 0 );
X loadarray( (char **)&verbspace, &hdr.verbindex, first );
X loadarray( (char **)&objspace, &hdr.objindex, first );
X
X if( scriptfile != (FILE *)0 ) {
X fclose( scriptfile );
X scriptfile = (FILE *)0;
X }
X
X if( wordwrite )
X fclose( wordfile );
X
X /* Initialize some variables (This is for ($spec 2) -> restart) */
X sp = bp = NUMVAR;
X ip = curract = numd = numf = 0;
X wordwrite = numsave = prompter = currturn = 0;
X
X actlist[ 0 ].linebuf = actlist[ 0 ].savebuf;
X *actlist[ 0 ].linebuf = '\0';
X actlist[ 0 ].interact = 1;
X numact = 0;
X
X clearmacro();
X
X if( *r_name ) {
X restoregame( r_name );
X r_name = "\0";
X }
X else
X callone( _START );
X
X restarted = 0;
X}
X
X
Xdriver()
X{
X int
X i;
X
X /* Outermost adlrun loop (never exited except to quit adlrun) */
X while( 1 ) {
X
X vsflush(); /* Clear out the temporary strings */
X curract = 0;
X
X /* Daemon loop */
X for( curract = numact - 1; curract >= 0; curract-- ) {
X#if MULTIPLEX
X if( actrec[ curract ].ttyfile == (FILE *)0 )
X CURRTTY = SYSTTY;
X else
X CURRTTY = actrec[ curract ].ttyfile;
X#endif
X Phase = 0;
X if( SET_EXIT( 1 ) == 0 ) {
X if( SET_EXIT( 0 ) == 0 )
X execdems();
X }
X }
X CLR_EXIT( 0 );
X
X /* Main actor loop */
X for( curract = numact - 1; curract >= 0; curract-- ) {
X#if MULTIPLEX
X if( actlist[ curract ].ttyfile == (FILE *)0 )
X CURRTTY = SYSTTY;
X else
X CURRTTY = actlist[ curract ].ttyfile;
X#endif
X
X if( SET_EXIT( 1 ) != 0 )
X continue;
X
X /* Delete actor if not interactive and line buffer is empty */
X if( (*PSTRING == 0) && (INTERACT == 0) ) {
X delactor( CURRACT );
X continue; /* with for loop */
X }
X
X /* Read and parse the user's input */
X initvars();
X while( 1 )
X if( SET_EXIT( 3 ) == 0 )
X break;
X if( get_buffer() < 0 )
X continue;
X
X /* Call the appropriate routines */
X callrouts();
X
X CLR_EXIT( 3 );
X } /* for( curract ... ) */
X } /* outer while( 1 ) */
X}
X
X
Xchar *
Xgetnext( which, argv )
Xint
X *which;
Xchar
X *argv[];
X{
X if( *++argv[ *which ] )
X return argv[ *which ];
X else
X return argv[ ++*which ];
X}
X
X
Xrand_seed()
X{
X long
X time();
X
X SRAND( (int)time( (long *)0 ) );
X}
X
Xsayer( s )
Xchar
X *s;
X{
X char
X word[ 80 ];
X
X while( *s ) {
X getchunk( &s, word );
X if( *word == '\n' ) {
X crlf();
X continue;
X }
X else if( (numcol + strlen( word )) > scrwidth ) {
X while( *word == ' ' ) /* Eat up blanks */
X getchunk( &s, word );
X if( !*word ) {
X fflush( stdout );
X return; /* The string was blank terminated */
X }
X crlf();
X }
X numcol += strlen( word );
X#if MULTIPLEX
X fputs( word, CURRTTY );
X fflush( CURRTTY );
X#else
X fputs( word, stdout );
X fflush( stdout );
X#endif
X if( scriptfile != (FILE *)0 )
X fputs( word, scriptfile );
X }
X#if MULTIPLEX
X fflush( CURRTTY );
X#else
X fflush( stdout );
X#endif
X}
X
X
X/* VARARGS */
Xloadarray( a, d, first )
Xchar
X **a;
Xstruct adldir
X *d;
Xint16
X first;
X{
X if( first && (d->numobjs * d->objsize) ) {
X *a = calloc( d->numobjs, d->objsize );
X if( *a == (char *)0 )
X error( 27 ); /* Out of memory */
X }
X lseek( infile, d->ptr, 0 );
X read( infile, *a, d->numobjs * d->objsize );
X}
X
X
Xgetchunk( s, word )
Xchar
X **s,
X *word;
X{
X if( !**s ) {
X *word = '\0';
X return;
X }
X if( islegal( **s ) )
X while( islegal( **s ) )
X *word++ = *((*s)++);
X else if( **s == '\t' ) { /* Expand the tab */
X strcpy( word, " " );
X word[ 8 - (numcol % 8) ] = '\0';
X (*s)++;
X return;
X }
X else
X *word++ = *((*s)++);
X *word = '\0';
X}
X
X
Xcrlf()
X{
X#if MULTIPLEX
X putc( '\n', CURRTTY );
X#else
X putchar( '\n' );
X#endif
X if( scriptfile != (FILE *)0 )
X putc( '\n', scriptfile );
X numcol = 0;
X}
X
X
Xget_buffer()
X{
X /* Loop for user input */
X while( 1 ) {
X
X /* Get a non-empty line */
X if( !*PSTRING ) {
X PSTRING = &SAVEBUF[ 0 ];
X u_prompt();
X getstring( PSTRING );
X }
X
X /* Parse the string */
X if( !parse() ) {
X *PSTRING = '\0';
X initvars(); /* Failed parse; init the variables */
X if( INTERACT )
X continue; /* with While (interactive actor, try again) */
X else {
X delactor( CURRACT );
X return -1; /* from While (the actor needs to die) */
X }
X }
X else
X break; /* The parse was successful */
X }
X return 0;
X}
X
X
Xint16
Xnoun_exists( adj, noun )
Xint16
X adj, noun;
X{
X int16
X t;
X
X for( t = nounspace[ noun ]; t != 0; t = objspace[ t ].others )
X if( objspace[ t ].adj == adj )
X return t;
X return -1;
X}
X
X/*** EOF adlrun.c ***/
END_OF_adlrun/adlrun.c
if test 8493 -ne `wc -c <adlrun/adlrun.c`; then
echo shar: \"adlrun/adlrun.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f adlrun/adlspec.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"adlrun/adlspec.c\"
else
echo shar: Extracting \"adlrun/adlspec.c\" \(8484 characters\)
sed "s/^X//" >adlrun/adlspec.c <<'END_OF_adlrun/adlspec.c'
X#include <stdio.h>
X#include <fcntl.h>
X
X#include "adltypes.h"
X#include "adlprog.h"
X#include "builtins.h"
X#include "vstring.h"
X#include "adlrun.h"
X
X
Xextern
Xchar *H_STR;
X
X
Xspecial()
X{
X int16
X t;
X
X assertargs( "$spec", 1 ); /* Have to have at least ($spec F) */
X switch( ARG( 1 ) ) {
X case 1 :
X debug = !debug;
X break;
X case 2 :
X restart();
X /* NOTREACHED */
X case 3 :
X head_term();
X exit( 0 ); /* terminate game */
X case 4 :
X assertargs( "$spec 4", 2 );
X savegame( virtstr( ARG( 2 ) ) );
X break;
X case 5 :
X assertargs( "$spec 5", 2 );
X if( restoregame( virtstr( ARG( 2 ) ) ) )
X return; /* Skip the fixup stuff */
X break;
X case 6 :
X callextern();
X break;
X case 7 :
X do_wordfile();
X break;
X case 8 :
X scripter();
X break;
X case 9 :
X write_head();
X break;
X case 10 :
X assertargs( "$spec 10", 2 );
X scrwidth = ARG( 2 );
X break;
X case 11 :
X set_tty();
X break;
X case 12 :
X change_tty();
X break;
X default :
X error( 24 ); /* Illegal parameter for $spec */
X }
X popip();
X t = pop();
X sp = bp + 1;
X bp = t;
X}
X
Xrestart()
X{
X int
X i;
X
X#if MULTIPLEX
X for( i = 0; i < numact; i++ ) {
X if( actlist[ i ].ttyfile != (FILE *)0 ) {
X /* Close the tty */
X fclose( actlist[ i ].ttyfile );
X *actlist[ i ].ttyname = '\0';
X }
X }
X#endif
X restarted = 1;
X DO_EXIT( 4 );
X}
X
X
Xset_tty()
X{
X#if MULTIPLEX
X int
X i;
X
X /* Set the actor's TTY */
X assertargs( "$spec 11", 3 );
X if( (ARG( 1 ) < 0) || (ARG( 1 ) > NUMOBJ) )
X error( 31 ); /* Illegal actor for $spec 11 */
X for( i = 0; i < numact; i++ ) {
X if( actlist[ i ].actor == ARG( 1 ) ) {
X /* We found the actor */
X if( actlist[ i ].ttyfile != (FILE *)0 )
X /* Close the old tty */
X fclose( actlist[ i ].ttyfile );
X actlist[ i ].ttyfile = fopen( virstr( ARG( 2 ) ), "r+" );
X if( actlist[ i ].ttyfile == (FILE *)0 )
X error( 32 ); /* Bad tty name */
X strcpy( actlist[ i ].ttyname, virtstr( ARG( 2 ) ) );
X return;
X }
X }
X error( 31 ); /* Illegal actor for $spec 11 */
X#endif
X}
X
X
Xchange_tty()
X{
X#if MULTIPLEX
X int
X i;
X
X /* Set the current TTY */
X assertargs( "$spec 12", 2 );
X if( (ARG( 1 ) < 0) || (ARG( 1 ) > NUMOBJ) )
X error( 33 ); /* Illegal actor for $spec 11 */
X for( i = 0; i < numact; i++ ) {
X if( actlist[ i ].actor == ARG( 1 ) ) {
X /* We found the actor */
X if( actlist[ i ].ttyfile == (FILE *)0 )
X CURRTTY = SYSTTY;
X else
X CURRTTY = actlist[ i ].ttyfile;
X return;
X }
X }
X error( 33 ); /* Illegal actor for $spec 12 */
X#endif
X}
X
X
Xinvert( s, n )
Xchar
X *s;
Xint16
X n;
X{
X int16
X i;
X
X for( i = 0; i < n; i++ )
X s[ i ] ^= CODE_CHAR;
X}
X
X
Xsavegame( savename )
Xchar
X *savename;
X{
X int
X savefile,
X cmask;
X char
X tempstr[ 80 ];
X int16
X yesno(),
X temp,
X i;
X struct macro
X *m;
X
X RETVAL = 0;
X savefile = open( savename, RB );
X if( savefile >= 0 ) {
X close( savefile );
X sayer( "File " );
X sayer( savename );
X sayer( " already exists. Destroy it? " );
X if( !yesno() )
X return;
X }
X savefile = open( savename, WB );
X if( savefile < 0 ) {
X sayer( "Error opening file " );
X sayer( savename );
X sayer( "\n" );
X return;
X }
X invert( savec, numsave );
X for( i = 0; i < numact; i++ ) {
X strcpy( tempstr, actlist[ i ].linebuf );
X strcpy( actlist[ i ].savebuf, tempstr );
X actlist[ i ].linebuf = actlist[ i ].savebuf;
X }
X temp = nummacro();
X write( savefile, &hdr.adlid, sizeof( int32 ) );
X write( savefile, &numsave, sizeof( int16 ) );
X write( savefile, savec, numsave );
X write( savefile, &numact, sizeof( int16 ) );
X write( savefile, actlist, numact * sizeof( struct actrec ) );
X write( savefile, vecverb, 10 * sizeof( int16 ) );
X write( savefile, &currturn, sizeof( int16 ) );
X write( savefile, &prompter, sizeof( int16 ) );
X write( savefile, &numd, sizeof( int16 ) );
X write( savefile, demons, 10 * sizeof( int16 ) );
X write( savefile, &numf, sizeof( int16 ) );
X write( savefile, fuses, 10 * sizeof( int16 ) );
X write( savefile, ftimes, 10 * sizeof( int16 ) );
X write( savefile, f_actors, 10 * sizeof( int16 ) );
X write( savefile, objspace, NUMOBJ * sizeof( struct objrec ) );
X write( savefile, verbspace, NUMVERB * sizeof( struct verbrec ) );
X write( savefile, stack, NUMVAR * sizeof( int16 ) );
X write( savefile, &temp, sizeof( int16 ) );
X for( m = mactab; m; m = m->next ) {
X invert( m->name, 10 );
X invert( m->val, 80 );
X write( savefile, m->name, 10 );
X write( savefile, m->val, 80 );
X invert( m->name, 10 );
X invert( m->val, 80 );
X }
X close( savefile );
X#if UNIX
X cmask = umask( 0 );
X (void)umask( cmask );
X chmod( savename, 0666 & ~cmask );
X#endif
X invert( savec, numsave );
X RETVAL = 1;
X}
X
X
Xrestoregame( savename )
Xchar
X *savename;
X{
X int
X savefile;
X char
X mname[ 10 ],
X mval[ 80 ];
X int32
X tempid;
X int16
X num,
X i;
X
X savefile = open( savename, RB );
X if( savefile < 0 ) {
X sayer( "Error opening file " );
X sayer( savename );
X sayer( "\n" );
X return 0;
X }
X read( savefile, &tempid, sizeof( int32 ) );
X if( tempid != hdr.adlid ) {
X sayer( "Error: \"" );
X sayer( savename );
X sayer( "\" is not a save file for this game.\n" );
X return 0;
X }
X#if MULTIPLEX
X for( i = 0; i < numact; i++ )
X if( actlist[ i ].ttyfile != (FILE *)0 )
X /* Close the tty */
X fclose( actlist[ i ].ttyfile );
X#endif
X read( savefile, &numsave, sizeof( int16 ) );
X read( savefile, savec, numsave );
X read( savefile, &numact, sizeof( int16 ) );
X read( savefile, actlist, numact * sizeof( struct actrec ) );
X read( savefile, vecverb, 10 * sizeof( int16 ) );
X read( savefile, &currturn, sizeof( int16 ) );
X read( savefile, &prompter, sizeof( int16 ) );
X read( savefile, &numd, sizeof( int16 ) );
X read( savefile, demons, 10 * sizeof( int16 ) );
X read( savefile, &numf, sizeof( int16 ) );
X read( savefile, fuses, 10 * sizeof( int16 ) );
X read( savefile, ftimes, 10 * sizeof( int16 ) );
X read( savefile, f_actors, 10 * sizeof( int16 ) );
X read( savefile, objspace, NUMOBJ * sizeof( struct objrec ) );
X read( savefile, verbspace, NUMVERB * sizeof( struct verbrec ) );
X read( savefile, stack, NUMVAR * sizeof( int16 ) );
X read( savefile, &num, sizeof( int16 ) );
X clearmacro();
X for( i = 0; i < num; i++ ) {
X read( savefile, mname, 10 );
X read( savefile, mval, 80 );
X invert( mname, 10 );
X invert( mval, 80 );
X define( mname, mval );
X }
X close( savefile );
X
X /* Fix up the actlist string pointers, which may have changed since
X the file was saved. */
X for( i = 0; i < numact; i++ )
X actlist[ i ].linebuf = actlist[ i ].savebuf;
X
X /* Decode the saved character buffer */
X invert( savec, numsave );
X
X#if MULTIPLEX
X /* Reopen the actor tty's */
X for( i = 0; i < numact; i++ )
X if( actlist[ i ].ttyfile != (FILE *)0 )
X actlist[ i ].ttyfile = fopen( actlist[ i ].ttyname, "r+" );
X#endif
X
X /* It was a successful restore, so stop running */
X ip = 0L;
X bp = sp = NUMVAR;
X return 1;
X}
X
X
Xdo_wordfile()
X{
X assertargs( "$spec 7", 2 );
X if( wordwrite )
X fclose( wordfile );
X wordwrite = 0;
X if( ARG( 2 ) ) {
X wordwrite = 1;
X wordfile = fopen( virtstr( ARG( 2 ) ), "a" );
X }
X}
X
X
Xcallextern()
X{
X#if UNIX
X int
X i;
X char
X **argv,
X *t;
X
X /* Have to have at least ($spec 6 "name" 0) */
X assertargs( "$spec 6", 3 );
X if( fork() )
X /* We're the parent - wait for the child to die */
X RETVAL = wait( 0 );
X else {
X /* We're the child. Get memory for the argument vector */
X argv = (char **)malloc( (RETVAL - 1) * sizeof( char * ) );
X if( argv == (char **)0 )
X error( 27 ); /* Out of memory */
X
X /* Fill the argument vectors */
X for( i = 2; i < RETVAL && ARG( i ); i++ ) {
X t = virtstr( ARG( i ) );
X argv[ i - 2 ] = malloc( strlen( t ) + 1 );
X if( argv[ i - 2 ] == (char *)0 )
X error( 27 ); /* Out of memory */
X
X strcpy( argv[ i - 2 ], t );
X }
X
X /* Set the last argument to be zero */
X argv[ RETVAL - 2 ] = (char *)0;
X
X /* Execute the program */
X execv( argv[ 0 ], argv );
X
X /* In case the exec failed, exit. */
X head_term();
X exit( -1 );
X }
X#endif
X}
X
X
X
Xscripter()
X{
X assertargs( "$spec 8", 2 );
X if( scriptfile != (FILE *)0 )
X fclose( scriptfile );
X scriptfile = (FILE *)0;
X if( ARG( 2 ) )
X scriptfile = fopen( virtstr( ARG( 2 ) ), "w" );
X}
X
X/*** EOF adlspec.c ***/
END_OF_adlrun/adlspec.c
if test 8484 -ne `wc -c <adlrun/adlspec.c`; then
echo shar: \"adlrun/adlspec.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f adlrun/rtlex.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"adlrun/rtlex.c\"
else
echo shar: Extracting \"adlrun/rtlex.c\" \(6842 characters\)
sed "s/^X//" >adlrun/rtlex.c <<'END_OF_adlrun/rtlex.c'
X#include <ctype.h>
X#include <stdio.h>
X
X#include "adltypes.h"
X#include "adlprog.h"
X#include "vstring.h"
X#include "adldef.h"
X#include "adlrun.h"
X
X#define MAXDEPTH 20 /* Maximum nesting of macros */
X
Xint16
X t_type, /* Current token type */
X t_val, /* Current token value */
X read_t; /* Instruction to lexer to read another token */
Xchar
X *s, /* Save area for current token */
X *xp; /* Expansion of s */
X
X
X /***************************************************************\
X * *
X * gettoken() - Read the first token from PSTRING, macro *
X * expand it, and place the type and value of the token *
X * in t_type and t_val, respectively. The actual token *
X * is located in the external string s. On an error, *
X * t_type will contain one of the following values: *
X * -1 : unknown word *
X * -2 : ambiguous abbreviation *
X * -3 : invalid macro expansion *
X * *
X \***************************************************************/
X
Xgettoken()
X{
X int
X depth, /* Depth of the macro expansion */
X success; /* Did the token expand? */
X
X
X /* Check to see whether we want to read a new token */
X if( !read_t ) {
X read_t = 1;
X return;
X }
X
X for( depth = 0; depth < MAXDEPTH; depth++ ) {
X /* Get the first token from the string */
X if( lexer() )
X return; /* The lexer fully handled the token */
X
X /* Process the token. */
X if( !*s ) {
X /* The string was empty, so return SEP (separator) */
X t_type = SEP;
X t_val = 0;
X return;
X }
X else {
X success = try_expand();
X if( success < 0 ) {
X /* An error occured during expansion */
X t_type = -3; /* Invalid macro expansion */
X t_val = 0;
X return;
X }
X else if( success == 0 ) {
X /* The token WASN'T a macro, so process it and return. */
X if( numberp( s ) ) {
X /* The token was a number. Coerce it into a string */
X t_type = STRING;
X t_val = newtstr( s );
X }
X else {
X /* The token was an identifier. Look it up. */
X t_type = lookup( s, &t_val, 1 );
X if( t_type < 0 && wordwrite )
X /* Write the token to the unknown words file */
X fprintf( wordfile, "%s\n", s );
X }
X return; /* Don't try to further expand this token */
X }
X }
X }
X /* If we get here, we expanded the thing MAXDEPTH times. */
X t_type = -3; /* Invalid macro expansion */
X}
X
X/* */
X
X /***************************************************************\
X * *
X * lexer() - read the first token from PSTRING. Returns *
X * 1 if the token is a quoted string, 0 otherwise. *
X * *
X \***************************************************************/
X
Xlexer()
X{
X int
X count = 0; /* Number of chars in the token */
X char
X c, /* Current char in the token */
X *t; /* Holding place for the beginning of the token */
X
X eatwhite(); /* Delete leading whitespace */
X t = s; /* Save the starting address. */
X
X if( *PSTRING ) {
X /* There are indeed non-blank characters in the string */
X
X if( !adlchr( *PSTRING ) ) {
X /* The current character can't appear in an identifier */
X
X if( (*PSTRING == '"') || (*PSTRING == '\'') ) {
X /* We need to (recursively) find a quoted string */
X getquotes( *PSTRING++ );
X *(--s) = '\0'; /* Destroy closing quote */
X s = t;
X t_val = newtstr( s );
X t_type = STRING;
X
X /* Return the fact that we handled everything */
X return 1;
X }
X else
X /* The current character is simply punctuation */
X *s++ = *PSTRING++;
X }
X
X else {
X /* The current character is the first of an identifier */
X
X while( adlchr( c = *PSTRING++ ) ) {
X /* Read the characters into s (iff there is room in s) */
X if( SLEN > ++count ) {
X if( isupper( c ) )
X *s++ = tolower( c );
X else
X *s++ = c;
X }
X }
X PSTRING--; /* Put back the last character. */
X }
X }
X *s = '\0'; /* Null terminate the string */
X s = t; /* Point to the beginning of the token */
X return 0; /* Further processing is required. */
X}
X
X/* */
X
X /***************************************************************\
X * *
X * try_expand() - attempt to expand the current token. *
X * Returns 1 if the token expands, 0 if the token doesn't *
X * expand, and -1 if expanding the token would overflow *
X * the string. *
X * *
X \***************************************************************/
X
Xtry_expand()
X{
X char
X tsave[ SLEN ]; /* Save area for concatenation */
X
X xp = expand( s );
X if( strcmp( xp, s ) != 0 ) {
X /* The token was a macro - put it in the right place */
X
X if( (strlen( xp ) + strlen( PSTRING )) > (SLEN - 1) ) {
X /* Macro expansion overflow - not enough room */
X return -1; /* error */
X }
X else {
X /* PSTRING := concat( xp, PSTRING ) */
X
X strcpy( tsave, PSTRING );
X PSTRING = actlist[ curract ].savebuf;
X strcpy( PSTRING, xp );
X strcat( PSTRING, tsave );
X return 1; /* successful expansion */
X }
X }
X else
X return 0; /* It didn't expand */
X}
X
X/* */
X
X /***************************************************************\
X * *
X * numberp( s ) - returns 1 if s is a valid signed *
X * integer, 0 otherwise. *
X * *
X \***************************************************************/
X
Xnumberp( s )
Xchar
X *s;
X{
X if( *s == '-' ) {
X /* Preceding minus sign */
X s++;
X if( !*s ) {
X /* Just a minus sign is NOT a number */
X return 0;
X }
X }
X while( *s ) {
X if( !isdigit( *s ) )
X return 0;
X else
X s++;
X }
X return 1;
X}
X
X
X /***************************************************************\
X * *
X * getquotes( ch ) - Get a quoted string delimited by ch *
X * from PSTRING. Nesting of strings is allowed, e.g.: *
X * *
X * 'The string "foobar 'bletch'" is legal.' *
X * *
X * Note that the trailing quote is optional. If the *
X * trailing quote is absent, the end of the string is *
X * delimited by the end of the line. *
X * *
X \***************************************************************/
X
Xgetquotes( ch )
Xint16
X ch;
X{
X while( (*PSTRING) && (*PSTRING != ch) ) {
X *s++ = *PSTRING;
X if( (*PSTRING == '\"') || (*PSTRING == '\'') )
X getquotes( *PSTRING++ );
X else
X PSTRING++;
X }
X *s++ = ch;
X if( *PSTRING )
X PSTRING++; /* Eat up closing quote */
X}
X
X
X /***************************************************************\
X * *
X * eatwhite() - Removes leading blanks from PSTRING. *
X * *
X \***************************************************************/
X
Xeatwhite()
X{
X while( (*PSTRING == ' ') || (*PSTRING == '\t') )
X PSTRING++;
X}
X
X
X
X /***************************************************************\
X * *
X * adlchr( c ) - returns 1 if c is a valid character in an *
X * ADL identifier, 0 otherwise. *
X * *
X \***************************************************************/
X
Xadlchr( c )
Xint c;
X{
X return isalnum(c) || (c == '-');
X}
X
X/*** EOF rtlex.c ***/
END_OF_adlrun/rtlex.c
if test 6842 -ne `wc -c <adlrun/rtlex.c`; then
echo shar: \"adlrun/rtlex.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f samples/aard/objects.adl -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"samples/aard/objects.adl\"
else
echo shar: Extracting \"samples/aard/objects.adl\" \(7768 characters\)
sed "s/^X//" >samples/aard/objects.adl <<'END_OF_samples/aard/objects.adl'
X{*** OBJECTS ***}
X
XNOUN pen(mrm2);
Xpen(weight) = 1;
Xpen(LDESC) = ($say "There is a ball-point pen here.\n");
Xpen(SDESC) = ($say "a ball-point pen");
X
XNOUN paper(mrm2);
Xrelease = paper;
Xform = paper;
Xpaper(weight) = 1;
Xpaper(LDESC) =
X (IF ($eq ($prop paper readl) 0) THEN
X ($say "There is a slip of paper here.\n")
X ELSE
X ($say "There is a release form here.\n")
X )
X;
Xpaper(SDESC) =
X (IF ($eq ($prop paper readl) 0) THEN
X ($say "a slip of paper")
X ELSE
X ($say "a release form")
X )
X;
X
X
XNOUN spices(irm6);
Xspices(weight) = 3;
Xspices(LDESC) = ($say "There is a bag of spices here.\n");
Xspices(SDESC) = ($say "spices");
Xspices(rarea) = 1;
Xspices(pfound) = 5;
Xspices(pplace) = 9;
X
XNOUN rupees(irm7);
Xcoins=rupees;
Xrupees(weight) = 5;
Xrupees(LDESC) = ($say "There is a bag of rupees (Indian coins) here.\n");
Xrupees(SDESC) = ($say "rupees (coins)");
Xrupees(rarea) = 1;
Xrupees(pfound) = 5;
Xrupees(pplace) = 15;
X
XNOUN coconut(irm3);
Xcoconut(weight) = 3;
Xcoconut(LDESC) = ($say "There is a large coconut here.\n");
Xcoconut(SDESC) = ($say "a coconut");
X
XNOUN rope(mrm1);
Xrope(weight) = 3;
Xrldesc =
X (IF ($prop rope ropstf) THEN
X ($say
X"There is a long piece of rope here, magically
X rising up in mid-air.\n"
X )
X ELSE
X ($say "There is a coil of rope here.\n")
X )
X;
Xrsdesc =
X ($say "a rope")
X;
Xrope(LDESC) = rldesc;
Xrope(SDESC) = rsdesc;
X
XNOUN clarinet(irm2);
Xclarinet(weight) = 2;
Xclarinet(LDESC) = ($say "There is a clarinet here.\n");
Xclarinet(SDESC) = ($say "clarinet");
X
XNOUN cobra(irm22);
Xcobra(NOTAKE) = TRUE;
Xcobra(LDESC) = ($say "There is a king cobra at the bottom of the pit.\n");
Xcobra(SDESC) = ($say "a cobra");
Xsnake = cobra;
Xelapid = cobra;
X
XNOUN river;
Xriver(NOTAKE) = TRUE;
X
XNOUN statue;
Xstatue(NOTAKE) = TRUE;
X
XNOUN banana(irm3);
Xbanana(weight) = 2;
Xbanana(LDESC) = ($say "There is a banana here.\n");
Xbanana(SDESC) = ($say "a banana");
X
XNOUN peel;
Xpeel(weight) = 1;
Xpeel(LDESC) = ($say "On the ground, there is a banana peel.\n");
Xpeel(SDESC) = ($say "a banana peel");
X
XNOUN vishnu(irm11);
Xvishnu(NOTAKE) = TRUE;
X
XNOUN mara(irm10);
Xmara(NOTAKE) = TRUE;
X
XNOUN lakshmi(irm12);
Xlakshmi(NOTAKE) = TRUE;
X
XNOUN crocodile;
Xcrocodile(NOTAKE) = TRUE;
X
XNOUN rhino(irm13);
Xrhino(NOTAKE) = TRUE;
Xrhino(LDESC) =
X (IF ($prop rhino cutflg) THEN
X ($say "There is a rhino sleeping here with his horn removed.\n")
X ELSE
X ($say "There is a rhinoceros sleeping in the corner.\n")
X )
X (IF ($prop rhino earplg) THEN
X ($say " There are two pieces of cotton stuck in his ears.\n")
X )
X;
Xrhino(SDESC) = ($say "a sleeping rhino");
X
XNOUN saw(irm2);
Xsaw(weight) = 2;
Xsaw(LDESC) = ($say "There is a hack-saw on the ground.\n");
Xsaw(SDESC) = ($say "a hack-saw");
Xhacksaw = saw;
Xhack-saw = saw;
X
XNOUN horn(irm13);
Xhorn(weight) = 2;
Xhorn(NOTAKE) = TRUE;
Xhorn(LDESC) =
X (IF ($prop rhino cutflg) THEN
X ($say "There is a rhinoceros horn here.\n")
X )
X;
Xhorn(SDESC) =
X (IF ($prop rhino cutflg) THEN
X ($say "a rhino horn")
X )
X;
Xhorn(rarea) = 1;
Xhorn(pfound) = 14;
Xhorn(pplace) = 7;
X
XNOUN cotton;
Xcotton(weight) = 1;
Xcotton(LDESC) = ($say "There is a large wad of cotton on the ground.\n");
Xcotton(SDESC) = ($say "a wad of cotton");
X
XNOUN lattice(irm13);
Xlattice(NOTAKE) = TRUE;
X
XNOUN monkey(irm20);
Xmonkey(NOTAKE) = TRUE;
Xmonkey(LDESC) = ($say "There is a sacred temple monkey here.\n");
Xmonkey(SDESC) = ($say "a monkey");
X
XNOUN tandoor(irm4);
Xoven = tandoor;
Xtandoor(NOTAKE) = TRUE;
X
XNOUN comb(irm14);
Xcomb(weight) = 1;
Xcomb(LDESC) = ($say "There is an expertly carved jade comb here.\n");
Xcomb(SDESC) = ($say "a jade comb");
Xcomb(rarea) = 1;
Xcomb(pfound) = 7;
Xcomb(pplace) = 6;
X
XNOUN ruby(irm17);
Xruby(weight) = 2;
Xruby(LDESC) = ($say "There is a crimson ruby here.\n");
Xruby(SDESC) = ($say "a ruby");
Xruby(rarea) = 1;
Xruby(pfound) = 8;
Xruby(pplace) = 7;
X
XNOUN bowl(irm21);
Xbowl(weight) = 3;
Xbowl(LDESC) = ($say "There is a crystal bowl here.\n");
Xbowl(SDESC) = ($say "a bowl");
Xbowl(rarea) = 1;
Xbowl(pfound) = 10;
Xbowl(pplace) = 10;
X
XNOUN bracelet(irm23);
Xbracelet(weight) = 1;
Xbracelet(LDESC) =
X ($say "There is a golden bracelet in the shape of a snake here.\n")
X;
Xbracelet(SDESC) = ($say "a bracelet");
Xbracelet(rarea) = 1;
Xbracelet(pfound) = 11;
Xbracelet(pplace) = 6;
X
XNOUN shovel(mrm1);
Xshovel(weight) = 3;
Xshovel(LDESC) = ($say "There is a shovel here.\n");
Xshovel(SDESC) = ($say "a shovel");
X
XNOUN ears(irm13);
Xears(NOTAKE) = TRUE;
X
XNOUN pole(prm2);
Xpole(NOTAKE) = TRUE;
X
XNOUN amber(prm3);
Xamber(weight) = 2;
Xamber(LDESC) = ($say "There is a polished piece of amber here.\n");
Xamber(SDESC) = ($say "a piece of amber");
Xamber(rarea) = 2;
Xamber(pfound) = 12;
Xamber(pplace) = 6;
X
XNOUN lamp(mrm1);
Xlamp(weight) = 3;
Xlamp(LDESC) = ($say "There is a carbide-flame lamp here.\n");
Xlamp(SDESC) = ($say "a lamp");
X
XNOUN grate(mrm5);
Xgrate(NOTAKE) = TRUE;
X
XNOUN nugget;
Xgold = nugget;
Xnugget(weight) = 4;
Xnugget(LDESC) = ($say "There is a gold nugget lying on the ground.\n");
Xnugget(SDESC) = ($say "a gold nugget");
Xnugget(rarea) = 2;
Xnugget(pfound) = 13;
Xnugget(pplace) = 7;
X
XNOUN axe(prm1);
Xaxe(weight) = 1;
Xaxe(LDESC) = ($say "There is an stone-age axe here.\n");
Xaxe(SDESC) = ($say "an axe");
X
XNOUN spear(prm17);
Xspear(weight) = 2;
Xspear(LDESC) =
X (IF ($prop spear tooky) THEN
X ($say "There is a Neanderthal hunting spear here.\n")
X ELSE
X ($say "There is a Neanderthal hunting spear stuck in the ground.\n")
X )
X;
Xspear(SDESC) = ($say "a spear");
X
XNOUN plant(prm2);
Xplant(weight) = 4;
Xplant(LDESC) = ($say "There is a strange looking potted plant here.\n");
Xplant(SDESC) = ($say "a plant");
X
XNOUN smilodon(prm6); {Putty tat}
Xsmilo = smilodon;
Xsabre = smilodon;
Xsmilodon(NOTAKE) = TRUE;
X
XNOUN troglodyte(prm8);
Xtrogl = troglodyte;
Xtroglodyte(NOTAKE) = TRUE;
X
XNOUN cheese(prm4);
Xcheese(weight) = 1;
Xcheese(LDESC) =
X ($say "There's a piece of Swiss cheese (aged 1,000,000 years) here.\n")
X;
Xcheese(SDESC) = ($say "a piece of cheese");
X
XNOUN towel(prm4);
Xtowel(weight) = 2;
Xtowel(LDESC) = ($say "There is an old towel here.\n");
Xtowel(SDESC) = ($say "a towel");
X
XNOUN mammoth(prm14);
Xmammoth(LDESC) =
X ($say "There is a large wooly mammoth blocking the path to the south.\n")
X;
Xmammoth(SDESC) = ($say "a mammoth");
Xelephant = mammoth;
Xpachyderm = mammoth;
X
XNOUN feet;
Xfeet(NOTAKE) = TRUE;
X
XNOUN diamond(prm12);
Xdiamond(weight) = 1;
Xdiamond(LDESC) = ($say "There is a small diamond here.\n");
Xdiamond(SDESC) = ($say "a diamond");
Xdiamond(rarea) = 2;
Xdiamond(pfound) = 7;
Xdiamond(pplace) = 8;
X
XNOUN ivory(prm15);
Xivory(weight) = 2;
Xivory(LDESC) = ($say "There is a piece of ivory here.\n");
Xivory(SDESC) = ($say "a piece of ivory");
Xivory(rarea) = 2;
Xivory(pfound) = 9;
Xivory(pplace) = 8;
X
XNOUN pendant;
Xpendant(weight) = 2;
Xpendant(LDESC) = ($say "There is a ancient pendant here.\n");
Xpendant(SDESC) = ($say "a pendant");
Xpendant(rarea) = 2;
Xpendant(pfound) = 14;
Xpendant(pplace) = 4;
X
XNOUN cairn(prm18);
Xskulls = cairn;
Xcairn(NOTAKE) = TRUE;
X
XNOUN bear(prm19);
Xbear(NOTAKE) = TRUE;
Xbear(LDESC) =
X ($say "There is a ferocious cave bear blocking your path to the north.\n")
X;
Xbear(SDESC) = ($say "a cave bear");
X
XNOUN necklace(prm20);
Xnecklace(weight) = 1;
Xnecklace(LDESC) = ($say "There is a pearl necklace here.\n");
Xnecklace(SDESC) = ($say "a necklace");
Xnecklace(rarea) = 2;
Xnecklace(pfound) = 13;
Xnecklace(pplace) = 6;
X
XNOUN tyranosaur(prm22);
Xtyranosaur(NOTAKE) = TRUE;
X
XNOUN ring(prm23);
Xring(weight) = 1;
Xring(LDESC) = ($say "There is a large diamond ring here.\n");
Xring(SDESC) = ($say "a ring");
Xring(rarea) = 2;
Xring(pfound) = 13;
Xring(pplace) = 10;
X
XNOUN hole;
Xhole(NOTAKE) = TRUE;
X
XNOUN newspaper(mrm1);
Xnewspaper(weight) = 1;
Xnewspaper(LDESC) = ($say "There is a copy of a newspaper here.\n");
Xnewspaper(SDESC) = ($say "a newspaper");
X
XNOUN crack;
Xcrack(NOTAKE) = TRUE;
XNOUN shaft;
Xshaft(NOTAKE) = TRUE;
END_OF_samples/aard/objects.adl
if test 7768 -ne `wc -c <samples/aard/objects.adl`; then
echo shar: \"samples/aard/objects.adl\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 8 \(of 11\).
cp /dev/null ark8isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 11 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
echo Making adl.doc
(cd man; cat doc.aa doc.ab doc.ac >adl.doc; rm doc.a[a-c])
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0