Trailing-Edge
-
PDP-10 Archives
-
tops10and20_integ_tools_v9_3-aug-86
-
tools/crc/ind/v1ind.mac
There are no other files named v1ind.mac in the archive.
;<KEVIN>INDOLD.MAC.2, 5-Feb-82 11:56:32, EDIT BY KEVIN
;<KEVIN>IND.MAC.244, 3-Feb-82 14:10:29, EDIT BY KEVIN
;<KEVIN>IND.MAC.243, 3-Feb-82 14:02:42, EDIT BY KEVIN
; Add conditional to record everyone who uses the file in a file in
; <KEVIN>.
;<KEVIN>IND.MAC.242, 29-Jan-82 16:50:32, EDIT BY KEVIN
; Add extra forms of relational operators such as <>
;<KEVIN>IND.MAC.241, 15-Jan-82 17:25:53, EDIT BY KEVIN
;<KEVIN>IND.MAC.240, 15-Jan-82 17:15:38, EDIT BY KEVIN
; Make CRCMD an internal routine so that we can use JSYS trapping on
; the subsidiary EXEC.
;<KEVIN>IND.MAC.239, 30-Nov-81 15:30:10, EDIT BY KEVIN
; Tell TESTFILE about invisible and offline files.
;<KEVIN>IND.MAC.238, 26-Nov-81 11:46:05, EDIT BY KEVIN
;<KEVIN>IND.MAC.236, 26-Nov-81 10:35:42, EDIT BY KEVIN
; Add .OPENA, teach NUMEXP about system symbols
;<KEVIN>IND.MAC.235, 26-Nov-81 10:15:13, EDIT BY KEVIN
; Teach .IF about system symbols as test variables (.IF <USER> eq "me")
;<KEVIN>IND.MAC.234, 26-Nov-81 10:02:57, EDIT BY KEVIN
; Didn't document LUKSYS correctly
;<KEVIN>IND.MAC.232, 25-Nov-81 17:07:21, EDIT BY KEVIN
; Allow system symbols in string expressions
;<KEVIN>IND.MAC.231, 22-Nov-81 14:04:46, EDIT BY KEVIN
; End-of-file code was forgetting to test file nesting depth
;<KEVIN>IND.MAC.230, 22-Nov-81 13:57:47, EDIT BY KEVIN
; .CALL was not saving new nesting level
;<KEVIN>IND.MAC.229, 22-Nov-81 13:43:29, EDIT BY KEVIN
; Forgot to add .CALL to command table
;<KEVIN>IND.MAC.227, 22-Nov-81 13:20:09, EDIT BY KEVIN
; Label testing was still being attempted in DATA mode - reverse order of
; tests
;<KEVIN>IND.MAC.226, 22-Nov-81 12:50:02, EDIT BY KEVIN
; XCREF AC symbols ; add .DISPLAY directive (probably not supported) ; add
; .DELAY directive ; add .ENABLE/.DISABLE QUIET/EXTENDED-EXEC
;<KEVIN>IND.MAC.225, 19-Nov-81 17:40:10, EDIT BY KEVIN
; Suppress RELOP symbols from DDT
;<KEVIN>IND.MAC.224, 19-Nov-81 17:27:44, EDIT BY KEVIN
; Add .CALL directive
;<KEVIN>IND.MAC.223, 19-Nov-81 17:06:00, EDIT BY KEVIN
; Make ISDGT recognise "-" as part of a number
;<KEVIN>IND.MAC.222, 19-Nov-81 16:45:57, EDIT BY KEVIN
; Forgot to supply storage for FILERR
;<KEVIN>IND.MAC.221, 19-Nov-81 16:43:21, EDIT BY KEVIN
; Add .TESTFILE directive, and special symbol <FILESTAT>
;<KEVIN>IND.MAC.220, 19-Nov-81 13:57:48, EDIT BY KEVIN
; Add .TEST directive, and special symbol <STRLEN>
;<KEVIN>IND.MAC.218, 19-Nov-81 13:33:17, EDIT BY KEVIN
; Don't use TX type macros when you haven't got an immediate value!
;<KEVIN>IND.MAC.216, 19-Nov-81 13:23:27, EDIT BY KEVIN
; RFCOC was having acs trashed by TXO
;<KEVIN>IND.MAC.214, 19-Nov-81 13:14:56, EDIT BY KEVIN
; Add .ENABLE ESCAPE for escape sequences
;<KEVIN>IND.MAC.212, 19-Nov-81 12:01:43, EDIT BY KEVIN
; Add .INC/.DEC for numeric symbols
; Make IND bomb out on command parse errors
;<KEVIN>IND.MAC.211, 18-Nov-81 19:34:23, EDIT BY KEVIN
; Unusual terminator in ENTVAL
;<KEVIN>IND.MAC.209, 18-Nov-81 19:02:15, EDIT BY KEVIN
; String expression parser failed on null strings
;<KEVIN>IND.MAC.208, 18-Nov-81 18:50:07, EDIT BY KEVIN
; String expression parser failed on symbols without ranges
;<KEVIN>IND.MAC.207, 18-Nov-81 17:50:04, EDIT BY KEVIN
; Rework way DATA mode works - set up flag for "pure" command, or
; one that has been rewritten.
;<KEVIN>IND.MAC.206, 18-Nov-81 17:39:07, EDIT BY KEVIN
; Source and destination designators wrong way round in WDATA
;<KEVIN>IND.MAC.205, 18-Nov-81 17:27:56, EDIT BY KEVIN
; Use extend sign ops for GETAB stuff
;<KEVIN>IND.MAC.203, 18-Nov-81 17:23:23, EDIT BY KEVIN
; Add ENABLE/DISABLE DATA directives
;<KEVIN>IND.MAC.201, 18-Nov-81 16:27:16, EDIT BY KEVIN
; Processor for system name forgot ERCAL after GETAB
;<KEVIN>IND.MAC.200, 18-Nov-81 16:19:02, EDIT BY KEVIN
; LUKSYS was not returning symbol type codes correctly
;<KEVIN>IND.MAC.198, 18-Nov-81 15:28:30, EDIT BY KEVIN
; Must use indexing and inirection with subroutine dispatch in LUKSYS
;<KEVIN>IND.MAC.197, 18-Nov-81 15:23:35, EDIT BY KEVIN
; Typeo in LUKSYS
;<KEVIN>IND.MAC.196, 18-Nov-81 15:14:18, EDIT BY KEVIN
; Teach substitution about system symbols
;<KEVIN>IND.MAC.195, 18-Nov-81 14:53:03, EDIT BY KEVIN
; CRCMD has now sorted out problems with PUSH, so we can now use
; the PAUSE command
;<KEVIN>IND.MAC.194, 18-Nov-81 10:25:05, EDIT BY KEVIN
; Correct typeos in system symbol table
;<KEVIN>IND.MAC.191, 18-Nov-81 10:17:42, EDIT BY KEVIN
; Add support routines for system symbols
;<KEVIN>IND.MAC.190, 18-Nov-81 09:57:37, EDIT BY KEVIN
; Add system symbol table
;<KEVIN>IND.MAC.188, 17-Nov-81 19:47:39, EDIT BY KEVIN
; Open brackets improperly handled in numeric parser
;<KEVIN>IND.MAC.187, 17-Nov-81 19:32:14, EDIT BY KEVIN
; Ranges was not remebering to save its acs
;<KEVIN>IND.MAC.185, 17-Nov-81 18:00:49, EDIT BY KEVIN
; Move definition of storage, etc. to separate file (indsym.unv).
; This allows IND to be generated by itself!
;<KEVIN>IND.MAC.183, 17-Nov-81 17:42:33, EDIT BY KEVIN
; STREXP was not handling multiple quoted strings correctly
;<KEVIN>IND.MAC.181, 17-Nov-81 17:32:45, EDIT BY KEVIN
; Testing wrong ac after STCMP
;<KEVIN>IND.MAC.179, 17-Nov-81 16:55:32, EDIT BY KEVIN
; problems with macro used to generate RELOP table
;<KEVIN>IND.MAC.176, 17-Nov-81 16:22:48, EDIT BY KEVIN
; Make garbage collector keep statistics on usage
;<KEVIN>IND.MAC.173, 17-Nov-81 15:26:45, EDIT BY KEVIN
; Macro doesn't like ~ signs
;<KEVIN>IND.MAC.172, 17-Nov-81 15:06:09, EDIT BY KEVIN
; Add .IF directive, for testing relational operations between strings or
; numbers.
;<KEVIN>IND.MAC.171, 16-Nov-81 17:45:07, EDIT BY KEVIN
; Stop .ASKS raising terminal input, add .STOP directive
;<KEVIN>IND.MAC.170, 16-Nov-81 17:35:10, EDIT BY KEVIN
; .RETURN was not decrementing nesting level
;<KEVIN>IND.MAC.168, 16-Nov-81 17:11:05, EDIT BY KEVIN
; Forward labels not being processed correctly
;<KEVIN>IND.MAC.166, 16-Nov-81 16:40:14, EDIT BY KEVIN
; Bug in label processing
;<KEVIN>IND.MAC.164, 16-Nov-81 16:18:33, EDIT BY KEVIN
; Implement .ASKS
;<KEVIN>IND.MAC.163, 16-Nov-81 15:21:17, EDIT BY KEVIN
; Add IND comments (.; command). Add .GOSUB, .RETURN
;<KEVIN>IND.MAC.162, 16-Nov-81 14:37:49, EDIT BY KEVIN
; Keyword table out of order
;<KEVIN>IND.MAC.159, 16-Nov-81 14:14:43, EDIT BY KEVIN
; Implement .ASKF, improve .ASK
;<KEVIN>IND.MAC.158, 16-Nov-81 13:27:38, EDIT BY KEVIN
; Wrong acs in .DATA command
;<KEVIN>IND.MAC.157, 16-Nov-81 13:18:48, EDIT BY KEVIN
; STATUS was not displaying negative numbers correctly
;<KEVIN>IND.MAC.156, 16-Nov-81 11:48:23, EDIT BY KEVIN
; Add .SETFI (set file symbol)
;<KEVIN>IND.MAC.154, 16-Nov-81 11:36:24, EDIT BY KEVIN
; Add ENTFIL LUKFIL
; Make substitution recognise file symbols. Fix bug in luknum - was
; not returning negative values with full sign (use HRRE not HRRZ)
;<KEVIN>IND.MAC.153, 16-Nov-81 10:14:49, EDIT BY KEVIN
; Add garbage collector for string storage, add .OPEN, .CLOSE, .DATA
; improve entering routines for symbol tables to check for existence of
; symbol (like ENTSTR does.)
;<KEVIN>IND.MAC.152, 13-Nov-81 18:25:39, EDIT BY KEVIN
; LUKNUM was not returning table positions
;<KEVIN>IND.MAC.151, 13-Nov-81 18:18:47, EDIT BY KEVIN
; Logic of below edit was inversed from desired action
;<KEVIN>IND.MAC.147, 13-Nov-81 18:05:06, EDIT BY KEVIN
; Modify ENTLAB to ignore request if label is already in table
;<KEVIN>IND.MAC.146, 13-Nov-81 17:56:15, EDIT BY KEVIN
;<KEVIN>IND.MAC.143, 13-Nov-81 16:45:41, EDIT BY KEVIN
;<KEVIN>IND.MAC.142, 13-Nov-81 14:27:30, EDIT BY KEVIN
;<KEVIN>IND.MAC.140, 12-Nov-81 11:07:11, EDIT BY KEVIN
;<KEVIN>IND.MAC.137, 11-Nov-81 16:24:45, EDIT BY KEVIN
; Start on .GOTO logica - command is not added yet, but we must put
; checks into the parser for adding labels to the table, and checks to
; ensure no commands are executed while a target is being searched for.
;<KEVIN>IND.MAC.132, 11-Nov-81 13:21:47, EDIT BY KEVIN
; Add file symbol table, planned for inclusion from start. Stores JFNS
; for later use. Improve ENTSTR so that it copes whether or not the symbol
; is defined. This will be the only ENTER-type routine which does this,
; and is useful 'cos strings are so difficult.
;<KEVIN>IND.MAC.129, 11-Nov-81 11:31:11, EDIT BY KEVIN
;<KEVIN>IND.MAC.128, 10-Nov-81 19:51:24, EDIT BY KEVIN
; Beef up STATUS command to print out all symbols and values
;<KEVIN>IND.MAC.117, 10-Nov-81 19:05:49, EDIT BY KEVIN
; Make ASKx directives use ranges.
;<KEVIN>IND.MAC.113, 10-Nov-81 18:35:49, EDIT BY KEVIN
; Fix problem with range parsing
;<KEVIN>IND.MAC.108, 10-Nov-81 17:35:38, EDIT BY KEVIN
; String parser
;<KEVIN>IND.MAC.107, 10-Nov-81 16:48:40, EDIT BY KEVIN
; Remove .PAUSE command due to bug in $CRCMD
;<KEVIN>IND.MAC.105, 10-Nov-81 11:27:15, EDIT BY KEVIN
;<KEVIN>IND.MAC.102, 10-Nov-81 10:34:27, EDIT BY KEVIN
; Add .PAUSE command, to PUSH to lower EXEC
;<KEVIN>IND.MAC.99, 10-Nov-81 10:00:54, EDIT BY KEVIN
;<KEVIN>IND.MAC.95, 10-Nov-81 09:22:58, EDIT BY KEVIN
;<KEVIN>IND.MAC.92, 9-Nov-81 16:51:07, EDIT BY KEVIN
;<KEVIN>IND.MAC.91, 9-Nov-81 15:00:15, EDIT BY KEVIN
; Bung in the work I did this weekend - notably the string and numeric
; expression parsers, in all their glory (or lack of it.) Also resolve
; problem whereby use of GETWRD was inconsistent, meaning that it could
; not backspace its byte pointer. Make GETWRD allow $, < and > as valid
; characters in a symbol.
; Add range parsing routine, for use in string expressions and .ASKx
; directives. Uses NUMEXP to parse general numeric expressions for the
; ranges.
;<KEVIN>IND.MAC.85, 7-Nov-81 18:19:15, EDIT BY KEVIN
; Add .IFDF/.IFNDF - if symbol defined or not defined
;<KEVIN>IND.MAC.82, 7-Nov-81 17:37:27, EDIT BY KEVIN
; Add .ASKN - ask for numeric symbol
;<KEVIN>IND.MAC.79, 7-Nov-81 17:16:34, EDIT BY KEVIN
; Add first few .ENABLE/.DISABLE commands
;<KEVIN>IND.MAC.78, 7-Nov-81 16:56:18, EDIT BY KEVIN
; Make substitution use numeric symbols as well
;<KEVIN>IND.MAC.74, 7-Nov-81 16:13:15, EDIT BY KEVIN
; Add .SETN
;<KEVIN>IND.MAC.72, 7-Nov-81 16:01:36, EDIT BY KEVIN
; ENTSTR was not counting string lengths properly
; Problem was implicit byte pointers where real ones were required
;<KEVIN>IND.MAC.71, 7-Nov-81 15:54:07, EDIT BY KEVIN
; Substitution was losing cr/lf from end of line
;<KEVIN>IND.MAC.70, 7-Nov-81 15:44:58, EDIT BY KEVIN
; LUKSTR was not returning correct byte pointers
;<KEVIN>IND.MAC.68, 7-Nov-81 15:23:01, EDIT BY KEVIN
;<KEVIN>IND.MAC.64, 7-Nov-81 14:58:55, EDIT BY KEVIN
; Add seperate reenter - REENTER performs no rescan
;<KEVIN>IND.MAC.61, 6-Nov-81 17:32:37, EDIT BY KEVIN
; Add substitution routines
;<KEVIN>IND.MAC.58, 6-Nov-81 16:32:10, EDIT BY KEVIN
; Add .STATUS command to print symbol table usage, etc.
;<KEVIN>IND.MAC.56, 6-Nov-81 16:08:44, EDIT BY KEVIN
;<KEVIN>IND.MAC.55, 6-Nov-81 15:43:44, EDIT BY KEVIN
; Add the .SETS command, in preparation for text substitution
;<KEVIN>IND.MAC.53, 6-Nov-81 15:14:44, EDIT BY KEVIN
; Modify GETWRD to return on no-alphabetic, and reset byte pointer.
; Also write ENTSTR - to enter a string symbol.
;<KEVIN>IND.MAC.51, 6-Nov-81 14:59:09, EDIT BY KEVIN
; .ASKx routines don't really want all the line terminator guff.
;<KEVIN>IND.MAC.47, 6-Nov-81 14:27:36, EDIT BY KEVIN
; Add LUKSTR to lookup string symbols so that the .ASKx routines can
; verify their symbol types.
;<KEVIN>IND.MAC.44, 6-Nov-81 14:15:02, EDIT BY KEVIN
;<KEVIN>IND.MAC.42, 5-Nov-81 17:52:14, EDIT BY KEVIN
; Add .ASK
;<KEVIN>IND.MAC.37, 5-Nov-81 17:21:31, EDIT BY KEVIN
; Add beginnings of .IFT, .IFF to test the logical ops
;<KEVIN>IND.MAC.33, 5-Nov-81 16:58:04, EDIT BY KEVIN
; Add .SETT/.SETF
;<KEVIN>IND.MAC.32, 5-Nov-81 16:11:33, EDIT BY KEVIN
; But clear out the buffers when we do it
;<KEVIN>IND.MAC.26, 5-Nov-81 14:55:56, EDIT BY KEVIN
; Add command line rescanning so we can @IND filename
;<KEVIN>IND.MAC.24, 5-Nov-81 14:22:32, EDIT BY KEVIN
;<KEVIN>IND.MAC.21, 5-Nov-81 14:07:37, EDIT BY KEVIN
;<KEVIN>IND.MAC.19, 4-Nov-81 18:03:05, EDIT BY KEVIN
; Start adding symbol table lookup/insertion/maintenance routines
;<KEVIN>IND.MAC.16, 4-Nov-81 15:03:18, EDIT BY KEVIN
; Also, REV and similar programs check the private program name and match
; it against the recsan buffer - must set program name.
;<KEVIN>IND.MAC.14, 4-Nov-81 10:25:22, EDIT BY KEVIN
; Alter way in which .RUN command works to load the rescan buffer properly
; Apparently, if you say RUN SYS:REV.EXE *.rel, the rescan buffer must
; only contain REV *.rel .
;<KEVIN>IND.MAC.10, 3-Nov-81 16:40:08, EDIT BY KEVIN
; Add .RUN command
;<KEVIN>IND.MAC.4, 3-Nov-81 13:56:20, EDIT BY KEVIN
;<KEVIN>IND.MAC.3, 3-Nov-81 13:52:09, EDIT BY KEVIN
;<KEVIN>IND.MAC.2, 3-Nov-81 13:48:47, EDIT BY KEVIN
;<KEVIN>IND.MAC.1, 3-Nov-81 12:02:26, EDIT BY KEVIN
title IND - performs similar function to RSX IND
subttl Edit history
subttl Definitions and impure storage
;
; This program reads command files of a similar format to those
; used under RSX, which allow question/answer stuff to go on, and also
; symbol substitution and all that good stuff. Running programs via the
; EXEC may present problems, so we may need to use a .RUN directive
; rather than the EXEC RUN. We'll see....
;
search vtmac,indsym
regdef
.request k:ersub ;request subroutine libraries
external errmes,error ;for these routines
.XCREF T1,T2,T3,T4 ;don't cross-reference ac symbols
cexit.==:12345
logg==0 ;log users one a file
m$exec==1 ;mexec bit for CRCMD
f$reez==4 ;freeze but for CRCMD
e$cho==2 ;echo bit for CRCMD
p$ush==8 ;PUSH bit for CRCMD
c$cmd==20 ;COMAND.CMD bit
lf==12 ;linefeed
true==0 ;logical truth
false==^-0 ;falsity (not 0)
esc==33 ;escape
ctrlz==^d26 ;control z
cr==15 ;carriage return
quote==42 ; " character
addop==1 ;for numeric parser
subop==2 ; : :
mulop==3 ; : :
divop==4 ; : :
;
; Bit definitions for relational operators - if a bit is set, then that
; condition means success for that operator. IE if the operator is le,
; then equals or less than both mean success.
;
$eq==1 ;equals condition
$lt==2 ;less than
$gt==4 ;greater than
eq==$eq ;only equals for equals
ne==$lt+$gt ;ne means less than or greater than
ge==$gt+$eq
gt==$gt
lt==$lt
le==$lt+$eq
$num==0 ;symbol type codes
$str==1
$fil==3
$lgc==4
calstk: block mxcal ;IND .CALL stack
substk: block mxcnst ;subroutine stack
numstK: block numsl ;numeric parse stack
stack: block slen
scrlen==^d30 ;30 words for scratch strings
scratch: block scrlen
;
; Storage for CRCMD
;
efork: 0 ;fork handle if f$REEZ is set
waspsh: 0 ;says we were pushed last time, so
;we must use SFORK
cmdwrd: 0 ;saved JFN mode word from COMND
cmdcc1: 0 ;saved CCOC words from COMND
cmdcc2: 0 ;"" ""
sysnm: 0 ;our SIXBIT name
;
; End of CRCMD storage
;
relop: 0 ;operator in .IF statement
ifval: 0 ;value of symbol in .IF directive
iftyp: 0 ;type of symbol : :
comjfn: 0 ;jfn of command file
linlen: 0 ;length of line read by GETLIN
purcmd: 0 ;-1 if this command is a rewrite from .IF
gonst: 0 ;subroutine nesting depth
calnst: 0 ;command procedure nesting depth
comptr: 0 ;pointer to remainder of command string for IND commands
datjfn: 0 ;JFN of open data file
prgjfn: 0 ;JFN of program mapped by .RUN
runnam: 0 ;SIXBIT program name
prgnam: 0 ;SIXBIT name of inferior
lgcflg: 0 ;value of next logical symbol to be entered
escflg: 0 ;-1 if escape was used to answer question
defflg: 0 ;-1 if last question was defualted
extflg: $ctrlz ;-1 if ctrl/z exits are prohibited
sbtflg: $$subst ;-1 if substitution is not allowed
dspflg: $disp ;if non-zero, display IND commands
datflg: 0 ;-1 if ENABLE DATA in process
datsav: 0 ;copy of above, behind by one line
sqzd: 0 ;non zero if garbage collector has been called
nsqzd: 0 ;number of tiems garbage collector has been called
ifdtyp: 0 ;flags .IFDF/.IFNDF
fnd: 0 ;flags if symbol found for above
edtyp: 0 ;-1 when .DISABLing, 0 if .ENABLing
nval: 0 ;second operand of numexp
numptr: 0 ;stored pointer parsing expressions
numnst: 0 ;nesting level of numeric expression
cnval: 0 ;holds current value of expression when parsing
cnop: 0 ; " " operator " "
cbyt: 0 ;starting byte number of current line
going: 0 ;non-zero if searching for a label
strlen: 0 ;length of string from .ASKS or .TEST directive
filerr: 0 ;status of last .TESTFILE directive
excflg: f$reez+c$cmd+e$cho ;flags for EXEC routine
target: block 3 ;name of target label in search
vals: block 3 ;values returned when parsing ranges
asksym: block 3 ;space for ASKx symbol
subsym: block ^d10 ;space for substitution symbol
setsym: block 5 ;space for SET symbol
ifsym: block 3 ;space for .IF symbol
agjargs: gj%fou+gj%msg+gj%cfm+gj%xtn ;for .ASKF - extended block, messages, confirm
.priin,,.priou ;input,,output
0
0
0
0
0
0
0
3 ;number of words in extended block
0
0
0 ;pointer to ctrl/r buffer
cgjargs: gj%old ;old files for command input
.nulio,,.nulio ;read from rescan buffer
0
0
0
deftyp
0
0
0
gjargs: gj%old ;old files
.nulio,,.nulio ;inout, output jfns
0 ;default device
0 ;default directory
0 ;defualt name
-1,,[asciz/exe/] ;default type
0 ;protections
0 ;account
0 ;JFN
comlin: block maxcom
comcop: block maxcom
asklin: block asklen
askans: block mslen ;space for answer
sublin: block maxcom ;space for substitution of text
wrkstr: block maxcom ;space for working out string expressions
sysval: block mslen ;value of system symbols
;
; Macro to adjust a byte pointer by a variable. Uses CX as scratch
;
define adjptr(ptr,bytes),<
move cx,bytes ;;number of bytes to bump by
adjbp cx,ptr
movem cx,ptr>
;
; macro to backspace byte pointer 1 byte
;
define bkptr (ptr),<
setom cx ;backspace 1
adjbp cx,ptr
movem cx,ptr>
;
; This is the collection of symbol tables for the various questions.
; There are four impure tables - for string symbols (STRSYM), numeric
; symbols (NUMSYM), logical symbols (LGCSYM) and file symbols (FILSYM).
; There should also be
; two pure tables, the command table (COMSYM) and the permanent symbol
; table (SYSSYM).
;
;
; space for storage of strings
;
nxtbyt: 0 ;next byte to be written into strings
strings: block strspc/5
strcpy: block strspc/5 ;copt of above for garbage collection
;
;space for text storage of symbol names
;
free: strsiz+numsiz+lgcsiz+labsiz+filsiz ;number of free entries left
nxtsym: 0 ;offset to place next symbol name at
symtab:block <strsiz+numsiz+lgcsiz+labsiz+filsiz>*<maxchr+1>/5
numsym: 0,,numsiz ;max entries in table of numeric symbols
block numsiz ;table storage
strsym: 0,,strsiz
block strsiz
filsym: 0,,filsiz
block filsiz
lgcsym: 0,,lgcsiz
block lgcsiz
labsym: 0,,labsiz
block labsiz
subttl Pure storage - command tables, etc.
;
; These are the pure tables of commands and permanent symbols
;
define key$(comand,imp<noimp>),<
$comsz==$comsz+1
IFIDN <IMP> <imp>,< [asciz/comand/],,.'comand>
ifidn <imp> <noimp>,< [asciz/comand/],,[tmsg <
%Can't .'comand yet...>
retskp]>>
define syk$(keyword,ktype,routine,%type1),<
%type1=-1
ifidn <ktype> <string>,<%type1=$str>
ifidn <ktype> <numeric>,<%type1=$num>
ifidn <ktype> <logical>,<%type1=$lgc>
ifidn <ktype> <file>,<%type1=$fil>
ifl %type1 <printx ?Unrecognised system symbol type:'%type1>
sysiz$=sysiz$+1
[asciz/<'keyword'>/],,[%type1,,routine]
.xcref %type1
purge %type1>
$comsz==0
comsym: comsiz,,comsiz ;number of entries in table
key$ ask,imp ;yes/no routine
key$ askf,imp ;file question
key$ askn,imp ;numeric question
key$ asks,imp ;string question
key$ call,imp ;call another file
key$ close,imp ;close data file
key$ data,imp ;send line to data file
key$ dec,imp ;decrement symbol
key$ delay,imp ;delay for n seconds
$$disab:key$ disable,imp ;disable function
key$ display,imp ;display string symbol as is (screens)
key$ enable,imp ;enable function
key$ gosub,imp ;.GOTO with .RETURN
key$ goto,imp ;goto function
key$ if,imp ;if sym relop 'expr' command
key$ ifdf,imp ;if defined....
key$ iff,imp ;if false....
key$ ifndf,imp ;if not defined....
key$ ift,imp ;if true....
key$ inc,imp ;increment symbol
key$ open,imp ;open data file
key$ opena,imp ;open data file for append
key$ pause,imp ;pause (push to subsid EXEC via $CRCMD)
key$ return,imp ;inverse of .GOSUB
key$ run,imp ;run program (instead of EXEC command)
key$ setf,imp ;set false
key$ setfi,imp ;set file
key$ setn,imp ;set numeric
key$ sets,imp ;set string
key$ sett,imp ;set true
key$ status,imp ;type status of symbol tables, etc.
key$ stop,imp ;STOP processing
key$ test,imp ;test string length
key$ testfile,imp ;test for file exists
comsiz==$comsz
purge $comsz
;
; table for yes/no
;
ysntab: 2,,2
[ASCIZ/NO/],,0
[asciz/YES/],,0
;
; Keywords for .ENABLE/.DISABLE, and the routines to do it
;
define enk$(word,code),<
[asciz/word/],,code
ensiz$==ensiz$+1>
ensiz$==0
edtab: ensiz,,ensiz ;number of entries in table
enk$ CONTROL-Z-EXITS,[move t1,edtyp
movem t1,extflg
ret]
..data: enk$ DATA,[move t1,edtyp ;get type of command
setcam t1,datflg ;setup flag
ret]
enk$ ESCAPE,[movei t1,.priou
rfcoc%
movx t1,1b19 ;flag escape o
movx t4,2b19 ;flag escape allowed
skipe edtyp ;enable ?
exch t1,t4 ;no
trz t3,(t1)
tro t3,(t4)
movei t1,.priou
sfcoc%
ret]
enk$ EXTENDED-EXEC,[move t1,excflgs ;get current flags
skipe edtyp ;enable ?
txza t1,m$exec ;no, zero and skip
txo t1,m$exec ;yes, set up
movem t1,excflgs ;restore flags
ret]
enk$ QUIET,[move t1,excflg ;get flags
skipe edtyp ;enable ?
txoa t1,e$cho ;no, echo back on
txz t1,e$cho ;yes, echo off
movem t1,excflgs ;restore
ret] ;to caller
enk$ SUBSTITUTION,[move t1,edtyp
movem t1,sbtflg
ret] ;return
enk$ TRACE,[ move t1,edtyp
setcam t1,dspflg
ret] ;trace of IND commands
ensiz==ensiz$
purge ensiz$
;
; keyword table for .IF directive
;
define relk$(relop,val),<
relsz$==relsz$+1
[asciz'relop],,val>
relsz$==0
reltab: relsz,,relsz ;size of table
relk$ "<",lt
relk$ "<=",le
relk$ "<>",ne
relk$ "=",eq
relk$ "=<",le
relk$ "=>",ge
relk$ ">",gt
relk$ "><",ne
relk$ ">=",ge
relk$ "eq",eq ;equals
relk$ "ge",ge
relk$ "gt",gt
relk$ "le",le
relk$ "lt",lt
relk$ "ne",ne
relk$ "~=",ne
relsz==relsz$
purge relsz$
;
; System symbol table
;
sysiz$==0
syssym: sysiz,,sysiz ;size of table
syk$ DATE,string,[movx t3,ot%ntm
jrst date.]
syk$ DIRECTORY,string,[gjinf% ;get dir number
hrroi t1,sysval
dirst%
ercal error
ret]
syk$ FILESTAT,numeric,[move t1,filerr ;result of .TESTFILE
movem t1,sysval
ret]
syk$ STRLEN,numeric,[move t1,strlen
movem t1,sysval
ret]
syk$ SYSTEM,string,sysnm. ;name of system
syk$ TIME,string,[movx t3,ot%nda
jrst date.]
syk$ USER,string,[gjinf% ;get user number
movem t1,t2 ;save
hrroi t1,sysval ;where to write it
dirst% ;write name
ercal error
ret]
sysiz==sysiz$
purge sysiz$
;
; dispatch table for numeric parser
;
optab: illvec ;illegal operator vector
nadd ;add
nsub
nmul
ndiv
;
; GTJFN argument block for TESTFILE
;
tsargs: gj%old+gj%xtn ;old files,extended arguments
.nulio,,.nulio ;inout, output jfns
0 ;default device
0 ;default directory
0 ;defualt name
0 ;default type
0 ;protections
0 ;account
0 ;JFN
g1%iin ;allow invisible files
entvec: jrst start
jrst reen
verno 1,A,243,3 ;Version number and author code - Kevin
subttl Main code
;
; Program starts here
;
reen: reset% ;on reenter, don't rescan
move p,[iowd slen,stack] ;set the stack
IFDEF LOGG, <call record>
jrst start1 ;read filename from terminal
start: reset% ;clear the world
move p,[iowd slen,stack] ;set the stack
IFDEF logg, <call record> ;log user
call gcom ;try and get command file name
start1: jrst [tmsg <
Command file name : >
movx t1,gj%cfm+gj%sht+gj%old+gj%fns ;olf file, name from terminal
move t2,[.priin,,.priou]
gtjfn%
ercal [call errmes
jrst start1]
jrst .+1] ;ok, got it from terminal
movem t1,comjfn ;remember command file JFN
movx t2,fld(7,of%bsz)+of%rd ;open for read with 7-bit bytes
openf% ;do so
ercal error ;crash
fillop: skipe datsav ;last line in DATA mode ?
call wdata ;yes, write to file if necessary
move t2,datflg ;get new copy of flag
movem t2,datsav ;and save it
call getlin ;read line, return +1 on eof
jrst eof ;no more to do
call substi ;perform substitution
jrst fillop ;failed for some reason
intfil: setom purcmd ;prevent copying from happening again
ildb t2,t1 ;get first byte using pointer in t1
cain t2,"." ;is it a dot ?
jrst [call parse ;yes, it is an IND command - parse it
jrst fillop] ;get next line
skipe going ;are we searchig for a target ?
jrst fillop ;yes, and we haven't found it yet
skipe datflg ;are we in DATA mode?
jrst fillop ;yes, just loop for more
cain t2,";" ;is it a comment ?
jrst [call coment ;yes, just output and continue
jrst fillop]
move t1,[point 7,comlin] ;nope, just an ordinary command - do it
move t2,linlen ;get linelength
subi t2,2 ;point before cr/lf
adjptr t1,t2 ;fiddle the byte pointer
setz t2, ;get a null
idpb t2,t1 ;and put ot over the cr/lf
move t1,[point 7,comlin] ;point to command
move t2,excflgs ;whatever flags are in use
call $crcmd ;execute command....
skipe t3 ;was there an error ?
jrst excerr ;no, an error from the exec - halt
jrst fillop ;no error - get next line
subttl Parsing of IND commands
;
; This routine parses the first part of IND commands, and does
; dispatch processing. A byte pointer is in t1.
; It also stores label values if they are present in the command line,
; then rewrites the command and redispatches.
;
parse: ildb t2,t1 ;get next byte
cain t2,";" ;comment start ?
ret ;do no more
bkptr t1 ;backspace
move t2,[point 7,scratch] ;point to scratch string store
call getwrd ;get ASCIZ word next on line
movem t1,comptr ;save command pointer for routines
skipe dspflg ;display commands ?
jrst [skipn going ;jumping ?
call prtcmd ;no
jrst .+1]
movei t1,comsym ;point to IND commands
hrroi t2,scratch ;point to this command
tbluk% ;perform table lookup
txnn t2,tl%exm ;exact match ?
jrst [skipn datflg ;no, in data mode ?
jrst tstlab ;no, test for a label
move t1,[0] ;yes, setup dummy command
jrst .+1] ;continue
skipe going ;execute commands ?
ret ;no, searching for label
hrrz t3,(t1) ;yes, get routine address
skipe datflg ;in DATA mode ?
jrst [caie t1,$$disab ;yes, is command DISABLE ?
ret ;no, ignore
jrst .+1] ;yes, let it work out what to do
move t1,comptr ;get command pointer for routine
call skpblk ;skip to Command start
movem t1,comptr ;resave pointer
call (t3) ;dispatch
jrst comfl ;failure to parse rest of command
ret ;ok, get next line
tstlab: ildb t2,comptr ;get next byte of command
caie t2,":" ;colon ?
jrst badcom ;no, invalid command
hrroi t1,scratch ;point to label name
move t2,cbyt ;and byte that starts line
call entlab ;enter label in table
ret ;bad return
move t1,comptr ;get position again
call skpblk ;skip over blanks
movem t1,t2
hrroi t1,comlin ;now prepare to rewrite command line
movei t3,maxcom*5 ;without a label on it
setz t4,
sout%
ercal error
movei t2,maxcom*5 ;what we wanted to write
sub t2,t3 ;minus what we didn't
movem t2,linlen ;is what we did
skipe going ;are we trying for a target label ?
jrst tstfnd ;yes, see if we just found it
pop p,t1 ;throw away return address
move t1,[point 7,comlin]
jrst intfil ;go for a new parse
;
; here to check if we just found our target label
;
tstfnd: hrroi t1,target ;point to desired target
call luklab ;lookup target in label table
ret ;not found - continue searching
setzm going ;found - turn off GOTO flag
move t1,comjfn ;our command file
sfptr% ;set the pointer for the next read
ercal error
setzm target ;clear out GOTO target
ret ;continue executing commands
badcom: tmsg <
?IND - unidentifiable command: >
jrst badc1
comfl: tmsg <
?IND - failure to parse command: >
badc1: hrroi t1,scratch
psout%
tmsg <
[IND - exiting]
>
jrst haltt
subttl The .RUN command
;
; This rotine processes the .RUN command, replacing the EXEC run
; cos that doesn't work with CRCMD.
;
.run: stkvar <rsptr,prgfrk>
call skpblk ;skip over blanks
movem t1,comptr ;point to non-blank
movem t1,t2 ;place in correct place for GTJFN
movei t1,gjargs ;address of file argument block
gtjfn% ;grab filespec
erjmp [ret] ;bad return
movem t2,rsptr ;save pointer to rest of string
call mapprg ;map the program
jrst [tmsg <
?IND - can't RUN program: > ;error from mapper
call errmes ;type JSYS error
ret] ;return failure
movem t1,prgfrk ;save the handle
move t1,rsptr ;get the rescan pointer
call rsload ;load the rescan buffer
move t1,prgfrk ;get the progs fork
setz t2, ;start at primary position
sfrkv% ;get the fork going
ercal error
move t1,prgfrk
wfork% ;wait for fork termination
kfork% ;kill it off
move t1,runnam ;retrive old program name
setnm% ;reset it
retskp ;return to the outside world
;
; routine to load rescan buffer from pointer in t1
;
rsload: push p,t1 ;save command pointer
setzm scratch ;blank out word we're going to use
setzm scratch+1 ;and the following
hrroi t1,scratch ;point to scratch buffer
move t2,prgjfn ;JFN of proggy we're about to run
movx t3,fld(.jsnof,js%dev)+fld(.jsnof,js%dir)+fld(.jsaof,js%nam)
+fld(.jsnof,js%typ)+fld(.jsnof,js%gen) ;name only
jfns% ;write filename to rescan buffer
ercal error ;crash
push p,t1 ;save pointer
call sysnam ;set new program name
pop p,t1 ;restore pointer
pop p,t2 ;retrive command pointer
bkptr t2 ;backspace one byte
setzb t3,t4 ;termina te on null
sout% ;write command with exe name
ercal error
hrroi t1,scratch ;repoint to rescan buffer
rscan% ;load rescan buffer
ercal error
ret ;return
;
; routine takes string from scratch buffer, and makes it our new
; program name. Calls ascsix from the string routines. Our old
; name is saved in runnam, for later restoration. New name is in
; prgnam.
;
sysnam: getnm% ;get current name
movem t1,runnam ;save it
move t1,[point 7,scratch] ;point to ASCII name
call ascsix ;SIXBIT returned in t2
move t1,t2 ;place in correct AC
setnm% ;set the name
ret ;return OK
;
; routine to map file whose JFN is in t1, return handle in t1
; +1 fail, +2 success
;
mapprg: stkvar <prghnd>
movem t1,prgjfn ;save jfn
movx t1,cr%cap ;same capabilites as us
cfork% ;grab a fork
erjmp [ret] ;no thanks, you've had enough
movem t1,prghnd ;save a handle on a fork
hrlzs t1,t1 ;put process handle in left half
hrr t1,prgjfn ;and a JFN in the right half
get% ;map file to process
erjmp [ret]
move t1,prghnd ;return handle for use by caller
retskp ;return success
subttl Set logical symbol true or false - .SETT
;
; .SETT/.SETF routines
;
.sett: setzm lgcflg ;true value
skipa
.setf: setom lgcflg ;false value
move t1,comptr ;point to command stuff
move t2,[point 7,asksym] ;and scratch store
call getwrd ;try out symbol
movem t1,comptr ;save command pointer
movei t1,lgcsym ;check symbol is logical
call askchk
jrst illtyp ;no, symbol is illegal type
hrroi t1,asksym ;ok, either its logical or undefined
move t2,lgcflg ;get its value
call entlgc ;enter into table
ret ;return fail
retskp ;return success
illtyp: tmsg <
?IND - symbol is invalid type for assignment:
>
call prtcmd
ret
subttl Test logical flag - .IFF/.IFT
;
; .IFF/.IFT - test logical flag and execute rest of command conditionally
; We use a second entry point to the command parser just past the point
; where we read from a file
;
.iff: setom lgcflg ;mark what we want
skipa
.ift: setzm lgcflg
move t2,[point 7,scratch]
call getwrd ;get symbol name
call skpblk ;skip over blanks
movem t1,comptr ;save for later
hrroi t1,scratch ;point to symbol name
call luklgc ;try to find symbol
jrst [tmsg <
?IND - logical symbol not defined: >
call prtcmd
ret] ;return failure - symbol not known
came t2,lgcflg ;is symbol what we want ?
retskp ;no, don't bother to do owt
move t1,comptr ;yes, skip over leadind blanks
call skpblk
.ift1: movem t1,comptr
hrroi t1,comlin ;prepare to rewrite command
move t2,comptr
movei t3,^d80 ;maximum length of line
setz t4, ;terminate on null
sout%
ercal error
movei t2,^d80 ;what we wanted to write
sub t2,t3 ;minus what we didn't
movem t2,linlen ;is what we did
pop p,t1 ;throw away our return address
pop p,t1 ;and PARSES return too
move t1,[point 7,comlin] ;point to command
jrst intfil ;internal command entry
subttl .ASK command - get yes/no answer
;
; ASK for value of a logical symbol
;
.ask: stkvar askval ;value of answer,symbol name(3 words)
call iniflgs ;initialize <default>, etc.
move t2,[point 7,asksym] ;temporary storage for our symbol
call getwrd ;get the symbol
call skpblk ;skip over blanks
movem t1,comptr ;save command line pointer
movei t1,lgcsym ;the table we allow
call askchk ;check the symbol isn't already there
jrst [tmsg <
?IND - symbol is not logical: >
call prtcmd
ret] ;return
move t1,comptr ;point beyond symbol
call skpblk ;eat up blanks
movem t1,comptr ;comptr now points at start of question
hrroi t1,asklin ;point to question buffer
hrroi t2,[asciz/* /] ;question prefix
setzb t3,t4
sout% ;write prefix
ercal error
move t2,comptr ;now use question text
movei t3,^d70 ;no more than 70 chars
movei t4,15 ;terminate on cr
sout% ;write question also
ercal error
bkptr t1 ;back up over cr
hrroi t2,[asciz\ [Y/N] \] ;put the question type ID out
setzb t3,t4
sout%
ercal error
.ask2: hrroi t1,asklin ;bung out CTRL/R buffer
psout%
hrroi t1,askans ;get answer
movx t2,rd%brk+rd%bel+rd%crf+rd%rai+5 ;break on ctrl/z, cr, esc
hrroi t3,asklin ;point to ^R buffer
rdtty% ;read answer
ercal error ;crash
txnn t2,rd%btm ;ended because of break ?
jrst yesorno ;bad answer
bkptr t1 ;backup pointer
move t3,[point 7,askans] ;point to start of answer
ildb t2,t3 ;get first char
cain t2,lf ;linefeed ?
jrst [movx t3,false ;yes, use default (NO)
movem t3,askval
setom defflg ;mark default taken
jrst .ask4]
ildb t2,t1 ;get pointer
cain t2,ctrlz ;was input terminated by ctrlz ?
call exit ;yes - exit if possible
cain t2,esc ;or escape
call escon ;yes - set <escape> to true
bkptr t1 ;back up pointer again
setz t2, ;obtain a null
idpb t2,t1 ;and make the string ASCIZ
hrroi t2,askans ;point to their answer
movei t1,ysntab ;yes or no table
tbluk% ;lookup
ercal error
txne t2,tl%nom ;no match ?
jrst yesorno ;complain
txne t2,tl%amb ;ambiguous (how yes or no can be, I
jrst yesorno ;don't know, but...)
txnn t2,tl%abr ;abbreviation ?
jrst [txnn t2,tl%exm ;or exact match ?
jrst yesorno ;nope - complain
jrst .+1] ;OK
movx t3,false ;initially false
caie t1,ysntab+1 ;was it no ?
movx t3,true ;no, setup for yes
movem t3,askval ;remember as value
.ask4: hrroi t1,asksym ;point to symbol
move t2,askval ;value of answer
call entlgc ;enter into table
ret ;return failure
retskp ;return success
;
; Complain about answer
;
yesorno: tmsg <?IND - yes or no required
>
jrst .ask2 ;ask again
purge askval
;
; Check symbol is not numeric or string or logical - t1 contains valid
; table address, assumes symbol is in ASKSYM.
; Return +1: Symbol is defined in other table
; +2: Symbol is in desired table or is not defined
;
askchk: stkvar oktab ;table we allow
movem t1,oktab ;remeber valid table
cain t1,numsym ;numeric symbol OK
jrst askch1 ;yes, don't check
hrroi t1,asksym ;point to our symbol
call luknum ;is it numeric ?
skipa ;no, try next
ret ;yes, return failure
askch1: move t2,oktab ;table we allow
cain t2,strsym ;string symbol OK ?
jrst askch2 ;yes, don't check
hrroi t1,asksym ;point again
call lukstr ;is it string ?
skipa ;no, check next
ret ;yes, return failure
askch2: move t2,oktab ;table we allow
cain t2,lgcsym ;logical OK ?
jrst askch3 ;yes, don't check
hrroi t1,asksym ;point again
call luklgc ;is it logical ?
skipa ;no, do next
ret ;yes, fail
askch3: retskp ;return success
subttl .SETS - set string symbol
;
; .SETS - set a string symbol to specified value
;
.sets: stkvar <strstt,sexpvl> ;3 words for symbol name
move t2,[point 7,asksym] ;place to store symbol name
call getwrd ;get symbol name
movem t1,comptr ;save position after symbol name
call skpblk ;skip over blanks
call strexp ;parse string expression
ret ;parser failed
movem t2,sexpvl ;save pointer to value
movei t1,strsym ;and valid table for it
call askchk ;check it isn't in another table
jrst illtyp ;it is - complain
hrroi t1,asksym ;point to symbol name
move t2,sexpvl ;and symbol value
call entstr ;enter string into table
ret ;return -failure
retskp ;return -success
subttl .STATUS command - print symbol table usage
;
; .STATUS command - print out status of IND tables, and symbol
; values
;
.status: tmsg <
----- IND symbol tables and internal flags -----
>
tmsg <
Exits on control-Z are >
hrroi t1,[asciz/not /]
skipe extflg ;allowed to exit ?
psout% ;no
tmsg <allowed.
>
tmsg < Substitution is >
hrroi t1,[asciz /not /]
skipe sbtflg ;substitution allowed ?
psout% ;no
tmsg < being performed.
>
skipn nsqzd ;garbage collection performed ?
jrst .stat1 ;no, print nothing
tmsg < Garbage collection of string pool has been performed >
movei t1,.priin ;terminal
move t2,nsqzd ;number of times performed
movx t3,^d10 ;rad10
nout% ;type number
ercal error
tmsg < times.
>
.stat1: tmsg <
> ;nice blank line before tables
define prttab(tabnam,tabadr,tabrtn),<
xlist
hrroi t1,[asciz/
'tabnam': /]
psout%
movei t1,tabadr ;;point to symbol table
call stuse ;;print usage
movei t1,tabadr ;;now get tables printed out
movei t2,tabrtn ;;routine to print values
call stprnt ;;print a table out
list
>
tmsg < Symbol table usage : >
prttab Numeric,numsym,.stn ;print numeric tables
prttab Strings,strsym,.sts ;string tables
prttab Logicals,lgcsym,.stl ;logical tables
prttab Files,filsym,.stf
prttab Labels,labsym,.stlb
tmsg <
----- End of status report -----
>
retskp ;return success always
;
; subroutine which takes a table address in t1, and prints out
; used and total entries.
;
stuse: movem t1,t4 ;save table address
hlrz t2,(t4) ;get currently used
movei t1,.priou ;type on terminal
movx t3,^d10 ;in rad 10
nout% ;type number
ercal error
tmsg < entries used from a total of >
movei t1,.priou ;on terminal again
movx t3,^d10
hrrz t2,(t4) ;get total in table
nout% ;type again
ercal error
tmsg < entries available.
Symbols defined, with values:
>
ret
;
; Subroutine takes a table address in t1, formatter routine address in t2.
; It prints out the names of all symbols in the table, and calls the
; routine from t2 to print out the symbol value, via a table pointer in
; t3.
;
stprnt: stkvar rtn
hlrz q1,(t1) ;head of table=number of entried,,max num
jumpe q1,stpr2 ;if table empty, say so
movns q1,q1 ;make negative
hrlz q1,q1 ;put in left half
addi q1,1 ;point to first real entry
add q1,t1 ;and add the start of the table in
movem t2,rtn ;save the formatter routine's addres
stpr1: hlro t1,(q1) ;construct byte pointer to symbol name
psout% ;type it
tmsg <: >
hrrz t3,q1 ;point to where we are in table
call (t2) ;dispatch to routine to print out value
move t2,rtn ;reget dispatch address
aobjn q1,stpr1 ;loop through table
ret ;return success
stpr2: tmsg < No entries currently in use.
>
ret
;
; The value printing routines
;
.stn: hrre t2,(t3) ;get numeric value
movx t3,^d10 ;print in decimal
movei t1,.priou ;on terminal
nout%
ercal error
tmsg <
>
ret
.stl: hrrz t2,(t3) ;get logical value
hrroi t1,[asciz/ False.
/] ;false ?
skipn t2
hrroi t1,[asciz/ True.
/] ;nope, true
psout%
ret
.sts: hrrz t2,(t3) ;get byte address of string
move t1,[point 7,strings] ;point to start of strings
adjptr t1,t2 ;adjust to point to selected string
psout%
tmsg <
>
ret
.stf: hrrz t2,(t3) ;get JFN
movei t1,.priou ;type on terminal
setz t3, ;no fancies
jfns% ;type filename
erjmp error
tmsg <
>
ret
.stlb: tmsg < at byte >
hrrz t2,(t3) ;get byte number
movx t3,^d10
movei t1,.priou
nout%
ercal error
tmsg <
>
ret
subttl Set numeric symbol
;
; .SETN command - set a symbol to a numeric value.
;
; Format: .SETN symbol nnnn
;
.setn: stkvar setnvl ;value
move t1,comptr ;point to command stuff
call skpblk
move t2,[point 7,asksym] ;and scratch store
call getwrd ;try out symbol
call skpblk ;skip over blanks to value
movem t1,comptr ;save command pointer
movei t1,numsym ;valid table
call askchk ;check symbol is numeric
jrst illtyp ;no
move t1,comptr ;point to start of expression
call numexp ;now parse the numeric expression
jrst setn1 ;failed
hrroi t1,asksym ;point to this symbol
call entnum ;add or replace in numeric table
ret ;faile
retskp ;succeed
setn1: tmsg <
?IND - can't understand number: >
call prtcmd ;print command
call errmes ;print reason
ret ;return failure
subttl .ENABLE and .DISABLE commands to toggle flags
;
; .ENABLE/.DISABLE commands - same code, same tables, just a
; flag marks the difference. These commands do things like
; turning substitution on and off. Format:
; .ENABLE SUBSTITUTION
;
.disable: setom edtyp ;mark enable
skipa
.enable: setzm edtyp
move t2,[point 7,scratch] ;point to the scratch buffer
call getwrd ;grab the argument to command
hrroi t2,scratch ;now point to the word
movei t1,edtab ;table of keywords for command
tbluk% ;try and lookup in the table
ercal error ;crash - table is trashed
txne t2,tl%nom ;match found ?
jrst .disa1 ;no - bad argument - complain
txne t2,tl%amb ;ambiguous ?
jrst .disa2 ;yes - complain
skipe datflg ;are we in DATA mode ?
jrst [caie t1,..data ;yes, is it the DATA directive ?
retskp ;no, ignore
skipn edtyp ;OK, is it DISABLE ?
retskp ;no, ignore
jrst .+1] ;yes, allow it
hrrz t2,(t1) ;OK - get routine to do the work
call (t2) ;call it
retskp ;and return success
;
; Errors from keywords
;
.disa1: tmsg <
?IND - unrecognised .ENABLE/.DISABLE flag:
>
call prtcmd ;print it
ret ;return failure
.disa2: tmsg <
?IND - ambiguous: >
call prtcmd ;print ambiguous command
ret ;return failure
subttl .ASKN - get numeric answer
;
; .ASKN - get a numeric answer
;
.askn: stkvar <askval,nrng> ;value of answer,number of ranges
call iniflgs ;initialize <escape>, etc.
setzm nrng ;zero number of ranges
movem t1,comptr ;save command position
call ranges ;get possible ranges, defualt
ret ;bad range format
movem t2,nrng ;save number of ranges
call skpblk ;skip blanks again
move t2,[point 7,asksym] ;temporary storage for our symbol
call getwrd ;get the symbol
call skpblk ;skip over blanks
movem t1,comptr ;save command line pointer
movei t1,numsym ;this is the one we allow
call askchk ;check the symbol isn't already there
jrst [tmsg <
?IND - symbol is not numeric: >
call prtcmd
ret] ;return
move t1,comptr ;point beyond symbol
call skpblk ;eat up blanks
movem t1,comptr ;comptr now points at start of question
hrroi t1,asklin ;point to question buffer
hrroi t2,[asciz/* /] ;question prefix
setzb t3,t4
sout% ;write prefix
ercal error
move t2,comptr ;now use question text
movei t3,^d70 ;no more than 70 chars
movei t4,15 ;terminate on cr
sout% ;write question also
ercal error
bkptr t1 ;back up over cr
hrroi t2,[asciz\ [#\] ;put the question type ID out
setzb t3,t4
sout%
ercal error
skipn nrng ;ranges, defaults ?
jrst .askn4 ;no, skip next
move t2,nrng ;get number of ranges
caige t2,2 ;at east 2 ?
jrst .askn4 ;no, strange syntax
movei t2," "
idpb t2,t1
movei t2,"R" ;bung out some chars
idpb t2,t1
movei t2,":" ;it's a waste of time using SOUT for
idpb t2,t1 ;this sort of thing - only a few chars
move t2,q1 ;get lower range
movx t3,^d10
nout% ;write it out
ercal error
movei t2,":" ;separator
idpb t2,t1
movx t3,^d10
move t2,q2 ;upper range
nout% ;write it out
ercal error
move t2,nrng ;get ranges again
caie t2,3 ;default as well ?
jrst .askn4 ;no
movei t2," " ;space between
idpb t2,t1
movei t2,"D" ;default
idpb t2,t1
movei t2,":"
idpb t2,t1
move t2,q3 ;get defualt val
movx t3,^d10
nout% ;write out
ercal error
.askn4: movei t2,"]"
idpb t2,t1
setz t2,
idpb t2,t1
.askn2: hrroi t1,asklin ;bung out CTRL/R buffer
psout%
hrroi t1,askans ;get answer
movx t2,rd%brk+rd%bel+rd%crf+rd%rai+10 ;break on ctrl/z, cr, esc
hrroi t3,asklin ;point to ^R buffer
rdtty% ;read answer
ercal error ;crash
txnn t2,rd%btm ;ended because of break ?
jrst numrqd ;bad answer
bkptr t1 ;backup pointer
ildb t2,t1 ;get pointer
cain t2,ctrlz ;was input terminated by ctrlz ?
call exit ;yes - exit if possible
cain t2,esc ;or escape
call escon ;yes - set <escape> to true
bkptr t1 ;back up pointer again
setz t2, ;obtain a null
idpb t2,t1 ;and make the string ASCIZ
move t1,[point 7,askans] ;point to start of answer
ildb t2,t1 ;get first byte
cain t2,lf ;carriage return ?
jrst .askndf ;yes, use defualts
skipn t2 ;or null ?
jrst .askndf
hrroi t1,askans ;point to their answer
movx t3,^d10 ;read ask rad 10
nin% ;decode number
erjmp numrqd ;bad number - try again
.askn5: movem t2,askval ;remember as value
move t2,nrng ;were ranges supplied
cail t2,2
jrst .asknr ;yes, check we are in range
.askn6: hrroi t1,asksym ;point to symbol
move t2,askval ;get value of answer
call entnum ;enter into table
ret ;faile
retskp ;succeed
;
; check answer is in range
;
.asknr: camge q2,askval ;top limit greater ?
jrst .askn7 ;no
camle q1,askval ;bottom limit lower ?
jrst .askn7 ;no
jrst .askn6 ;yes, OK
;
; Use defualt supplied
;
.askndf: move t2,nrng ;defualt given ?
caie t2,3
jrst numrqd ;no
move t2,q3 ;yes, use it
setom defflg ;indicate answer was defualted
jrst .askn5
;
; Complain about answer
;
numrqd: tmsg <?IND - numeric answer required
>
jrst .askn2 ;ask again
purge askval,nrng
.askn7: tmsg <
?IND - answer not in range
>
jrst .askn2
subttl .IFDF/.IFNDF commands
;
; Conditional execution depending on whether a symbol is defined
;
.ifndf: setzm ifdtyp ;flag not defined wanted
skipa
.ifdf: setom ifdtyp ;symbol must be defined
move t2,[point 7,asksym]
call getwrd ;get symbol name
call skpblk ;skip over blanks
movem t1,comptr ;save for later
setom fnd ;mark found initially
setz t1, ;indicate NO table is valid
call askchk ;and ask if it exists
skipa ;it does - skip next
setzm fnd ;it doesn't - indicate
move t1,fnd ;OK, did we find it ?
came t1,ifdtyp ;is the result a success
retskp ;no, either found and not wanted or vice versa
move t1,comptr ;OK - the IF worked,now do command
call skpblk ;skip over blanks
movem t1,t2 ;point to startof new command
hrroi t1,comlin ;yes, prepare to rewrite command
movei t3,^d80 ;maximum length of line
setz t4, ;terminate on null
sout%
ercal error
movei t2,^d80 ;what we wanted to write
sub t2,t3 ;minus what we didn't
movem t2,linlen ;is what we did
pop p,t1 ;throw away our return address
pop p,t1 ;and PARSES return too
move t1,[point 7,comlin] ;point to command
jrst intfil ;internal command entry
subttl The .PAUSE command
;
; This command uses the p$USH bit in CRCMD, which just continues the
; EXEC until we do a POP.
;
.pause: tmsg <
[IND - pausing. To continue type "POP"]
>
movx t2,c$cmd+m$exec+e$cho+p$ush ;push, freeze, echo, keep COMAND.CMD
call $CRcmd
skipe t3 ;OK ?
call excerr ;no
tmsg <
[IND - continuing]
>
retskp
subttl The GOTO command
;
; This command is of the form .GOTO lab, where lab will be in
; the file in the form .lab: . We check if it is already in the symbol
; table, in which case we can use SFPTR and return, or we must set
; GOING to true, and set up the label in TARGET, returning to allow
; a search through the file for the label.
;
.goto: move t1,comptr ;point to label name
move t2,[point 7,target] ;where to put label
call getwrd ;pickup label from command
movem t1,comptr ;save pointer
hrroi t1,target ;point to label
call luklab ;does it exist ?
jrst .goto2 ;no, we must search
move t1,comjfn ;yes, just reset
sfptr% ;the file pointer
ercal error
retskp ;and continue from the label
.goto2: setom going ;no, we must set up for a goto search
retskp ;which inhibits command execution
subttl The .OPEN, .OPENA and .CLOSE commands
;
; These commands are of the form .OPEN filename and .CLOSE . They open a
; secondary fileto which the output of the .DATA directive, or .ENABLE
; DATA is directed. .CLOSE is a no-op if no file is open.
; .OPENA opens the file for append, not write
;
.opena: movx t3,fld(7,of%bsz)+of%app ;open for append
skipa
.open: movx t3,fld(7,of%bsz)+of%wr ;open for write
skipe datjfn ;file already open ?
jrst [tmsg <
?IND - File already open:> ;yes, complain
call prtcmd
ret] ;return failure
movx t1,gj%sht+gj%new+gj%fou ;no, set up to open new file
move t2,comptr
gtjfn% ;attempt to get a handle
erjmp .open1 ;failed for some reason
movem t1,datjfn ;save the handle
move t2,t3 ;open for write or append
openf%
erjmp .open1 ;failed for some reason
retskp ;return success
.open1: tmsg <
?IND - can't OPEN file: >
call errmes
call prtcmd ;print JSYS error and command
setzm datjfn ;clear in case error was on OPENF
ret ;return failure
.close: move t1,datjfn ;get file handle
jumpe t1,rskp ;if no file, return success
closf% ;close file
ercal errmes ;huh ?
setzm datjfn ;indicate we have no file
retskp ;return success
subttl The .DATA command - sends data to secondary file
;
; This command is of the form .DATA kwjre ekekkjtr wjejjetre
; Everything from the first non-blank character after the .DATA to the
; end of line is output to the secondary file, if it exists. If it does
; not, an error is generated.
;
.data: move t1,datjfn ;get handle on secondary file
jumpe t1,[tmsg <
?IND - no data file open:>
call prtcmd ;no file open - complain
ret] ;return failure
move t2,comptr ;pointer to data for file
setzb t3,t4 ;write until null seen
sout%
erjmp [tmsg <
?IND - error writing to data file:> ;we have an error (disk full ?)
call errmes ;print the error
call prtcmd ;and the command
ret] ;return failure
retskp ;return success
subttl The .SETFI command - set file symbol
;
; This command is of the form .SETFI FILS Filename.type
; It sets up a file symbol
;
.setfi: move t2,[point 7,asksym]
call getwrd ;get file symbol name
call skpblk ;skip over blanks
movem t1,comptr
movei t1,filsym ;valid table
call askchk ;check valid type
jrst illtyp ;no
move t2,comptr ;point to filename
movx t1,gj%sht ;short call
gtjfn% ;get a handle
erjmp .sef1 ;error
movem t1,t2 ;save handle
hrroi t1,asksym ;point to symbol name
call entfil ;enter into table
ret ;fail
retskp ;succeed
.sef1: tmsg <
?IND - error in filename:>
call errmes
call prtcmd
ret
subttl The .ASKF command - ask for file spec (with recognition)
;
; This command is like the other .ASKx - format is
; .ASKF fildef Filename for output ?
; prompt is * Filename for output ? [F] .
; We use an extended GTJFN for the CTRL/R buffer, and return a JFN for the
; file symbol table.
;
.askf: stkvar askval ;value of answer
call iniflgs ;initialize <default>, etc.
move t2,[point 7,asksym] ;temporary storage for our symbol
call getwrd ;get the symbol
call skpblk ;skip over blanks
movem t1,comptr ;save command line pointer
movei t1,filsym ;the table we allow
call askchk ;check the symbol isn't already there
jrst [tmsg <
?IND - symbol is not a file symbol: >
call prtcmd
ret] ;return
move t1,comptr ;point beyond symbol
call skpblk ;eat up blanks
movem t1,comptr ;comptr now points at start of question
hrroi t1,asklin ;point to question buffer
hrroi t2,[asciz/* /] ;question prefix
setzb t3,t4
sout% ;write prefix
ercal error
move t2,comptr ;now use question text
movei t3,^d70 ;no more than 70 chars
movei t4,15 ;terminate on cr
sout% ;write question also
ercal error
bkptr t1 ;back up over cr
hrroi t2,[asciz\ [F]:\] ;put the question type ID out
setzb t3,t4
sout%
ercal error
.askf2: hrroi t1,asklin ;bung out CTRL/R buffer
movem t1,agjargs+.gjrty ;intialize ^R buffer for GTJFN
psout%
movei t1,agjargs ;address of argument block
setz t2, ;we supply no ASCIZ string
gtjfn% ;parse the file spec
erjmp [call errmes
jrst .askf2] ;try again
movem t1,askval ;store JFN
hrroi t1,asksym ;point to symbol
move t2,askval ;value of answer
call entfil ;enter into table
ret ;return failure
retskp ;return success
purge askval
subttl .GOSUB, .RETURN commands
;
; These two commands allow one to have subroutines in IND files.
; .GOSUB pushes down a call stack, and uses the .GOTO code. .RETURN
; pops the .GOSUB stack, and resets the byte pointer for input.
;
.gosub: move t3,gonst ;check GOSUB nesting depth
cail t3,mxcnst-1 ;maximum call depth exceeded ?
jrst [tmsg <
?IND - subroutine nesting depth exceeded:
>
call prtcmd
jrst haltt] ;yes - cras
move t1,comjfn ;command file JFN
rfptr% ;find start of next line
ercal error
movem t2,substk(t3) ;and stack on the subroutine list
aoj t3, ;bump the pointer
movem t3,gonst ;and store it again
jrst .goto ;get .GOTO to do the rest of the work
;
; .RETURN
;
.return: skipn gonst ;are we in a subroutine ?
jrst [tmsg <
?IND - .RETURN when not in subroutine:
>
call prtcmd
ret] ;return failure
move t1,gonst ;yes, get the nesting depth
soj t1, ;decrement
movem t1,gonst ;place back
move t2,substk(t1) ;get old file pointer
move t1,comjfn ;JFN of command file
sfptr% ;reset to continue from old place
ercal error
retskp ;return success
subttl .ASKS command - ask for a string
;
; format : .ASKS [low:high] symnam what is your name?
;
; low and high are optional range bounds for length
;
.asks: stkvar <askval,nrng> ;value of answer,number of ranges
call iniflgs ;initialize <escape>, etc.
setzm nrng ;zero number of ranges
movem t1,comptr ;save command position
call ranges ;get possible ranges, defualt
ret ;bad range format
movem t2,nrng ;save number of ranges
call skpblk ;skip blanks again
move t2,[point 7,asksym] ;temporary storage for our symbol
call getwrd ;get the symbol
call skpblk ;skip over blanks
movem t1,comptr ;save command line pointer
movei t1,strsym ;this is the one we allow
call askchk ;check the symbol isn't already there
jrst [tmsg <
?IND - symbol is not string: >
call prtcmd
ret] ;return
move t1,comptr ;point beyond symbol
call skpblk ;eat up blanks
movem t1,comptr ;comptr now points at start of question
hrroi t1,asklin ;point to question buffer
hrroi t2,[asciz/* /] ;question prefix
setzb t3,t4
sout% ;write prefix
ercal error
move t2,comptr ;now use question text
movei t3,^d70 ;no more than 70 chars
movei t4,15 ;terminate on cr
sout% ;write question also
ercal error
bkptr t1 ;back up over cr
hrroi t2,[asciz\ [S\] ;put the question type ID out
setzb t3,t4
sout%
ercal error
move t2,nrng ;get number of ranges
caie t2,2 ;at east 2 ?
jrst .asks4 ;no, strange syntax
movei t2," "
idpb t2,t1
movei t2,"R" ;bung out some chars
idpb t2,t1
movei t2,":" ;it's a waste of time using SOUT for
idpb t2,t1 ;this sort of thing - only a few chars
move t2,q1 ;get lower range
movx t3,^d10
nout% ;write it out
ercal error
movei t2,":" ;separator
idpb t2,t1
movx t3,^d10
move t2,q2 ;upper range
nout% ;write it out
ercal error
.asks4: movei t2,"]"
idpb t2,t1
setz t2,
idpb t2,t1
.asks2: hrroi t1,asklin ;bung out CTRL/R buffer
psout%
hrroi t1,askans ;get answer
movx t2,rd%brk+rd%bel+rd%crf+mslen ;break on ctrl/z, cr, esc
hrroi t3,asklin ;point to ^R buffer
rdtty% ;read answer
ercal error ;crash
bkptr t1 ;backup pointer
ildb t2,t1 ;get pointer
cain t2,ctrlz ;was input terminated by ctrlz ?
call exit ;yes - exit if possible
cain t2,esc ;or escape
call escon ;yes - set <escape> to true
bkptr t1 ;back up pointer again
setz t2, ;obtain a null
idpb t2,t1 ;and make the string ASCIZ
move t1,[point 7,askans] ;point to start of answer
.asks5: movem t1,askval ;remember as value
move t2,nrng ;were ranges supplied
cain t2,2
jrst .asksr ;yes, check we are in range
.asks6: hrroi t1,asksym ;point to symbol
move t2,askval ;get value of answer
call entstr ;enter into table
ret ;faile
move t1,[point 7,askans] ;point to answer
call leng ;get length of it
movem t3,strlen ;remember for user
retskp ;succeed
;
; check answer is in range
;
.asksr: move t1,[point 7,askans] ;point to answer string
call leng ;get length
camge q2,t3 ;top limit greater ?
jrst .asks7 ;no
camle q1,t3 ;bottom limit lower ?
jrst .asks7 ;no
jrst .asks6 ;yes, OK
;
; Complain about answer
;
purge askval,nrng
.asks7: tmsg <
?IND - string length not in range
>
jrst .asks2
subttl The .STOP command
;
; This justs simulates EOF
;
.stop: jrst eof
subttl The .IF command - permits comparison between strings or numbers
;
; This directive is of the form
; .IF symbol relop expression command
;
; where symbol is either a numeric or a string symbol name, relop is one
; of eq(=) ne(~=) gt(>) ge(>=) lt(<) le(=<) and expression is either
; string or numeric in type according to symbol. The alternative forms of
; relops are shown in brackets after their mnemonic names. The command
; is executed if the comparison returns a true result.
;
.if: move t2,[point 7,asksym] ;where to put our symbol name
call getwrd ;retrieve the symbol
call skpblk ;skip over blanks
move t2,[point 7,scratch] ;now get operator
call getwrd ;retrieve in ASCIZ
call skpblk ;skip over next blanks
movem t1,comptr ;and save position of start of exp
movei t1,reltab ;table of relational operators
hrroi t2,scratch ;one we are considering at the moment
tbluk% ;determine if in table
ercal error ;crash - tables trashed
txnn t2,tl%exm ;exact match ?
jrst .if1 ;no, complain - bad relop
hrrz t2,(t1) ;OK, get relop ID
movem t2,relop ;and remember for when we parse exp
hrroi t1,asksym ;now find out if string or numeric
call luknum ;try numeric first
jrst [hrroi t1,asksym ;failed, try string
call lukstr
jrst [hrroi t1,asksym ;failed again, try system symbol
call luksys ;lookup
jrst .if2 ;still nowhere, complain
movem t3,iftyp ;remember symbol type
movem t2,ifval ;and value
jrst .if3] ;continue
movem t2,ifval ;save value
movei t1,$str ;and type
movem t1,iftyp
jrst .if3] ;continue
movem t2,ifval ;numeric succeeded, save value
movei t1,$num ;and remember type also
movem t1,iftyp
.if3: move t1,iftyp ;get type of symbol
cain t1,$num ;numeric ?
jrst .if4 ;yes
move t1,comptr ;no,must be string - point to exp
call strexp ;parse string expression
ret ;failed - strexp has complained
movem t1,comptr ;save position in command
move t1,ifval ;get byte number of symbol value
stcmp% ;compare two strings
move t3,relop ;now get desired operator
jumpe t1,.ifse ;strings are equal ?
txne t1,sc%lss ;no, is sym less than exp ?
jrst .ifsl ;yes
txne t1,sc%gtr ;greater than ?
jrst .ifsg ;yes
txne t1,sc%sub ;subset ?
jrst .ifsl ;yes, consider as lt
tmsg <
?IND - can't understand string comparison: Internal error
>
jrst haltt ;crash
;
; Here for numeric comparison
;
.if4: move t1,comptr ;point to start of expression
call numexp ;evaluate
ret ;failed
movem t1,comptr ;save command position
move t1,ifval ;value of numeric symbol
camn t1,t2 ;are they equal ?
jrst .ifse ;yes
caml t1,t2 ;is sym<exp ?
jrst .ifsg ;no, must be greater
jrst .ifsl ;yes, dispatch as such
;
; Test if the comparison is a success
;
.ifsl: move t3,relop ;get operator bits
txnn t3,$lt ;less than work for this relop ?
retskp ;no, do nothing
jrst .ifgo ;yes, do second command
.ifse: move t3,relop
txnn t3,$eq ;equals work ?
retskp ;no
jrst .ifgo ;yes
.ifsg: move t3,relop
txnn t3,$gt ;greater than OK ?
retskp ;no
jrst .ifgo ;yes
;
; test succeeded - now rewrite command and dispatch for execution
;
.ifgo: move t1,comptr
call skpblk ;skip to start of command
jrst .ift1 ;get .IFT code to do the work
;
; .IF errors
;
.if1: tmsg <
?IND - unknown relational operator:
>
call prtcmd ;print erroneous command
ret ;return failure
.if2: tmsg <
?IND - symbol is not numeric or string for comparison:
>
call prtcmd
ret ;return failure
subttl .IND/.DEC directives - increment/decrement numeric symbol
;
; These directives are purely to make it easier to add or subtract one
; from a symbol to do loops. It looks clearer than .SETN symnam symnam+1
;
.dec: move t2,[soj t2,] ;decrement instruction
skipa
.inc: move t2,[aoj t2,] ;increment instruction
push p,t2 ;save
move t1,comptr ;command pointer
move t2,[point 7,asksym] ;storage for symbol name
call getwrd ;get name
hrroi t1,asksym ;don't use ASKCHK - number MUST alread
call luknum ;exist.
jrst .ince ;it doesn't - complain
hrroi t1,asksym ;we now have the current value in t2
pop p,t3 ;so retrieve inc/dec instruction
xct t3 ;and execute it
call entnum ;and re-enter in table
ret
retskp ;return success
.ince: pop p,t1 ;throw away saved instruction
tmsg <
?IND - symbol does not exist for increment/decrement:
>
call prtcmd
ret ;return failure
subttl The .TEST command - test the length of a string expression
;
; This command is of the form .TEST strexp, and sets the special
; symbol <STRLEN> to the length of the string in characters.
;
.test: move t1,comptr ;get command pointer
call strexp ;parse the string expression
ret ;parse failed
move t1,t2 ;get pointer to string in right ac
call leng ;discover length
movem t3,strlen ;remember in right place for SYSSYM
retskp ;return success
subttl The .TESTFILE directive - test for existence of a file
;
; Format: .TESTFILE filnam.typ
;
; Sets symbol FILESTAT to 0: File does not exist
; 1: File exists
; -1: File exists in deleted state only
; -2: File exists but is invisible (may be del'd)
; -3: File is offline
.testfil: move t2,comptr ;point to filename
movx t1,gj%sht+gj%old ;insist on old filename
gtjfn% ;try for a handle
erjmp .tsf1 ;no success - see what happened
movei t2,1 ;indicate existence
movem t2,filerr ;remember
jrst .tsf5 ;now test for offline
.tsf1: cain t1,gjfx18 ;no such filename ?
jrst .tsf2 ;yes, try deleted
cain t1,gjfx19 ;no such filetype?
jrst .tsf2 ;yes
cain t1,gjfx20 ;no such gen ?
jrst .tsf2 ;yes
cain t1,gjfx24 ;file not found ?
jrst .tsf2 ;yes
cain t1,gjfx32 ;no files match spec ?
jrst .tsf2 ;yes *wildcard only*
tmsg <
?IND - invalid filespec:>
call prtcmd ;type invalid command
ret ;return failure
.tsf2: move t2,comptr ;get saved filename pointer
movx t1,gj%sht+gj%old+gj%del ;consider deleted files this time
gtjfn%
erjmp .tsf3 ;OK, try invisible
setom filerr ;indicate status
jrst .tsf5 ;now test for offline
.tsf3: move t2,comptr ;get saved filename pointer
movei t1,tsargs ;pointer to long form argument block
gtjfn% ;try again
erjmp .tsf4 ;file definitely not found (syntax OK)
movx t2,-2 ;set invisible status
movem t2,filerr ;mark
.tsf5: move t2,[1,,.fbctl] ;get .FBCTL out of the FDB
movei t3,t4 ;return info in t4
gtfdb% ;grab info
ercal error ;die horribly
move t2,filerr ;get current status word
txne t4,fb%off ;file is offline ?
movx t2,-3 ;yes, indicate
movem t2,filerr ;remeber status
rljfn% ;lose JFN
ercal error
retskp ;return OK
.tsf4: setzm filerr ;file does not exist (we know the name's
retskp ;OK because it passed the first test)
subttl .CALL directive - invokes another IND file, passing symbols
;
; This directive is of the form .CALL filnam
; If the file type is not specified, the same default applies as with the
; IND program itself. This directive allows you to pass symbols between
; the command files (all symbols are still valid), thus having command
; "procedures" you can call at will.
;
.call: move t2,calnst ;get current nesting level of IND
cail t2,mxcal ;above maximum call depth ?
jrst [tmsg <
?IND - maximum file nesting depth exceeded
>
ret] ;yes, return failure
move t1,comjfn ;no, get current file handle
movem t1,calstk(t2) ;stack it
aoj t2, ;bump nesting depth
movem t2,calnst ;save it
move t2,comptr ;get command pointer
movei t1,cgjargs ;address of GTJFN argument block
gtjfn% ;long form GTJFN
erjmp [tmsg <
?IND - can't .CALL file:>
call errmes ;print error message
call prtcmd ;print command
ret] ;return failure
movem t1,comjfn ;save JFN
movx t2,fld(7,of%bsz)+of%rd ;open for read
openf% ;well, try anyway
erjmp [tmsg <
?IND - can't open command file:> ;failed
call errmes ;print system error
call prtcmd ;and failed command
ret] ;return failure
retskp ;return OK
subttl .DELAY directive - pauses for n seconds
;
; format: .DELAY numexp (general numeric expression)
;
.delay: call numexp ;parse numeric expression
ret ;failed for some reason
skipge t2 ;positive number ?
jrst [tmsg <
%IND - can't DELAY for a negative amount of time>
call prtcmd ;print command
retskp] ;return OK - warning only
move t1,t2 ;get in right ac
imuli t1,^d1000 ;convert secomds to milliseconds
disms% ;sleep....
retskp ;and continue
subttl .DISPLAY directive - types string on terminal without cr/lf
;
; Format: .DISPLAY strexp .
; This directive is primarily intended for files wanting to do cursor
; control via string variables.
;
.display: call strexp ;parse string expression
ret ;failed
move t1,t2 ;retrive pointer
psout% ;type string
ercal error ;huh ?
retskp ;can only really return success
;==**== Next command goes here
subttl Text substitution routines
;
; text substitution routines - given a command line in COMLIN,
; we scan the line for 'SYMBOL' and substitute the appropriate string
; or numeric stuff. Return +1/+2
;
substi: stkvar <subst,subptr,newptr>
skipe purcmd ;are we being re-entered ?
retskp ;yes, ignore
move t1,[comlin,,comcop] ;make copy of command line
blt t1,comcop+maxcom-1 ;for use by .DATA directives
move t1,[point 7,comlin] ;point to command line
movem t1,comptr ;save as command pointer
skipe sbtflg ;are we allowed to substitute ?
retskp ;no, user has disabled function
skipe going ;are we doing a GOTO search ?
retskp ;yes, symbols may not be defined
move t1,[point 7,sublin] ;point to substitution line
movem t1,subptr ;save it
move t1,[point 7,comlin] ;point to command line
movem t1,comptr ;save as command pointer
;
; Enter here for each round of substitution
;
subst2: move t1,comptr ;point to where we are in command line
movei t2,"'" ;search for symbol starter
movei t3,^d80 ;80 chars away at most
call search ;try to find the character
skipge t3 ;was it found ?
jrst subend ;no, we can exit gracefully
move t2,[point 7,subsym] ;yes, get the symbol name
movem t1,subst ;substitution start pointer
call getwrd ;will return on non-alpha
ildb t2,t1 ;now get next char
caie t2,"'" ;should be closing quote
jrst sbqerr ;no, so we can't parse the line
movem t1,newptr ;now this points beyond end of symbol
move t1,subptr ;reget substitution pointer
move t2,comptr ;reget command pointer
movei t3,^d80 ;maximum of 80 chars
movei t4,"'" ;terminate on quote
sout% ;write normal part of string
ercal error
bkptr t1 ;back up over "'"
movem t1,subptr ;and save again
move t1,[point 7,subsym] ;start of symbol
call lukstr ;lookup in string symbol table
jrst subnt ;string not found try numeric
subst3: move t1,subptr ;OK, get pointer to output again
setzb t3,t4 ;terminate on null
sout% ;write substituted string
ercal error
movem t1,subptr ;save substitution pointer
move t1,newptr ;this points beyond end of symbol
movem t1,comptr ;which is where we want to search from
jrst subst2 ;and go and try for next bit of string
;
; try for numeric symbol and get value
;
subnt: move t1,[point 7,subsym] ;point at symbol name
call luknum ;lookup symbol as numeric
jrst subft ;not found - try for file symbol
hrroi t1,scratch ;point to scratch buffer
movx t3,^d10 ;write number as numeric
nout%
ercal error
hrroi t2,scratch ;set up for substi as if a string was
jrst subst3 ;found and continue
;
; Try for file symbol and get filename
;
subft: move t1,[point 7,subsym] ;point to symbol name
call lukfil ;try in file table
jrst subsy ;not found -try system symbol
hrroi t1,scratch ;write name to scratch buffer
setz t3, ;no fancy options: dev:<dir>file.typ.gen
jfns% ;write out name
ercal error
hrroi t2,scratch ;set up for substitution
jrst subst3 ;place into command
;
; Try for system symbol, decode
;
subsy: move t1,[point 7,subsym]
call luksys ;lookup symbol in system tables
jrst subnf ;not found - complain
caie t3,$str ;string symbol ?
jrst nsubsy ;no, hopefully numeric
hrroi t1,scratch ;yes, write to scratch buffer
hrroi t2,sysval ;from where left
setzb t3,t4
sout% ;with a sout%
ercal error
hrroi t2,scratch ;fool the rest of the code this normal
jrst subst3 ;continue
nsubsy: caie t3,$num ;numeric, perhaps ?
jrst illsy ;no, illegal system symbol type
hrroi t1,scratch ;yes, write to scratch buffer
move t2,sysval ;get value of symbol
movx t3,^d10 ;in RAD 10
nout%
ercal error
hrroi t2,scratch ;fool the rest of the code
jrst subst3 ;and continue
;
; print out remainder of command in buffer, and copy buffer back
; to comlin
;
subend: move t1,subptr ;where we are
move t2,comptr ;where we are coming from
setzb t3,t4 ;terminate on null
sout% ;write rest of string
ercal error
hrroi t1,comlin ;point back to comlin
hrroi t2,sublin ;and to where we have the substituted
movei t3,maxcom*5 ;maximum command length
setz t4, ;string in ASCIZ
sout%
ercal error
movei t2,maxcom*5-1 ;what we wanted to read
sub t2,t3 ;minus what we didn't
movem t2,linlen ;is what we did
move t1,[comlin,,comcop] ;make copy of command line
blt t1,comcop+maxcom-1 ;for use by .DATA directives
move t1,[point 7,comlin] ;restore command pointer
retskp ;return success
purge newptr,subptr,subst ;throw away temporary names
;
; string symbol not found
;
subnf: tmsg <
?IND - undefined symbol for substitution: >
call prtcmd
ret ;return failure
;
; mismatched quotes
;
sbqerr: tmsg <
?IND - mismatched quotes while substituting: >
call prtcmd ;dump the command out
ret ;return failure
;
; Crazy system symbol type
;
illsy: tmsg <
?IND - invalid system symbol type>
call prtcmd
ret
subttl Rescan EXEC command line for input file
;
; This routine rescans our command line to attempt to get a filename
; for it.
;
gcom: movei t1,.rsini ;initialize for rescan
rscan%
ercal error
movei t1,.rscnt ;count of chars in buffer
rscan%
ercal error
movnm t1,t3 ;make a count for SIN%
movei t1,.priin ;read rescan stuff
hrroi t2,scratch ;write to scratch
setz t4, ;terminate on null
sin% ;read rescan stuff
adjptr t2,[3] ;bump pointer to safe area
move t1,[point 7,scratch] ;where to read from
call getwrd ;get a word out
call skpblk ;skip over intervening blanks
movem t1,t2 ;put pointer in right place
movei t1,cgjargs ;address of argument block
gtjfn% ;attempt to get handle on file
erjmp [call errmes
ret] ;return bad - get from terminal
retskp ;return success
subttl Sundry routines
;
; This routine resets the question/answer flags to initial settings
; (for system symbols <ESCAPE>, <DEFAULT> and .DISABLE/.ENABLE EXIT
;
iniflgs: setzm escflg ;indicate no escape
setzm defflg ;no defualt
ret
;
; exit if ctrl/z exit is allowed
;
exit: skipe extflg ;allowed to exit ?
ret ;no
jrst haltt ;yes - finish up
;
; set <escape> to true
;
escon: setom escflg
ret
prtcmd: hrroi t1,comlin
psout%
ret
;
; Check substring limits - byte pointer in t1 to string, or 0 if not
; yet exists. Q1,Q2 contain start, finish. Check that q1<=q2, and
; if t1 is not 0, that q2 is less than the length of the string.
; Also check q1>0
;
cksubs: skipg q1 ;q1 > 0 ?
ret ;no, complain
camle q1,q2 ;q1 <= q2 ?
ret ;no, complain
skipn t1 ;pointer supplied ?
retskp ;no, return success
push p,t1 ;save pointer
call leng ;get length of string
skipge t3 ;length OK ?
jrst cksub1 ;no... strange
camle q2,t3 ;top of range less than string length ?
jrst cksub1 ;no, complain
pop p,t1 ;restore pointer
retskp ;yes, OK
cksub1: pop p,t1
ret
;
; write to data file if necessary
; Must preserve AC 1. On entry: DATFLG/-1, datsav/0:
; Last command was .ENABLE DATA, do nowt
; -1,-1: In DATA mode, write to file
; 0,-1: Last command was .DISABLE DATA, do nowt
;
wdata: skipn datsav ;are we in DATA mode ?
ret ;no, just ENABLEd now
skipn datflg ;just done a .DISABLE DATA ?
ret ;yes, do nowt
push p,t1 ;save useful acs
skipn datjfn ;open data file ?
jrst wdata1 ;no, crash
hrroi t2,comcop ;yes, write to file
move t1,datjfn ;from command buffer
setzb t3,t4 ;terminate on null
sout% ;write
ercal error
pop p,t1
ret ;return OK
wdata1: tmsg <
?IND - can't .ENABLE DATA without data file open.>
jrst haltt
subttl Routines used by system symbol tables
;
; These routines find the values of various system permanent symbols,
; and leave their answers (of whatever forms) in SYSVAL.
;
date.: hrroi t1,sysval ;where to put output string
seto t2, ;current date/time
odtim% ;format bits already in t3
ret
sysnm.: move t1,[sixbit/SYSVER/] ;routine to find system name
sysgt% ;find out how many words in table
hrrz t1,t2 ;put table number in t1
hlre t3,t2 ;set up counter
hrrzs t2,t2 ;leave t2 with just a table number
setz t4,
sysnm1: getab% ;read next word from table
ercal error
movem t1,sysval(t4) ;store
aoj t4, ;bump t4
hrlz t1,t4 ;set up t1 again - getab trashes it
hrr t1,t2 ;and get the table number
aojn t3,sysnm1 ;go until finished
ret ;all done
subttl comment processing
;
; This routine is called to output comments in command files to the
; screen
;
coment: hrroi t2,comlin ;point to command line
movei t1,.priou ;point to terminal
setzb t3,t4 ;terminate on null
sout% ;type it
ercal error ;crash
ret
;
; IND comments
;
.coment: retskp ;succeed always, do nowt
;
; Called whenever an error occurs executing an EXEC command with
; JSYS error in t3
;
excerr: tmsg <
?IND - error executing command: >
movei t1,.priou ;type on terminal
move t2,t3 ;get error number in right place
hrl t2,.fhslf ;must point to own fork
setz t3, ;no limit on message length
erstr% ;type out JSYS error
trn
trn ;ignore errors with errors
haltt: haltf% ;stop
tmsg <
?Cannot be continued>
jrst haltt
;
; called ar end of file
;
eof: skipe going ;still searching for a label ?
jrst laberr ;yes, error
skipn calnst ;end of .CALLED file ?
jrst eof1 ;no, proceed as normal
sos calnst ;drop nesting level
move t1,comjfn ;get old command file JFN
closf% ;close it
erjmp .+1 ;ignore errors
move t1,calnst ;get current value
move t2,calstk(t1) ;and get old command file JFN
movem t2,comjfn ;store as new one
jrst fillop ;loop for next command
eof1: tmsg <
@ <EOF>>
skipe datjfn ;data file open ?
jrst [move t1,datjfn ;yes, close it
closf%
erjmp .+1 ;ignore errors
jrst .+1]
jrst haltt
laberr: tmsg <
?IND - End of file while searching for label ">
hrroi t1,target ;point to label name
psout% ;type it
tmsg <">
jrst haltt ;stop
;
; called from numeric parser
;
illvec: tmsg <
?IND - fatal internal error in numeric parser - impossible operator invoked.
>
jrst haltt
subttl Read next command line
;
; This routine zeros out the command space and reads in the next line
; from the command file. It returns +1 on error, +2 on success
;
getlin: setzm comlin ;zero out first word of command
setzm purcmd ;indicate real command for SUBSTI
move t1,[comlin,,comlin+1] ;from,,to
blt t1,comlin+maxcom-1 ;zero out command line
move t1,comjfn ;handle on command file
rfptr% ;read where we are in file
ercal error
movem t2,cbyt ;remember for .goto, etc.
hrroi t2,comlin ;where to put command line
movei t3,maxcom*5 ;maximum chars in string
movei t4,lf ;terminate on linefeed
sin% ;read record
erjmp [ret] ;return +1 - failure
movei t2,maxcom*5 ;what we wanted to read
sub t2,t3 ;minus what we didn't
movem t2,linlen ;is what we did
move t1,[point 7,comlin] ;return start pointer
retskp ;return success
subttl Range parsing routines
;
; Ranges - called with a byte pointer in t1, looks for something of the
; form [a:b:c], c being optional, and all of a,b,c being arbitrary numeric
; expressions. They can indicate a range for an answer (a is min, b max, c
; default) or a substring slice (where c should be absent.) Here, we don't
; care. a,b,c are returned in q1,q2,q3 and the number of vals found is
; returned in t2. The byte pointer is undisturbed if t2=0, else it points
; beyond the closing bracket.
;
ranges: stkvar <savptr,nvals>
movem t1,savptr ;save the pointer
call skpblk ;jump over blanks
ildb t2,t1 ;get first non-blank
caie t2,"[" ;start of range ?
jrst [setz t2, ;no, return no args
move t1,savptr ;restore original pointer
retskp] ;return success
hrlzi t4,-3 ;initialize count
rangl: push p,t4 ;save ac
call numexp ;parse first expression
jrst [pop p,t4
jrst range1] ;bad expression
pop p,t4 ;restore
movem t2,vals(t4) ;save value of expression
ildb t2,t1 ;get next byte
caie t2,":" ;should be ":" to separate
jrst [cain t2,"]" ;or failing that, end of range specs
jrst [aoj t4,1 ;it is, fake extra pass in loop
jrst rang2] ;return OK
jrst rang3] ;it ain't, complain
aobjn t4,rangl ;ok, loop 3 times
rang2: move q1,vals ;get first value
move q2,vals+1 ;and second
move q3,vals+2 ;and third
hrrz t2,t4 ;get number of args parsed
retskp ;return success
rang3: tmsg <
?IND - bad range format: >
call prtcmd
ret ;return failure
range1: tmsg <
?IND - bad numeric range>
ret ;NUMEXP has complained - return failure
subttl Numeric expression parsing
;
; NUMEXP - parse a numeric expression of the form
; ID op ID op.... where ID is either a constant, variable or bracketed
; expression, and op is one of "+","-","*","/" . We do NOT parse this
; truly algebraically as no rules of operator precedence are applied.
; Evaluation is simply left to right, and brackets must be used to overide
; this. We use a separate parsing stack for this, to simplify exits if we
; bomb out halfway through. We use a simple expression stack of the form:
; TOP BOTTOM
; op val op val ... op val.
;
; which is unstacked on every ")". Initially we put 0 and "+" as the
; current op and val, in case we get (1+2) or that.
; Opcodes:
; +:1 -:2 *:3 /:4
; Input: t1/Byte pointer to expression
; Output: t2/Value of expression
;
numexp: move p5,[iowd numsl,numstk] ;set up parsing stack
setzm cnval ;initialize current value of exp.
movei t2,addop ;and set current operator to +
movem t2,cnop
setzm numnst ;initialize nest level of brackets to 0
;
; Come here to get number, symbol or "("
;
gval: ildb t2,t1 ;get first byte of next bit
caig t2," " ;space ?
jrst numext ;not a printer - exit if OK
cain t2,"(" ;open bracketed expression ?
jrst opnbrk ;yes - push parse stack
call isdgt ;OK, is it a digit ?
jrst symevl ;no, evaluate as a symbol
bkptr t1 ;yes, backup over first digit
movx t3,^d10 ;read as decimal
nin% ;monitor does work
erjmp numex1 ;bad numeric format
movem t2,nval ;OK, we have val1
bkptr t1 ;backup over first non-digit
jrst eval ;now evaluate current expression
symevl: bkptr t1 ;we have a symbol - hopefully (may be ])
move t2,[point 7,scratch] ;bung symbol name here
call getwrd ;grab symbol name
movem t1,numptr ;save pointer value
move t1,[point 7,scratch] ;point to symbol
call leng ;and evaluate length
skipn t3 ;was it zero ?
jrst numex2 ;yes, unknown symbol for mo - better ?
hrroi t1,scratch ;point to symbol name
call luknum ;attempt to look it up
jrst [hrroi t1,scratch ;failed - point again
call luksys ;and try for system symbol
jrst numex2 ;unknown
caie t3,$num ;numeric type ?
jrst numex4 ;no, complain
jrst .+1] ;succeed
movem t2,nval ;save value
move t1,numptr ;restore pointer
jrst eval ;evaluate so far
opnbrk: push p5,cnval ;remember current exp value
push p5,cnop ;and curent operator
aos numnst ;bump nesting level
setzm cnval ;initialize current value of exp.
movei t2,addop ;and set current operator to +
movem t2,cnop
jrst gval ;get next value
clsbrk: sosge numnst ;drop nesting level, test for OK
jrst badbrk ;bad parentheses
pop p5,cnop ;get old operator
pop p5,t2 ;and old value
exch t2,cnval ;make current value
movem t2,nval ;and make current val second op
jrst eval ;get evaluated
;
; here after obtaining a value or popping brackets - evaluate current
; expression and get next operator
;
eval: move t2,cnop ;get current operator
call @optab(t2) ;dispatch to arithmetic routine
ildb t2,t1 ;get next byte
caige t2," " ;printing character ?
jrst numext ;no, try exit
cain t2,")" ;close bracket ?
jrst clsbrk ;yes, pop parse stack
cain t2,"+" ;add ?
jrst [movei t2,addop ;yes, remeber operator
movem t2,cnop
jrst gval]
cain t2,"-" ;subtract ?
jrst [movei t2,subop
movem t2,cnop
jrst gval]
cain t2,"*" ;multiply ?
jrst [movei t2,mulop
movem t2,cnop
jrst gval]
cain t2,"/" ;divide ?
jrst [movei t2,divop
movem t2,cnop
jrst gval]
jrst numext ;none of these - try exiting expression
;
; here at possible end of expression - check state of parse stack for
; valid parentheses
;
numext: skipe numnst ;still nested ?
jrst badbrk ;yes, complain
move t2,cnval ;yes,get expression value
bkptr t1 ;nackup over the byte we don't want
retskp ;return success
numex1: tmsg <
?IND - bad numeric constant: >
call prtcmd
ret ;return failure
numex2: tmsg <
?IND - unknown numeric symbol in expression:
>
call prtcmd
ret
badbrk: tmsg <
?IND - Unmatched parentheses: >
call prtcmd
ret
numex4: tmsg <
?IND - non-numeric system symbol in numeric expression:
>
call prtcmd
ret
;
; arithmetic routines
;
nadd: move t3,nval ;get second operand
addm t3,cnval ;and add to first
ret
nsub: move t3,cnval ;get first operand
sub t3,nval ;subtract second
movem t3,cnval ;store result
ret
nmul: move t3,nval ;get second operand
imulm t3,cnval ;multiply by first and store
ret
ndiv: move t3,cnval ;get dividend
idiv t3,nval ;divide by divisor
movem t3,cnval ;store result
ret
subttl String expression parsing
;
; This subroutine accepts, like numexp, a pointer in t1 to the
; start of a string expression to be parsed. It calls NUMEXP, via
; RANGES, when doing substring evaluation. It accepts string constants
; of the form "asbdek", string variable names, like STREXP, and optional
; range values on the variables: STREXP[1:23] . The numbers indicate
; start and stop chop positions for a substring. The only operator is
; "+" for concatenation.
; Input: t1/byte pointer to expression (parse stops on bad char)
; Output: t2/ Pointer to result of expression
;
strexp: stkvar <stxptr,qstrt,ssymvl>
setzm wrkstr ;initialize parsed string to null
move t2,[point 7,wrkstr] ;point to it
movem t2,stxptr ;initialize expression pointer
strelp: ildb t3,t1 ;get a byte
caie t3,quote ; "?
jrst ssymev ;no, must be a symbol
movei t2,quote ;get closing quote
movei t3,mslen ;maximum string length
movem t1,qstrt ;save start of string
call search ;search for matching quote
skipge t3 ;found ?
jrst strex1 ;no - complain
movem t1,comptr ;save position in string of end
move t2,qstrt ;get start position
movns t3,t3 ;make absolute limit
jumpe t3,strel1 ;special for null string ""
movei t4,quote ;terminate on "
move t1,stxptr ;write to expression buffer
sout% ;write quoted string
ercal error
strel1: ibp t2 ;bump past " in input
movem t1,stxptr ;save pointer position
movem t2,comptr ;and position to read from command
jrst getop ;get possible operator
ssymev: bkptr t1
move t2,[point 7,scratch] ;where to put symbol name
call getwrd ;get symbol name
movem t1,comptr ;save end of symbol
hrroi t1,scratch ;point to symbol name
call lukstr ;and lookup value in tables
jrst [hrroi t1,scratch ;not there - try system symbol
call luksys ;is it there ?
jrst strex2 ;not there - complain
caie t3,$str ;string type symbol ?
jrst strex3 ;no - complain
hrroi t2,sysval ;construct pointer to value
jrst .+1] ;OK - is there
movem t2,ssymvl ;remember string value (ie pointer)
move t1,comptr ;point to next byteof expression
call ranges ;check for possible substring stuff
ret ;bad range format
movem t1,comptr ;may have moved
jumpe t2,ssymnr ;if no ranges, jump over
caie t2,2 ;if ranges, must be 2 and 2 only
jrst bdsubs ;bad substring format
move t1,ssymvl ;get symbol value pointer
call cksubs ;check substring stuff is in range
jrst bdsubs ;no - complain
move t2,ssymvl ;OK, point to string start
adjptr t2,q1 ;start of substring
bkptr t2 ;but ranges start at 1, so....
move t3,q2 ;get end of range
sub t3,q1 ;compute difference
aoj t3, ;add 1 'cos of 1/0 stuff
movns t3,t3 ;make negative for absolute limit
setz t4, ;terminate
move t1,stxptr ;next bit of expression
sout% ;write out
ercal error
idpb t4,t1 ;dump out extra null
bkptr t1 ;and backup over it
movem t1,stxptr ;save pointer to result
jrst getop ;get possible operand
;
; String symbol, no range specified
;
ssymnr: move t2,ssymvl
; move t2,[point 7,strings]
; adjptr t2,t3 ;adjust to point to correct POOL byte
move t1,stxptr ;where we will put expression
setzb t3,t4 ;termiate on null
sout% ;write variable value
ercal error
movem t1,stxptr ;remember where we got to
jrst getop ;get possible operand
;
; Check for operand
;
getop: move t1,comptr ;point to command
ildb t2,t1 ;get next char
caie t2,"+" ;is it "+" ?
jrst strext ;no, exit
movem t1,comptr ;yes, grab next bit
jrst strelp ;got to it !!!
;
; Check and exit
;
strext: bkptr t1 ;back up over non-+
move t2,[point 7,wrkstr] ;where the result is
retskp ;return success
;
; errors in string parsing
;
strex1: tmsg <
?IND - mismatched " in string constant:
>
call prtcmd
ret
strex2: tmsg <
?IND - unknown string symbol in expression:
>
call prtcmd
ret
strex3: tmsg <
?IND - system symbol in string expression is not of type string:
>
call prtcmd
ret
bdsubs: tmsg <
?IND - substring limits invalid: >
call prtcmd
ret
purge stxptr,qstrt,ssymvl
subttl Symbol table manipulation
;=======================================================
;
; These are the symbol table manipulation routines.
; They provide code for entering symbols into the tables,
; and performing table lookup. All are +1/+2 return type stuff,
; and the usual convention is to have a byte pointer in t1 to the
; symbol in ASCIZ, and have data returned in t2 (i.e. symbol value,
; or pointer to symbol value.)
;
;=========================================================
;
; entnum: enter a numeric symbol. t1- pointer to symbol name
; t2 - symbol value
;
entnum: movei t3,numsym ;address of numeric symbols
call entval ;get entval to do the work
ret
retskp
;
; luknum - lookup a numeric symbol - return +1 if not there, +2 if is
; input: t1/Pointer to symbol name
; output: t2/ Value of symbol if it exists
; t3/Position in table if exists
;
luknum: movem t1,t2
movei t1,numsym ;address of table
tbluk% ;look it up
ercal error ;table is screwed up
txnn t2,tl%exm ;exact match ?
ret ;no - return failure
hrre t2,(t1) ;yes - get value of symbol
move t3,t1 ;and position in table
retskp ;return success
;
; Entlgc: Enter logical symbol into table.
; Input: t1/Pointer to symbol name in ASCIZ
; t2/0 - true, -1 - false
; Calls entval - general entry routine
;
entlgc: movei t3,lgcsym ;address of logical table
call entval ;entval does the work
ret ;return failure
retskp ;return success
;
; LUKLGC: Lookup logical symbol, return value
; Input: t1/ Pointer to symbol name
;
; Output: t2/ Symbol value if +2 return, else
; +1 return, not found
;
; t3/ Address in TBLUK table of entry
;
luklgc: movem t1,t2
movei t1,lgcsym ;address of table
tbluk% ;look it up
ercal error ;table is screwed up
txnn t2,tl%exm ;exact match ?
ret ;no - return failure
hrre t2,(t1) ;yes - get value of symbol (extend sign)
movem t1,t3 ;and return entry address
retskp ;return success
;
; entstr - enter s string symbol into appropriate table
;
; Input: t1/ Pointer to symbol name
; t2/ Pointer to symbol value
; We have to do a bit of work with this one before we call entval
;
entstr: stkvar <ptr,strptr,strpos>
setzm sqzd ;indicate not squeezed yet
movem t1,ptr ;save name pointer
movem t2,strptr ;save value pointer also
movei t3,strspc ;max number of string chars
camg t3,nxtbyt ;already written that many ?
jrst strful ;yes, BOMB
entst1: move t1,strptr ;pointer to string
call leng ;get string length
skipge t3 ;string OK ?
jrst [tmsg <
?IND - string too long: >
call prtcmd ;print offending command
ret] ;return failure
move t1,nxtbyt ;size of string buffers in use
add t1,t3 ;what we want to add to it
cail t1,strspc ;will it overflow ?
jrst [call squeeze ;call garbage collector
jrst entst1]
move t1,nxtbyt ;get next byte in use
movem t1,strpos ;where string will be written
move t1,[point 7,strings] ;point to strings
adjptr t1,nxtbyt ;and now point to free store
addm t3,nxtbyt ;OK, bump amount of storage in use
aos nxtbyt ;add on null byte
move t2,strptr ;get string itself
setzb t3,t4 ;write until null byte
sout% ;write string
ercal error ;crash
move t1,ptr ;ask ENTVAL to put it in
move t2,strpos
movei t3,strsym
call entval
ret ;return failure
retskp ;return success
purge strpos,ptr,strptr
;
; Lookup string symbol
; Input: t1/ Pointer to symbol name
;
; Output: t2/ Pointer to symbol value if +2 return
; t3/ Position in symbol table if +2 return
;
; +1 return: Symbol not found
;
lukstr: movem t1,t2 ;put pointer in right place
movei t1,strsym ;point to string tables
tbluk% ;try to look it up
ercal error ;woops....
txnn t2,tl%exm ;exact match ?
ret ;no, return failure
movem t1,t3 ;save table address for caller
hrr t4,(t3) ;get byte number where string starts
move t2,[point 7,strings] ;point at string table
adjptr t2,t4 ;and adjust to point to relevant byte
retskp ;return success
;
; entlab - enter a label into table
; t1 - byte pointer to label name
; t2 - byte number in file to associate with it
;
entlab: stkvar <labnam,labbyt>
movem t1,labnam
movem t2,labbyt
call luklab ;look it up
skipa ;not there - put it in
retskp ;there - ignore it
move t1,labnam
move t2,labbyt
movei t3,labsym ;point to correct table
call entval ;enter value
ret ;fail
retskp ;succeed
purge labnam,labbyt
;
; luklab - lookup label i symbol table +1/+2 return
; input: t1/Byte pointer to label name
; Output: t2/ Value of label
; t3/ Position in symbol table
;
luklab: movem t1,t2 ;save pointer to label
movei t1,labsym ;point to label table
tbluk% ;lookup
ercal error ;tables are crapped up
txnn t2,tl%exm ;exact match ?
ret ;no - return failure
hrrz t2,(t1) ;yes - get value of symbol
move t3,t1
retskp ;return success
;
; LUKFIL - lookup file symbol in table, return JFN
; In: t1/ Pointer to symbol name
; Out: t2/ JFN
; t3/ Table address
;
lukfil: movem t1,t2 ;save
movei t1,filsym ;address of symbol table
tbluk% ;lookup
ercal error ;tables trashed
txnn t2,tl%exm ;match ?
ret ;no
hrrz t2,(t1) ;yes, get JFN
move t3,t1 ;address
retskp ;return success
;
; ENTFIL - enter file symbol.
; t1/ Pointer to symbol name
; t2/ JFN
;
entfil: movei t3,filsym ;address of table
call entval ;enter it
ret ;fail
retskp ;succeed
;
; LUKSYS - lookup a system symbol
; Input: t1/ Pointer to symbol name in ASCIZ
; Output: t2/ Value of symbol (Text string or immediate)
; t3/Symbol type code
;
luksys: movem t1,t2 ;put name in right place
movei t1,syssym ;address of table
tbluk% ;try a lookup
ercal error ;tables trashed
txnn t2,tl%exm ;exact match ?
ret ;no, return failure
hrrz t3,(t1) ;yes, get table entry
push p,t3 ;save entry for use by caller
hrrz t3,(t3) ;make routine address
call (t3) ;call the routine
pop p,t3 ;get back old copy of entry
hlrz t3,(t3) ;and leave the symbol type behind
cain t3,$str ;string type symbol returned ?
jrst [hrroi t2,sysval ;yes, point to it
jrst .+2]
move t2,sysval ;no, just get value
retskp ;return success
;
; Entval : Enter a general symbol into table, placing value in
; there also.
; Input: t1/ Pointer to synbol name in ASCIZ
; t2/ Value of symbol or stuff for left half of TBLUK entry.
; t3/ Table address
; +1/+2 return
;
entval: stkvar <namptr,value,tabnam>
movem t1,namptr
movem t2,value ;save arguments
movem t3,tabnam ;save table name
move t1,t3 ;tabel address
move t2,namptr ;name of symbol
tbluk% ;symbol already there ?
ercal error ;tables crapped up
txnn t2,tl%exm ;well ?
jrst entvl1 ;no, put it in properly
move t2,value ;yes, just put new value in
hrrm t2,(t1) ;at the address wher we found the oldun
retskp ;return success
entvl1: sosge free ;decrement number of entries in strings
jrst strful ;string space full - crash
movei t3,symtab ;address of string storage
add t3,nxtsym ;offset to next entry
hrro t1,t3 ;make byte pointer
move t2,namptr ;point to name string
movei t3,9 ;maximum of 9 bytes
setz t4, ;terminate on null
sout%
ercal error
setz t2, ;grab a null byte
idpb t2,t1 ;and bung that at the end
move t1,tabnam ;now bung the TBLUK entry in
movei t2,symtab ;address of string table
add t2,nxtsym ;where we put the entry
hrlzs t2,t2 ;put in left half
hrr t2,value ;and put value in left half
tbadd% ;enter into table
erjmp tberr ;table error - report
movei t1,2 ;its now safe to update the table entry
addm t1,nxtsym ;to reflect the new string
retskp ;return success
purge namptr,tabnam,value
;
; tabel error routines
;
strful: tmsg <
?IND - string storage full
>
ret ;return failure
tberr: tmsg <
?IND - symbol table full>
call errmes
ret ;return failure
IFDEF logg,<
SUBTTL Record username
;
; This routine makes a record of all users of IND
;
record: stkvar recjfn
movx t1,gj%sht!gj%old
hrroi t2,[asciz/PS:<KEVIN>IND-USERS.TXT/]
GTJFN%
erjmp recerr
movem t1,recjfn
movx t2,fld(7,of%bsz)!of%app
openf%
erjmp recerr
hrroi t2,[asciz/
User /]
setzb t3,t4
sout%
erjmp recerr
gjinf%
movem t1,t2
move t1,recjfn
dirst%
erjmp recerr
hrroi t2,[asciz / at /]
setzb t3,t4
sout%
erjmp recerr
seto t2,
setz t3,
odtim%
erjmp recerr
closf%
erjmp recerr
ret
recerr: tmsg <
%User logfile write failed, inform KEVIN:>
call errmes
ret>
subttl EXEC handler - lifted from CRCMD en mass.
;
; This subroutine has been taken direct from the CRC subroutine library.
; We need it here because we need to access some of its internal variables
; such as the fork handle of its inferior EXEC.
;
;
; The program is called from fortan as below :
;
; call crcmd('print file.dat/forms:la1',flags,jserr)
;
; from macro , pass a byte pointer in t1
; a flag word in t2, jsys error returned in t3
;
; The meaning of the flag word is as follows:
; 0 Do nothing unusual
; b35 (1) Use MEXEC instead of EXEC
; b34 (2) Allow echoing of commands
; b33 (OBSOLETE) (4)
; Do not release EXEC fork- freeze it, and check for existing
; fork on reentry
; b32 (8) Do not pass command to EXEC - merely run it and WFORK.
; b31 (16) Allow COMAND.CMD to be executed
; The strategy is to get the EXEC in a lower fork (natch), clear
; the input buffer, wait till output finishes, and lock the keyboard
; (send ^s). We then rename COMAND.CMD to COMAND.crcmd (to stop it
; being executed) and do STIs to get the stuff in, followed by a POP.
; We do a DIBE to wait for the time to put the POP in, and then WFORK.
; It may be necessary to do a KFORK after we give the command, to prevent
; errors in the command from clearing our typeahead.
;
define db(code),<ifdef $dbg,<code>>
; $dbg==0
c$cmd==20 ;COMAND.CMD no rename
cr==15
lf==12
ctrls==23 ;xoff
xon==21
xonoff==0 ;make 1 to use XON/XOFF processing
eatch1==40 ;char to be eaten (space)
eatch2==177 ;second eatable = delete
;
; PRARG argument block for EXEC
;
prargb: 4 ;number of words in block
1b0+3b6+2b12+cr%pra ;crjob prarg block
1b0+4
1b0+5
1b0
0
prblen==6
$crcmd: stkvar <cmdjfn,cmdptr,flgs,excjfn,exchnd,jfnwrd,ccoc1,ccoc2>
movem t1,cmdptr ;save pointer
movem t2,flgs ;save flgs
setzm exchnd
setzm cmdjfn
setzm excjfn ;zero before use !!
;
; Now save the JFN word and CCOC word
;
movei t1,.priin ;terminal
rfmod% ;get mode word
erjmp crerr
movem t2,jfnwrd ;save it
rfcoc% ;get ccoc word
erjmp crerr
movem t2,ccoc1 ;save first word
movem t3,ccoc2 ;and second
skipe efork ;got a frozen fork ?
jrst cont ;yes, thanks
;no, but I wouldn't mind one or two
move t2,flgs ;get flags back
txne t2,c$cmd ;COMAND.CMD desired ?
jrst nocom ;yes, skip next
db <tmsg <
%Renaming COMAND.CMD>>
movx t1,gj%sht+gj%old ;old file
hrroi t2,[asciz/COMAND.CMD/]
GTJFN% ;is there a COMAND.CMD available ?
erjmp nocom ;no, forget it
movem t1,cmdjfn ;yes, save the JFN
movx t1,gj%sht+gj%new+gj%fou ;new file
hrroi t2,[asciz/COMAND.crcmd/] ;saved filespec
gtjfn%
erjmp crerr ;failure
movem t1,t2 ;put arg in right place
move t1,cmdjfn ;get old JFN
rnamf% ;rename comand.cmd temporarily
erjmp crerr
movem t2,cmdjfn ;save the new JFN for later use
jrst crcmd1 ;comtinue
nocom: setzm cmdjfn ;indicate no COMAND.CMD
db <tmsg <
%No COMAND.CMD or not renaming>>
crcmd1: movei t1,.priou
dobe% ;wait for output to finish
jrst cont1 ;don't restore nonexistant JFN words
cont: movei t1,.priin ;point to terminal
move t2,cmdwrd ;get COMND JFN word
sfmod% ;set software mode
erjmp crerr
stpar% ;set hardware mode
erjmp crerr
move t2,cmdcc1 ;get old CCOC words
move t3,cmdcc2 ;and the next
sfcoc% ;set them also
erjmp crerr
cont1: movei t1,.priin
cfibf% ;clear any typeahead
IFN xonoff,<movei t1,ctrls ;get an xoff
pbout% ;and lock the keyboard
>
move t2,flgs ;give flag word
call mapexc ;get hold of a fork and an EXEC
jrst crerr ;error return
movem t1,excjfn ;save EXEC jfn
movem t2,exchnd ;and fork handle
move t1,flgs ;get flag word
txnn t1,e$cho ;echo desired ?
call noeco ;no
move t1,flgs ;get flags again
txne t1,p$ush ;a PUSH-type command wanted ?
jrst push ;yes, just do that then
db <tmsg <
%Simulating command input>>
move t3,cmdptr ;retrieve command pointer
movei t1,.priin ;point to input
comlop: ildb t2,t3 ;grab a byte
jumpe t2,crcmd2 ;if 0, end of command
sti% ;simulate input
jrst comlop ;go for next
crcmd2: movei t2,cr ;get carriage return
sti% ;input
movei t2,eatch1 ;and char to be eaten for detection
;of new command parse
sti% ;input
movei t2,eatch2 ;second eatable char to remove first
sti%
push: skipe efork ;continuing frozen fork ?
jrst [db <tmsg <
%Resuming frozen fork>>
move t1,efork ;yes, get handle
rfork% ;and resume fork operations
call tsfork ;test if we need an SFORK%
jrst crwait] ;wait for denoument
db <tmsg <
%Starting EXEC at entry vector>>
move t1,exchnd ;get the EXEC handle
setz t2, ;start at START
sfrkv% ;commence at normal entry vector
erjmp crerr
crwait: move t1,flgs ;get flags
txne t1,p$ush ;PUSH wanted ?
jrst [db <tmsg <
%Push and WFORK%>>
move t1,exchnd ;yes, get handle we just created
skipe efork
move t1,efork ;or a frozen one, if we have it
wfork% ;and wait for the EXEC
jrst crfin] ;it has POPped !
db <tmsg <
%DIBE/SIBE pair>>
movei t1,.priin ;specify input
sibe% ;skip if already empty
dibe% ;and dismiss until input buffer empty
movei t1,^d1000
disms% ;sleep for one second to allow error mes
;
; at this point, the input buffer is empty. This means that the EXEC has
; read our commmand, executed it, and read the following linefeed. Thus,
; it can now be killed.
; Alternatively, we have done a PUSH, and the EXEC has done a POP.
;
crfin: movei t1,.priin ;now find out what COMND has left the
rfmod% ;terminal like
erjmp crerr
movem t2,cmdwrd ;save COMMD word
rfcoc% ;get CCOC words
erjmp crerr
movem t2,cmdcc1 ;save first
movem t3,cmdcc2 ;and second
movei t1,.priin ;now reset things for our terminal
move t2,jfnwrd ;first the JFN word
sfmod% ;software bits
erjmp crerr
stpar% ;and hardware bits
erjmp crerr
movei t1,.priin ;now things to do with control chars
move t2,ccoc1
move t3,ccoc2 ;get both words back
sfcoc% ;and reset to what we had before
erjmp crerr
IFN xonoff,<movei t1,xon ;reallow terminal input
pbout%
>
db <tmsg <
Termination occurred>>
move t1,sysnm ;get our old name
setnm% ;set it
move t1,flgs ;get flags
txnn t1,e$cho ;was echo off ?
call eco ;yes, turn it on
setz t3, ;indicate no errors
move t1,exchnd ;get handle again
move t2,flgs ;get flags
skipn efork ;yes, got one ?
movem t1,efork ;remember newly acquired fork
move t1,efork ;get it back in case we didn't have it
ffork% ;freeze it
setzm waspsh
txne t2,p$ush ;did we do a push ?
setom waspsh ;yes, indicate that next call must SFORK
fgo: db <txne t2,p$ush
jrst [tmsg <
%Exec was pushed - setting flag>
jrst .+1]>
skipn cmdjfn ;anything to rename ?
ret ;no, just return
db <tmsg <
%Renaming COMAND files>>
movx t1,gj%sht+gj%fou ;new file
hrroi t2,[asciz/COMAND.CMD/] ;name to use
gtjfn%
erjmp crerr
movem t1,t2 ;save JFN for COMAND.CMD
move t1,cmdjfn ;retrieve JFN of COMAND.crcmd
rnamf% ;rename
trn
ret ;and return success
;
; This subroutine maps the EXEC into an appropriate fork
; It also sends the PRARG block to the fork
; called with t2=flags
; If frozen fork desired, and already have one, don't map
; Returns +1 error, +2 success with t1=JFN of EXEC, t2=fork handle
;
mapexc:getnm% ;get our program name
movem t1,sysnm ;save it
db <skipe efork
jrst [tmsg <
%Already have a fork - not mapping a new one>
jrst .+1]>
skipe efork ;yes, got one already ?
retskp ;yes, ta very much
db <tmsg <
%mapping new EXEC>>
setz t1, ;leave out that frozen trash - give me a FRESH fork!
cfork% ;create a fork
erjmp [ret]
movem t1,t4 ;save handle
movx t1,gj%sht+gj%old ;old file
movem t2,t3 ;save flags
hrroi t2,[asciz/SYSTEM:EXEC.EXE/] ;which is the EXEC
txne t3,m$exec ;MEXEC required ?
hrroi t2,[asciz/SYS:MEXEC.EXE/] ;yes
txnn t3,e$cho ;echo wanted ?
hrroi t2,[asciz/PS:<PACKAGES>CRCMD-EXEC.EXE/] ;no, suppress prompt
gtjfn% ;get a handle
erjmp [ret] ;return failure
movem t1,t3 ;save JFN
hrl t1,t4 ;place fork handle with JFN
get% ;map the EXEC to the fork
erjmp [ret] ;fail return
move t1,t4 ;get fork handle
hrli t1,.prast ;set arguments
movei t2,prargb ;address of argument block
push p,t3
movei t3,prblen ;length of arg block
prarg% ;specify argument block
erjmp [ret] ;failure
movei t1,.fhslf ;now discover our capabilities
rpcap% ;read them
erjmp [ret]
txz t2,sc%log ;make LOGOUT impossible
txz t3,sc%log ;and don't enable it
move t1,t4 ;get the fork handle
epcap% ;and set the EXEC's capabilities
erjmp [ret]
pop p,t3 ;restore ac
move t2,t4 ;place returned arguments in correct
move t1,t3
retskp ;return success
;
; These two routines turn terminal echoing on and off
;
noeco: setzm t3 ;indicate echo off
db <tmsg <
%echo off>>
skipa
eco: seto t3, ;indicate echo on
movei t1,.priin
rfmod% ;get terminal mode word
jumpe t3,eco1 ;echo off or on ?
txo t2,tt%eco ;on
skipa
eco1: txz t2,tt%eco ;off
sfmod% ;do whatever it is
ret ;back to caller
;
; Test is subsidiary is halted, and if so, SFORK it
;
tsfork:
db <skipn waspsh
jrst [push p,t1
tmsg <
%Exec was not pushed last time>
pop p,t1
jrst $db1]
push p,t1
tmsg <
%Exec was pushed last time>
pop p,t1
$db1:>
skipn waspsh ;pushed last time ?
ret ;no, just return
movem t1,t3 ;save fork handle
movei t1,^d500 ;1/2 second
disms%
move t1,t3 ;get handle again
rfsts% ;read fork status
db <push p,t1
push p,t2
push p,t3
movem t1,t2
movei t1,.priou
movx t3,^d10
nout%
erjmp [jshlt]
tmsg < was Fork status
>
pop p,t3
pop p,t2
pop p,t1>
db <tmsg <
%Continuing EXEC>>
move t1,t3 ;yes, get handle
txo t1,sf%con ;mark for continue
sfork% ;start
db <erjmp [tmsg <
%Error from SFORK>
jrst .+1]>
erjmp .+1 ;ignore error - process ws never started
ret
;
; errors come here
;
crerr:
IFN xonoff,<movei t1,xon ;reallow terminal input
pbout%
>
movei t1,flgs ;get flags
txnn t1,e$cho ;was echo off
call eco ;yes, turn it on
movei t1,.fhslf ;us
geter% ;get the error code
hrrz t3,t2 ;place in t3
ret ;and return
subttl Garbage collector for string storage
;
; This routine is called from ENTSTR whenever a new string would drop off
; the end of the string pool. Its operation is extremely primitive. As the
; string pool contains no back pointers (ie symbol names point to symbol
; values, but not vice versa) we just reconstruct the entire thing from
; scratch, using symbol table pointers and a second copy of the pool.
; When entered, we set a flag to say we have been. If this flag is set on
; entry, we consider it an error. It is the rsponsibility of the calling
; routine to clear the flag to prevent recursion.
;
squeeze: skipe sqzd ;already squezed ?
jrst [tmsg <
?IND - string space exhausted: recursive call to SQUEEZE.> ;yes
call prtcmd
jrst haltt] ;crash
stkvar <onxbyt,scptr,sval,savq1>
aos nsqzd ;increment times called
movem q1,savq1 ;save non-scratch AC
setom sqzd ;mark entry has occurred
move t1,nxtbyt ;get value of next free byte
movem t1,onxbyt ;remeber it
setzm nxtbyt ;zero out in preparation
hllz q1,strsym ;number of string symbols defined
movns q1,q1 ;negate
hrri q1,strsym+1 ;make aobjn pointer with first table ent
hrroi t1,strcpy ;point to string copies
squez1: move t2,[point 7,strings] ;point to strings
hrrz t3,(q1) ;get start byte of this string
adjptr t2,t3 ;construct pointer
movem t2,sval ;save pointer to source
setzb t3,t4 ;write until null
sout% ;move to copy space
ercal error
ibp t1 ;bump output past null
movem t1,scptr ;save output pointer
move t2,nxtbyt ;this is where we wrote the string
hrrm t2,(q1) ;so store it back in the table
move t1,sval ;get pointer to string we just wrote
call leng ;discover length
aoj t3, ;add on null byte
addm t3,nxtbyt ;increment space used
move t1,scptr ;reget output pointer
aobjn q1,squez1 ;loop through table
move t1,[strcpy,,strings] ;from,,to
blt t1,strings+<strspc/5>-1 ;transfer strings back to where they
move q1,savq1 ;came from, restore acs
ret
subttl String handling routines
;===========================================================
;
; These are the general string-handling routines. They generally
; accept a byte pointer to a source string in t1.
;
; LENG - computes length of ASCIZ string
; byte pointer in t1
; length returned in t3 - -1 if more than 256 chars
;
leng: setz t2, ;tell SEARCH to look for null
movei t3,^d256 ;max length acceptable
call search ;get search to do the work
ret
;
; SEARCH - byte pointer in t1
; character to search for in t2
; Maximum length in t3 (terminated on null also)
;
; Returns: Updated pointer in t1
; Position in t3, or -1 if not found.
;
search: movns t3,t3 ;negate count
hrlz t3,t3 ;place in left half,use right half for count
searc1: ildb t4,t1 ;get byte
camn t4,t2 ;character desired ?
jrst searc4 ;yes, exit
jumpe t4,searc3 ;null, exit with not found
aobjn t3,searc1 ;increment count, and loop if not all done
;
; If here, then we have found a null or dropped offf end without target
;
searc3: seto t3, ;indicate not found
ret ;return
searc4: hrrzs t3,t3 ;throw away index, leave character position
ret ;return
;
; getwrd - removes next word from string.
; accepts pointer in t1 to input string,
; pointer in t2 to area to output ASCIZ word.
;
getwrd: ildb t3,t1 ;get next byte
cain t3,"$" ;check for allowed special chars: $,<,>
jrst getwr2 ;yes, is $
cain t3,"<"
jrst getwr2 ;yes, is "<"
cain t3,">" ;yes, is "<"
jrst getwr2
caig t3,"/" ;at least numeric ?
jrst getwr1 ;no, end of word
txo t3,40 ;ok, safe to force lower case
caile t3,"z" ;not a funny char ?
jrst getwr1 ;funny char
caig t3,"9" ;numeric ?
jrst getwr2 ;definitely - Ok
caig t3,"@" ;in between number and letter ?
jrst getwr1 ;yes - end of word
getwr2: idpb t3,t2 ;no, dump character
jrst getwrd ;and get next
getwr1: setz t3, ;get a null byte
idpb t3,t2 ;dump that too
bkptr t1 ;backup pointer to valid byte
ret ;return
;
; isdgt - called with character in t2, returns +2 if digit, else
; +1
;
isdgt: cain t2,"-" ;minus sign ?
retskp ;yes, OK
caige t2,"0" ;at least 0 ?
ret ;nope
caile t2,"9" ;at most 9 ?
ret ;nope
retskp ;yes
;
; skpblk - skips over blanks and tabs
; byte pointer to string in t1
;
skpblk: ildb t2,t1 ;get next byte
jumpe t2,skpbl1 ;return on null
cain t2," " ;space ?
jrst skpblk ;yes
cain t2," " ;tab ?
jrst skpblk ;yes
skpbl1: bkptr t1 ;backspace byte pointer
ret ;and return
;
; ASCSIZ - accepts byte pointer in t1 to ascii string, encodes
; 6 chars into SIXBIT word in t2
;
ascsix: setz t2, ;zero out SIXBIT word
movei t4,6 ;initialize loop count
ascsi1: ildb t3,t1 ;get byte
subi t3,40 ;convert to sixbit
skipge t3 ;still a character ?
setz t3, ;no, convert to space
lsh t2,6 ;shift current word six bits left
or t2,t3 ;and in extra byte
sojg t4,ascsi1 ;loop six times
ret ;back to caller
end <3,,entvec>