Trailing-Edge
-
PDP-10 Archives
-
tops10and20_integ_tools_v9_3-aug-86
-
tools/crc/browse/maccmd.mac
There are no other files named maccmd.mac in the archive.
; GTASCZ trashes lots of acs. make sure we know this when we call it.
;<KEVIN>MACCMD.MAC.2, 26-Oct-84 11:44:51, Edit by KEVIN
; Add the KYALOW and KYDALW routines to modify the standard breakset.
;<MICROBIOLOGY-ARCHIVES>MACCMD.MAC.2, 23-Aug-84 15:37:27, Edit by KEVIN
;TEXTIN was failing to accept null strings (again....). Outputting
;confirm message instead. Moral : skip instructions don't skip
;macros very well.
;<CRC-SUBS>MACCMD.MAC.?, 15-Jun-84 14:48:05, Edit by Geoff
; Allow for Fortran 77 character variables in the output fields.
;<KEVIN>MACCMD.MAC.2, 21-May-84 15:08:05, Edit by KEVIN
; Try to make most routines return an answer even if it is dubious (ie make
; NUMIN and friends return a number, even if it is out of range.)
;<KEVIN>MACCMD.MAC.100010, 21-Oct-83 14:35:31, Edit by KEVIN
; Make KYWORD return different errors on ambiguous/not known
;<RT11.CANADA>MACCMD.MAC.100021, 19-Oct-83 13:10:57, Edit by KEVIN
; When adding entries with TABLE, don't use string space if error occurs.
;12-sep-83 Edit by Kevin
; Introduce a compile time switch to avoid loading FOROTS stuff.
;15-Aug-83 Edit by Kevin
; Make even more sure than before - chain a confirm block
;11 Aug 83 Edit by Kevin
; Make SURE that TEXTIN accepts a blank line as input
;8 jun 83 Edit by Kevin
; Make errors type out "?" before bell, not after, so they trap in batch.
;<KEVIN>MACCMD.MAC, 23-May-83 14:00, EDIT BY KEVIN
; Not all strings trapped. Also, TBLOOK not trimming blanks OK.
;<KEVIN>MACCMD.MAC, 10-May-83 09:27:00, EDIT BY Geoff
; allow for fortran v7 strings.
;<KEVIN>MACCMD.MAC, 10-Feb-83 10:37:00, EDIT BY KEVIN
;COMND does not return count of characters in atom buffer when a default
;is taken with .CMTXT - must provide routine to count string length
;<KEVIN>MACCMD.MAC.100047, 18-Jan-83 11:53:40, EDIT BY KEVIN
; Add functionality which suppresses recognition of EXIT and
; UNKNOWN via common block flag.
title maccmd - COMND routines for FORTRAN.
;
; This set of routines is designed to give the Fortran programmer
; limited access to the facilities of the COMND JSYS. They provide
; for parsing commands consisting of a single field, with a supplied
; prompt, and are intended to be used in an on-line questionarre
; environment. Greater control is available to the user via common
; blocks which are used for storage by these routines, and can be
; modified from Fortran.
; Routines are also available for manipulating TBLUK tables, independantly
; of their use with COMND%.
;
search vtmac
regdef ;declare registers, search MONSYM, etc.
;
; Macro to define offsets for a fortran argument list
;
; FORARG(arg1,arg2,arg3)
; defines arg1=0
; arg2==1, etc.
; Also defines cleararg to purge all the rest, and does this before each
; setup.
;
DEFINE FORARG(ARGLST),<
IFDEF $ARGCNT, <NOARGS> ;;clear previous argument definitions
DEFINE NOARGS, <PURGE ARGLST> ;;set up a new clear macro
$ARGCNT==0 ;;initialize count of arguments
IRP ARGLST,<$FARG ARGLST>
> ;now define the arguments
DEFINE $FARG(ARG),<
ARG==$ARGCNT
$ARGCNT==$ARGCNT+1>
;
; Macro to generate definitions of error numbers and error messages
;
; ERRDEF(SYMBOL,VAL,TEXT)
;
DEFINE ERRORS,<
errdef(errsuc,0,<Success - no error>)
errdef(errgen,1,<Invalid input>)
errdef(errcfm,2,<Superfluous input at end of field>)
errdef(errhnm,3,<Hospital number does not look right>)
errdef(errhcl,4,<Check letter does not match patient number>)
errdef(errdat,5,<Not a valid date>)
errdef(errdtr,6,<Date not in range>)
errdef(errnum,7,<That is not a number>)
errdef(errnsm,8,<That number is too small>)
errdef(errnlg,9,<That number is too large>)
errdef(errsex,^d10,<Male, Female or unknown required>)
errdef(erryes,^d11,<Yes, No or unknown required>)
errdef(errful,^d12,<Table is full>)
errdef(errmul,^d13,<Entry is already in table>)
errdef(errfil,^d14,<Invalid file name>)
errdef(errstl,^d15,<Text field too long>)
errdef(errnsk,^d16,<Entry is not in table>)
errdef(erramk,^d17,<Ambiguous keyword>)
errdef(errtim,^d18,<Not a valid time>)
errdef(errtmr,^d19,<Time not in range>)
>
;
; Define error symbols
;
DEFINE ERRDEF(SYM,VAL,TXT),<SYM==VAL>
ERRORS ;do it
;
; Macro to print error message associated with a number
;
; ERRMES error
;
DEFINE ERRMES(ERROR,RETURN<>,FAILAD<>,%a),<
xlist
call tstcol ;;get a new line if needed
skipge tried ;;user supply a retry count ?
jrst %a ;;no, so repeat forever until correct
sosl tried ;;yes, so knock one off the count
jrst %a ;;still non--ve, so allow another go
movei t1,error ;;get general error code
IFB <FAILAD>,<movem t1,@fail(cx)> ;;return to caller
IFNB <FAILAD>,<movem t1,@failad> ;;via special loc if appropriate
ret ;;and return properly
%a: tmsg <?> ;;look querulous
movei t1,7 ;;ring terminal bell
pbout% ;;with ^G = ascii 7
hrro t1,errtab+error ;;get address of message
psout% ;;type it
IFNB <RETURN>,< ;;if a retry address is specified...
tmsg <, try again please> ;;ask them to do it again
jrst return> ;;and go and repeat question
list > ;;else let routine handle retry itself
;
; Macro to confirm a command
;
; CONFIRM erradr ;jump to erradr if bad confirm, errors
; are to be trapped
DEFINE CONFIRM(erradr),<call endcom
jrst [movei t1,erradr ;;get address of reprompt
movei q1,@fail(cx) ;;get address of fail code
call cfmerr ;;jump to error type routine
ret ;;error return
jrst .+1] ;;returned ok
>
;
; Macro to set up whether we use the EXIT and UNKNOWN tables.
;
DEFINE SETEXT,<
movei t1,exifdb ;;assume chain to EXIT/UNKNOWN table
skipe useext ;;is that what the user wants ?
movei t1,fdb ;;no, chain straight to function-specific fdb
hrrm t1,bakfdb ;;and store in token fdb
>
;
; Macro for the MOVSLJ extended instruction.
;
DEFINE MOVCHA (acc,filcha<" ">,skop<nop>),<
extend acc, [movslj 0,0
filcha ]
skop ;;ignore truncation if nop
>
;
bufsiz==^d70 ;number of words in command buffer
atmsiz==bufsiz ;words in atom buffer (^d70)
fdbsiz==.cmbrk+1 ;size of FDB (5)
hlpsiz==^d25 ;size of help message
defsiz==^d56 ;size of default text
gjfsiz==.gjrty+3 ;size of gtjfn block used by comnd jsys (15)
argsiz==5 ;size of forots argument block
deflen==defsiz*5 ;size of default buffer in characters
.common CMDSTG[bufsiz+atmsiz+fdbsiz+hlpsiz+defsiz+gjfsiz+argsiz]
.common cmdprm[14+.cmgjb+1]
atmbfr=cmdstg+bufsiz ;address of atom buffer
fdb=atmbfr+atmsiz ;address of current FDB
hlpbfr=fdb+fdbsiz ;address of help message
defbfr=hlpbfr+hlpsiz ;address of storage for default string
gjfblk=defbfr+defsiz ;address of gtjfn% argument block
argblk=gjfblk+gjfsiz ;address of forots argument block
cmdblk=exilab+5 ;address of command state block
initf=cmdprm ;non-zero word if cmdblk INITed
retrys=initf+1 ;address of number of retries to be allowed
tried=retrys+1 ;number of attempts left on this field
endnse=tried+1 ;non zero means disallow confirm errors
raise=endnse+1 ;if non-zero, raise input
savret=raise+1 ;place to save return address for CMDINI
savp=savret+1 ;place to save stack pointer for reparse
exilab=savp+1 ;label to return to after "exit"
useext=exilab+1 ;flag to recognise EXIT and UNKNOWN
nargs=p1 ;number of arguments stored in this register
;
; Now generate the table of error messages
;
DEFINE ERRDEF(symbol,val,text),<[ASCIZ\text\]>
errtab: errors ;construct the table
;
; Define breaksets for .CMKEY and .CMDAT functions, to include
; things like "." as allowable characters in the field. The keyword
; brek table can be modified by KYALOW and KYDALW
;
datbrk: brmsk. (fldb0.,fldb1.,fldb2.,fldb3.,<.,< >,<,>,</>,:>)
brkmsk: brmsk. (keyb0.,keyb1.,keyb2.,keyb3.,<.,#,< >,<(>,<)>,</>,:,<'>,%,*>)
defbrk: brmsk. (keyb0.,keyb1.,keyb2.,keyb3.,<.,#,< >,<(>,<)>,</>,:,<'>,%,*>)
;
; set up fdb's for exit and backup (^)
;
bakfdb: fld(.cmtok,cm%fnc)!cm%sdh!exifdb
<point 7,[byte(7) "^"]>
z
z
exifdb: flddb.(.cmkey,cm%sdh,exitbl,,,fdb)
exitbl: 2,,2
[asciz/exit/],,exit
[asciz/unknown/],,unknow
;
; Make requests for external routines, and declare our entry points
;
IFNDEF $MACY,<external crhalt,open.,ftncmd>;clean fortran exit routine,and forots open
external gtbypt,gtadrs,gtascz,ptspac ;allow fortran v7 text
entry textin,hospno,datein,realin,table ;Fortran-callable routines
entry kyword,sexin,numin,yesno,tblook,tbrloc,timein
entry kyalow,kydalw
IFNDEF $MACY,<entry cropen>
IFNDEF $MACY,<
subttl CROPEN - read a file name and open it
; Routine to read a text field
;
; CALL CROPEN(PROMPT,UNIT,STATUS,FAIL[,HELP[,DEFNAM[,DEFEXT
; [,DEFDIR[,DEFDEV[,OPTION]]]]]])
;
; prompt - ASCIZ prompt string
; unit - fortran logical unit number
; status - file type key word e.g. 'OLD' 'NEW' etc.
; fail - 0 if ok, else +ve
; length - number of characters typed, optional
; help - ASCIZ help text for ?, optional
; defalt - ASCIZ default answer, optional
; defnam - the default file name
; defext - the default file extension
; defdir - the default directory
; defdev - the default device
; option - further options as specified to 'DIALOG='
;
forarg <prompt,unit,status,fail,help,defnam,defext,defdir,defdev,option>
sixbit /cropen/
cropen: setzm @fail(cx) ;indicate no error
move t2,retrys ;get users retry count
movem t2,tried ;save count for this field
croprp: movei t1,prompt ;pointer to prompt
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@prompt(cx) ;point to first argument
call cmdini ;initialize COMND
;
;set up gtjfn% argument block
;
move t1,[gjfblk,,gjfblk+1] ;set up to clear gtjfn block
setzm gjfblk ;clear first word of block
blt t1,gjfblk+gjfsiz-1 ;clear gtjfn block
movei t1,status ;pointer to status
;* call gtbypt ;may be fortran v7
call gtascz ;may be fortran v7
move t2,t1
;* movx t2,<point 7,0,6> ;set up for byte pointer
;* hrri t2,@status(cx) ;get status, 'OLD' or 'NEW' file ?
ildb t3,t2 ;get first character of specifier
txz t3,40 ;ensure upper case
cain t3,"N" ;is it N ?
jrst [movx t1,gj%fou+gj%cfm+gj%xtn
jrst cropst] ;want a new file & ext. arg block etc.
cain t3,"O" ;is it O ?
jrst [movx t1,gj%old+gj%cfm+gj%xtn
jrst cropst] ;want existing file & ext. arg block
movx t1,gj%cfm+gj%xtn ;want any file & ext. arg block etc.
cropst: movem t1,gjfblk+.gjgen ;store flags
movx t1,<.priin,,.priou> ;i/o from tty:
movem t1,gjfblk+.gjsrc ;store source
caig nargs,defnam ;is argument there?
jrst croext ;no, so skip
skipn @defnam(cx) ;user supplied default ?
jrst croext ;no, so indicate no default
movei t1,defnam ;pointer to default name
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@defnam(cx) ;get default file name
movem t1,gjfblk+.gjnam ;store default name
croext: caig nargs,defext ;is argument there?
jrst crodir ;no, so skip
skipn @defext(cx) ;user supplied default ?
jrst crodir ;no, so indicate no default
movei t1,defext ;pointer to default extension
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@defext(cx) ;get default extension
movem t1,gjfblk+.gjext ;store default extension
crodir: caig nargs,defdir ;is argument there?
jrst crodev ;no, so skip
skipn @defdir(cx) ;user supplied default ?
jrst crodev ;no, so indicate no default
movei t1,defdir ;pointer to default directory
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
ibp ,t1 ;skip the opening bracket
;* movx t1,<point 7,0,6> ;set up for byte pointer
;* hrri t1,@defdir(cx) ;get default directory
movem t1,gjfblk+.gjdir ;store default directory
crodev: caig nargs,defdev ;is argument there?
jrst crofor ;no, so skip
skipn @defdev(cx) ;user supplied default ?
jrst crofor ;no, so indicate no default
movei t1,defdev ;pointer to default device
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@defdev(cx) ;get default device
movem t1,gjfblk+.gjdev ;store default device
crofor: movx t1,gjfsiz-.gjf2-1 ;calculate length of extended block
movem t1,gjfblk+.gjf2 ;store flag
;
; gtjfn block now set up, so get comnd to get the file name
;
movei t1,gjfblk ;get address of gtjfn block
movem t1,cmdblk+.cmgjb ;store pointer to gtjfn block
setzm fdb+.cmdef ;defaults not in cmdblk but gjfblk
setzm fdb+.cmbrk ;no fancy break mask please
move t1,[fld(.cmfil,cm%fnc)!cm%sdh!cm%hpp] ;get function
;indicate a help message is supplied
cropi1: movem t1,fdb ;store function code, flags
setzm fdb+.cmdat ;no func-specific data
hrroi t1,[asciz/file name/] ;help message
caig nargs,help ;help argument ?
jrst cropnh ;no, so don't store
skipn @help(cx) ;is it null ?
jrst cropnh ;yes, so skip
movei t1,help ;pointer to help message
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@help(cx) ;no, get users help
cropnh: movem t1,fdb+.cmhlp ;yes, so store it
cropi2: movei t1,cmdblk ;point to command state block
movei t2,fdb ;point to function block
comnd% ;parse a file name
erjmp cmderr ;die
movei t4,@fail(cx) ;get address of fail flag for chpars
call chpars ;check on which fdb used to parse
jrst croerr ;fail, so try for error handling
move t4,t2 ;save jfn for a mo'
confirm croprp ;confirm command
;
;get the file info about the jfn
;
setz t3, ;use default format for name
movei t1,status ;pointer to status
call gtbypt ;may be fortran v7
move t2,t1
;* movx t2,<point 7,0,6> ;set up for byte pointer
;* hrri t2,@status(cx) ;get status, 'UNKNOWN' ?
ildb t1,t2 ;get first character of specifier
txz t1,40 ;ensure upper case
cain t1,"U" ;is it U ?
movx t3,fld(.jsssd,js%dev)!fld(.jsssd,js%dir)!fld(.jsaof,js%nam)
!fld(.jsaof,js%typ)!js%paf
;don't output generation no. if unknown
move t2,t4 ;move returned jfn
hrroi t1,defbfr ;address to send file name to
jfns% ;get the name
erjmp cmderr ;die
;
;release the jfn as we are not going to use it
;
move t4,t1 ;save the byte pointer
move t1,t2 ;jfn to acc 1
rljfn%
jrst cmderr ;die
;
;append options to filename
;
caig nargs,option ;option argument ?
jrst cropar ;no, so don't store
skipn @option(cx) ;is it null ?
jrst cropar ;yes, so skip
movei t1,option ;pointer to options
push p,t4 ;save pointer to string end
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@option(cx) ;no, get pointer to options
pop p,t2 ;get pointer to end of name
setz t3, ;terminate on null
sin% ;move the characters
;
;now try and open the file, first set up argument block
;
cropar: move t1,[argblk,,argblk+1] ;set up to clear arg block
setzm argblk ;clear first word of block
blt t1,argblk+argsiz-1 ;clear arg block
movei t4,argblk ;get argument block address
cropac: aoj t4, ;start at second word
movei t1,defbfr ;get pointer to the filename
txo t1,1b8!17b12 ;set "G" field to 1 i.e. long filename
movem t1,(t4) ;store in argument block
aoj t4, ;next word of argument block
movei t1,status ;want address of status
call gtadrs ;may be fortran v7
;* movei t1,@status(cx) ;get pointer to the status
txo t1,33b8!17b12 ;set "G" field to 33 i.e. status
movem t1,(t4) ;store in argument block
aoj t4, ;next word of argument block
move t1,@unit(cx) ;get pointer to the unit number
txo t1,36b8 ;set "G" field to 36 i.e. unit(error in manual?)
movem t1,(t4) ;store in argument block
aoj t4, ;next word of argument block
movei t1,@fail(cx) ;get pointer to the fail flag
txo t1,21b8 ;set "G" field to 21 i.e. iostat word
movem t1,(t4) ;store in argument block
subi t4,argblk ;get length of argument block
movn t1,t4 ;set up negve size of argument block
hrlzm t1,argblk ;and store in first word
push p,cx ;save old arg block
movei cx,argblk+1 ;give forots the argument block, 2nd word
call open. ;and open the file
pop p,cx ;restore old arg. block
call ptspac ;release f77 string space
ret ;return
croerr: errmes errfil ;issue general error, try again
tmsg <, >
movx t1,.priou ;message to terminal
hrloi t2,.fhslf ;last error, this fork
setz t3, ;no limit on length
erstr% ;print last jsys error message
nop
nop ;ignore error in errors
tmsg <, please try again>
jrst croprp ;try again
> ;IFNDEF $MACY
subttl TEXTIN - read arbitrary text field
;
; Routine to read a text field
;
; CALL TEXTIN(PROMPT,ANSWER,FAIL[,BACK[,LENGTH[,HELP[,DEFALT]]])
;
; prompt - ASCIZ prompt string
; answer - ASCIZ returned text, typed by user
; fail - 0 if ok, else +ve
; back - label to return to on getting "^"
; length - number of characters typed, optional
; help - ASCIZ help text for ?, optional
; defalt - ASCIZ default answer, optional
;
; If, on entry, the first word of ANSWER contains a non-zero number
; less than the size of the atom buffer, we assume that it is a maximum
; length of text string. In this case, an error will be issued if the user
; types more than this.
;
forarg <prompt,answer,fail,back,length,help,defalt>
sixbit /textin/
textin: setzm @fail(cx) ;indicate no error
move t2,retrys ;get users retry count
movem t2,tried ;save count for this field
setz p2, ;assume no maximum length
movx t1,answer ;is answer a f77 character variable?
call gtbypt ;get its byte pointer and length
skipg t2 ;if length > 0 then f77
jrst [move t2,@answer(cx) ; get possible max length (f66)
setzm ,@answer(cx) ; clear the first element of the count
jrst .+1 ] ; and continue
skiple t2 ;if not +ve, ignore
caile t2,atmsiz*5 ;check less than atom buffer size
skipa ;no, so do nothing
movem t2,p2 ;seems valid, use it
textrp: movei t1,prompt ;point to the prompt
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@prompt(cx) ;point to first argument
call cmdini ;initialize COMND
move t1,[fld(.cmtxt,cm%fnc)![flddb. (.cmcfm,cm%sdh)]] ;get function
txo t1,cm%sdh!cm%hpp ;indicate a help message is supplied
movem t1,fdb ;store function code, flags
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!exifdb
;get default flags
movem t2,bakfdb ;and store
caile nargs,length ;did user ask for string length ?
setzm @length(cx) ;yes, clear in case of error
setzm fdb+.cmdef ;indicate no default
caig nargs,defalt ;number of arguments indicate default ?
jrst texti1 ;no, so don't supply one
skipn defalt(cx) ;user supplied default ?
jrst texti1 ;no, so indicate no default
skipn @defalt(cx) ;is the default null ?
jrst texti1 ;yes, so skip this
movx t2,cm%dpp ;no, so get flag that indicates default
iorm t2,bakfdb ;and light it
movei t1,defalt ;point to the default
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t2,@defalt(cx) ;get a byte pointer to it
movem t1,bakfdb+.cmdef ;and store in the fdb
texti1: setzm fdb+.cmdat ;no func-specific data
hrroi t1,[asciz/text/] ;help message
caig nargs,help ;help argument ?
jrst textnh ;no, so don't store
skipe @help(cx) ;is it null ?
movei t1,help ;argument offset
call gtascz ;may be fortran v7
;* call gtbypt ;construct byte pointer
;* hrroi t1,@help(cx) ;no, get users help
textnh: movem t1,fdb+.cmhlp ;yes, so store it
texti2: SETEXT ;decide whether to use EXIT/UNKNOWN
movei t1,cmdblk ;point to command state block
movei t2,bakfdb ;point to function block
comnd% ;parse arbitrary text
erjmp cmderr ;die
movei t4,@fail(cx) ;get address of fail flag for chpars
setz q3,@answer(cx) ;DON'T get the address of the answer for chpars
setz q2, ;clear return address
caig nargs,back ;alternate return given ?
jrst textch ;no, so skip
skipe @back(cx) ;is it zero ?
movei q2,@back(cx) ;no, get return address if "^" entered
textch: call chpars ;check on which fdb used to parse
jrst txterr ;fail, so try for error handling
call atmlen ;get length of buffer, COMND fails to
;return a count if the default was used
caile nargs,length ;did user ask for string length ?
movem t1,@length(cx) ;yes, give user length of field
jumpn p2,[camg t1,p2 ;if supplied max length, is it exceeded
jrst .+1 ;no, so continue
errmes errstl,textrp] ;yes, complain and reparse
push p,t1 ;save count
;* hrroi t1,@answer(cx) ;and to callers array for answer
movx t1,answer ;want pointer to caller's array
call gtbypt ; may be f77 character
caig t2,0 ;a length of 0 means f66
jrst [hrroi t2,atmbfr ;point to user's answer
setzb t3,t4 ;terminate writing on null
sout% ;and copy answer to caller's buffer
pop p,t1 ;restore count
jrst txtret] ;and continue
;
;set up the block of accumulators for the movslj instruction, with blank fill
;
; _________________________________
; t1 | 000 | source string length |
; t2 |{ source string byte ptr }|<- atmbfr
; t3 |{ }|
; t4 | 000 | dest. string length |<
; q1 |{ dest. string byte ptr. }|<- from gtbypt
; q2 |{ }|
; ---------------------------------
;
move t4,t2 ;get destination length, from gtbypt.
move q1,t1 ;get destination pointer
move t1,(p) ;restore source length from stack
move t2,[point 7,atmbfr] ;get source pointer
movcha t1, ;move string with blank fill (MACRO)
pop p,t1 ;restore length
;
txtret: jumpe t1,txtrt1 ;was it non-zero ?
confirm textrp ;yes, so confirm command
txtrt1: call ptspac ;return f77 scratch string space
ret ;no problems, so return
;
; Here on parse error
;
txterr: errmes errgen,textrp ;issue general error, try again
;
; Here to get length of user string
;
ATMLEN: move t2,[point 7,atmbfr] ;point to buffer
setz t1, ;zero length count
atmln1: ildb t2 ;get a byte
skipn t1 ;first char ?
caie 15 ;yes, is it return ?
skipa ;no, just check for nulls
ret ;yes, first char = space means null
skipn 0 ;was it zero ?
ret ;yes, return length
aoja t1,atmln1 ;no, increment count and loop
subttl HOSPNO - read a hospital number
;
; This routine is called to read a hospital number.
; CALL HOSPNO(PROMPT,HOSNUM,LETTER,FAIL[,BACK[,HELP[,DEFALT]]])
;
; HOSNUM - integer returned hospital number
; LETTER - Check character returned as A1
; FAIL - 0 on success, 1 on general error, 2 on confirm error,
; 3 indicates number is bad, 4 indicates check letter does not
; match.
; BACK - label to return to on getting "^"
;
FORARG <PROMPT,HOSNUM,LETTER,FAIL,BACK,HELP,DEFALT>
;
; Generate table of hospital check letters
;
hoslet: "A"
"B"
"D"
"E"
"F"
"H"
"J"
"K"
"L"
"M"
"N"
"P"
"R"
"S"
"T"
"V"
"X"
sixbit /hospno/
hospno: setzm @fail(cx) ;indicate no error initially
move t1,retrys ;get number of retries
movem t1,tried ;store as number of tries
hosprp: movei t1,prompt ;Point to prompt argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t1,@prompt(cx) ;point to prompt
call cmdini ;initialize COMND
setzm bakfdb+.cmdef ;no pointer for default yet
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!exifdb
;clear default flag in bakfdb
movem t2,bakfdb ;and store
caig nargs,defalt ;default supplied ?
jrst hospn1 ;no, skip this
skipn defalt(cx) ;address ok ?
jrst hospn1 ;no, so still skip it
skipn @defalt(cx) ;zero default ?
jrst hospn1 ;yes, so forget the lot
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!cm%dpp!exifdb
;set default flag in bakfdb
movem t2,bakfdb ;and store
movei t1,defalt ;Point to default argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t2,@defalt(cx) ;point to user's default
movem t1,bakfdb+.cmdef ;store in function descriptor block
hospn1: movx t1,fld(.cmtxt,cm%fnc)!cm%sdh!cm%hpp
;parse as text, indicate our help is present
movem t1,fdb ;store function descriptor block
setzm fdb+.cmdat ;no function data for this
hrroi t1,[asciz/Hospital number/] ;get default help text
caig nargs,help ;enough args for a help message ?
jrst hospn2 ;no, use ours
skipn help(cx) ;do we have an address for the help ?
jrst hospn2 ;no, use ours
skipn @help(cx) ;is the help null ?
jrst hospn2 ;yes, use ours
movei t1,help ;Point to help argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t1,@help(cx) ;no, so use theirs
hospn2: movem t1,fdb+.cmhlp ;store pointer to help message
SETEXT ;decide whether to use EXIT/UNKNOWN
movei t1,cmdblk ;point to command state block
movei t2,bakfdb ;and descriptor for this field
comnd% ;parse the number + letter
erjmp cmderr ;die badly
movei t4,@fail(cx) ;get address of fail flag for chpars
movei q3,@hosnum(cx) ;get the address of the answer for chpars
setz q2, ;clear return address
caig nargs,back ;alternate return given ?
jrst hospch ;no, so skip
skipe @back(cx) ;is it zero ?
movei q2,@back(cx) ;no, get return address if "^" entered
hospch: call chpars ;check on which fdb used to parse
jrst hsperr ;fail, check for retries
hrroi t1,atmbfr ;point to the atom buffer
movx t3,^d10 ;set up to read a decimal number
nin% ;do it
erjmp hsbadn ;bad number format, complain
movem t1,q1 ;save the input pointer
movem t2,@hosnum(cx) ;store hospital number for user
idivi t2,^d17 ;now get the number mod 17
move t4,hoslet(t3) ;get the correct check letter
ldb 0,t1 ;get the check letter supplied by user
txz 0,40 ;force upper case
lsh 0,^d29 ;convert to a1
lsh t4,^d29 ;convert to a1
movx t1,letter ;get pointer to letter
call gtbypt ;may be f77 character
skipn t2 ; f66 if length is 0
jrst [movem 0,@letter(cx) ; yes return the character
jrst hspchk ]
push p,t4 ;no save the correct letter
;
;set up the block of accumulators for the movslj instruction, with blank fill
;
; _________________________________
; t1 | 000 | source string length |
; t2 |{ source string byte ptr }|<- the letter in ac 0
; t3 |{ }|
; t4 | 000 | dest. string length |<
; q1 |{ dest. string byte ptr. }|<- from gtbypt
; q2 |{ }|
; ---------------------------------
;
dmove t4,t1 ;get destination length, from gtbypt.
exch t4,q1 ;...get destination pointer
dmove t1, [1 ;1 character in source
point 7,0 ] ;make source pointer to ac 0
movcha t1, ;move string with blank fill (MACRO)
pop p,t4 ;restore the correct letter
;
hspchk: came 0,t4 ;are the letters equal ?
jrst hsbadl ;no, complain
confirm hosprp ;yes, confirm command
call ptspac ;return f77 string space
ret ;return to caller
;
; Errors in HOSPNO
;
hsperr: errmes errgen,hosprp ;issue general error
hsbadn: errmes errhnm,hosprp ;error is bad number
hsbadl: errmes errhcl,hosprp ;error is bad letter
subttl DATEIN - read a date in variable-type format
;
; Yet again, this is read as a text field, because of problems with
; setting the format used by COMND to read dates.
;
; CALL DATEIN(PROMPT,JULIAN,FAIL[,BACK[,LOWER[,UPPER[,HELP[,DEFALT]]]]])
;
; PROMPT - promptiny string in ASCIZ
; JULIAN - Returned julian day number for date entered
; FAIL - 0 is success, else bad date format, else not in range
; BACK - label to return to on getting "^"
; LOWER - lower limit, ignored if 0 (optional)
; UPPER - upper limit, ignored if 0 (optional)
; HELP - ASCIZ help message, ignore if 0 (optional)
; DEFALT - default date, ignored if 0 (optional)
; Lower, upper and default are all supplied as Julian day numbers.
;
FORARG <PROMPT,JULIAN,FAIL,BACK,LOWER,UPPER,HELP,DEFALT>
JTOS=^D2400001 ;convert smithsonian day to Julian
sixbit /datein/
datein: setzm @fail(cx) ;no errors yet
move t1,retrys ;get number of retries
movem t1,tried ;store it
daterp: movei t1,prompt ;Point to prompt argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t1,@prompt(cx) ;point to prompt
call cmdini ;initialize
setzm bakfdb+.cmdef ;no pointer for default yet
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!exifdb
;clear default flag in bakfdb
movem t2,bakfdb ;and store
move t1,[fld(.cmfld,cm%fnc)!cm%brk!cm%sdh!cm%hpp] ;parse as field, use breakset
;indicate our help is present
movem t1,fdb ;store them
caig nargs,defalt ;default supplied ?
jrst datei1 ;no, skip this
skipn defalt(cx) ;address ok ?
jrst datei1 ;no, skip this
skipn @defalt(cx) ;is default 0 ?
jrst datei1 ;yes, skip this again
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!cm%dpp!exifdb
;set default flag in bakfdb
movem t2,bakfdb ;and store
move t2,@defalt(cx) ;get the default julian day number
sub t2,[jtos] ;and turn to smithsonian day number
hrlzs t2,t2 ;then put in right half
hrroi t1,defbfr ;point to area for default text
movx t3,ot%ntm ;indicate no time desired
odtim% ;output the date
erjmp cmderr ;cannot recover from these errors
hrroi t1,defbfr ;point to default
movem t1,bakfdb+.cmdef ;store pointer in fdb
datei1: caig nargs,help ;did user supply a help message
jrst dateih ;no, so we must construct our own
skipn @help(cx) ;yes, is help null ?
jrst dateih ;yes, construct our own
movei t1,help ;Point to help argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t1,@help(cx) ;no, so point to it
movem t1,fdb+.cmhlp ;and store for use by COMND
jrst dateh1 ;skip constructing ours
dateih: call makhld ;make the help message
hrroi t1,hlpbfr ;point to it
movem t1,fdb+.cmhlp ;store pointer for COMND
dateh1: movei t1,datbrk ;get address of date breakset
movem t1,fdb+.cmbrk ;store in fdb
SETEXT ;decide whether to use EXIT/UNKNOWN
movei t1,cmdblk ;now, point to command state block
movei t2,bakfdb ;and function block
comnd% ;get text
erjmp cmderr ;die badly
movei t4,@fail(cx) ;get address of fail flag for chpars
movei q3,@julian(cx) ;get the address of the answer for chpars
setz q2, ;clear return address
caig nargs,back ;alternate return given ?
jrst datech ;no, so skip
skipe @back(cx) ;is it zero ?
movei q2,@back(cx) ;no, get return address if "^" entered
datech: call chpars ;check on which fdb used to parse
jrst dater1 ;fail, issue error, try again
hrroi t1,atmbfr ;now point to input text
movx t2,it%snm!it%err!it%nti ;refuse american dates, no time please
idtnc% ;read date, return separate numbers
erjmp dater2 ;if an error, complain
call jday ;convert to julian day number
move t2,t1 ;get result in right place
movem t2,@julian(cx) ;return date to caller
caig nargs,upper ;upper limit supplied ?
jrst datenu ;no, so don't test
skipn upper(cx) ;address for upper limit ?
jrst datenu ;no, so don't test
skipn @upper(cx) ;upper limit non-zero ?
jrst datenu ;no, so don't test
camle t2,@upper(cx) ;yes, so are we in range ?
jrst dater3 ;no, complain and try again
datenu: caig nargs,lower ;lower limit supplied ?
jrst datenl ;no, don't test
skipn lower(cx) ;address for it ?
jrst datenl ;no, so don't test
skipn @lower(cx) ;lower limit non-zero ?
jrst datenl ;no, don't check it
camge t2,@lower(cx) ;ok, are we in range ?
jrst dater3 ;no, complain and try again
datenl: confirm daterp ;and confirm command
ret ;all ok
;
; Routine to convert output from IDTNC to julian day number
;
jday: hrrz t1,t2 ;get month
hlrzs t2,t2 ;get year
caig t1,1 ;february or january ?
jrst jday1 ;yes
subi t1,2 ;no, subtract 2 from month
jrst jday2 ;continue
jday1: addi t1,^d10 ;add 10 to month
soj t2, ;but subtract one from year
jday2: hlrzs t3,t3 ;get day of month
aoj t3, ;make it start at 1
push p,q1 ;save a register we will fiddle with
move t4,t2 ;get a year
idivi t4,^d100 ;divide result by 100
movem t4,q1 ;take this intermediate result
imuli t4,^d100 ;multiply by 100 again
movns t4,t4 ;negate
add t4,t2 ;and add to real year
imuli t4,^d1461 ;multiply this result by 1461
lsh t4,-2 ;divide by 4
imuli q1,^d146097 ;multiply previous intermediate result
lsh q1,-2 ;divide that by 4
addm t4,q1 ;add two results together
addm t3,q1 ;add in day of month
imuli t1,^d153 ;multiply month-3 by 153
addi t1,2 ;add 2
idivi t1,5 ;divide by 5
addm t1,q1 ;add in to total
add q1,[^d1721119] ;add the magic number
move t1,q1 ;return in correct ac
pop p,q1 ;restore
ret ;and back to caller
;
; Here on various parse and range check errors.
;
dater1: errmes errgen ;issue error
datern: hrroi t1,[ASCIZ/, try again please/] ;usual request
skipe hlpbfr ;is there some helpful help ?
jrst datrn1 ;yes, use it instead
psout% ;type it
jrst daterp ;and go again
datrn1: tmsg <, please > ;be polite
hrroi t1,hlpbfr ;point to the help message
psout% ;and type it
jrst daterp ;go round again
dater2: errmes errdat ;complain about date
jrst datern
dater3: errmes errdtr ;date not in range
jrst datern
subttl Construct DATEIN help message
;
; Construct help message for DATEIN function
;
makhld: hrroi t1,hlpbfr ;point to help buffer
hrroi t2,[asciz/Enter a date/] ;beginning of help
setzb t3,t4
sout% ;write out message prefix
caig nargs,lower ;lower limit ?
jrst makhd1 ;no
skipn @lower(cx) ;lower limit non-zero ?
jrst makhd1 ;no
hrroi t2,[asciz/, after /] ;yes, so prepare to add lower limit
setzb t3,t4
sout% ;write next part of help
move t2,@lower(cx) ;get lower limit
sub t2,[jtos+1] ;convert to smithsonian
hrlzs t2,t2 ;make internal date/time
movx t3,ot%ntm ;write no time
odtim% ;put out lower date
makhd1: caig nargs,upper ;upper limit ?
jrst makhd2 ;no
skipn @upper(cx) ;upper limit non-zero ?
jrst makhd2 ;no
hrroi t2,[asciz/, before /] ;yes, so prepare to add upper limit
setzb t3,t4
sout% ;write next part of help
move t2,@upper(cx) ;get upper limit
sub t2,[jtos-1] ;convert to smithsonian
hrlzs t2,t2 ;make internal date/time
movx t3,ot%ntm ;write no time
odtim% ;put out upper date
makhd2: hrroi t1,hlpbfr ;point to help buffer
ret ;back to caller
subttl TIMEIN - read a time in variable-type format
;
; Yet again, this is read as a text field, because of problems with
; setting the format used by COMND to read times.
;
; CALL TIMEIN(PROMPT,SECOND,FAIL[,BACK[,LOWER[,UPPER[,HELP[,DEFALT]]]]])
;
; PROMPT - prompting string in ASCIZ
; SECOND - Returned number of seconds since midnight
; FAIL - 0 is success, else bad time format, else not in range
; BACK - label to return to on getting "^"
; LOWER - lower limit, ignored if 0 (optional)
; UPPER - upper limit, ignored if 0 (optional)
; HELP - ASCIZ help message, ignore if 0 (optional)
; DEFALT - default time, ignored if 0 (optional)
; Lower, upper and default are all supplied as seconds since midnight(ssm)
;
FORARG <PROMPT,SECOND,FAIL,BACK,LOWER,UPPER,HELP,DEFALT>
sixbit /timein/
timein: setzm @fail(cx) ;no errors yet
move t1,retrys ;get number of retries
movem t1,tried ;store it
timerp: hrroi t1,@prompt(cx) ;point to prompt
call cmdini ;initialize
setzm bakfdb+.cmdef ;no pointer for default yet
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!exifdb
;clear default flag in bakfdb
movem t2,bakfdb ;and store
move t1,[fld(.cmtad,cm%fnc)!cm%sdh!cm%hpp] ;parse as time
;indicate our help is present
movem t1,fdb ;store them
movx t2,cm%itm!cm%nci!p2 ;only want time, not converted,ans in p2
movem t2,fdb+.cmdat ;and store
caig nargs,defalt ;default supplied ?
jrst timei1 ;no, skip this
skipn defalt(cx) ;address ok ?
jrst timei1 ;no, skip this
skipn @defalt(cx) ;is default 0 ?
jrst timei1 ;yes, skip this again
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!cm%dpp!exifdb
;set default flag in bakfdb
movem t2,bakfdb ;and store
hrroi t1,defbfr ;point to area for default text
setz t2, ;no years or months
setz t3, ;no days
hrrz t4,@defalt(cx) ;get the default time (ssm)
movx q1,ot%nda ;indicate no date desired
odtnc% ;output the time
erjmp cmderr ;cannot recover from these errors
hrroi t1,defbfr ;point to default
movem t1,bakfdb+.cmdef ;store pointer in fdb
timei1: caig nargs,help ;did user supply a help message
jrst timeih ;no, so we must construct our own
skipn @help(cx) ;yes, is help null ?
jrst timeih ;yes, construct our own
hrroi t1,@help(cx) ;no, so point to it
movem t1,fdb+.cmhlp ;and store for use by COMND
jrst timeh1 ;skip constructing ours
timeih: call makhlt ;make the help message
hrroi t1,hlpbfr ;point to it
movem t1,fdb+.cmhlp ;store pointer for COMND
timeh1: SETEXT ;decide whether to use EXIT/UNKNOWN
movei t1,cmdblk ;now, point to command state block
movei t2,bakfdb ;and function block
comnd% ;get time
erjmp cmderr ;die badly
movei t4,@fail(cx) ;get address of fail flag for chpars
movei q3,@second(cx) ;get the address of the answer for chpars
setz q2, ;clear return address
caig nargs,back ;alternate return given ?
jrst timech ;no, so skip
skipe @back(cx) ;is it zero ?
movei q2,@back(cx) ;no, get return address if "^" entered
timech: call chpars ;check on which fdb used to parse
jrst timer1 ;fail, issue error, try again
move t2,p4 ;get result in right place
movem t2,@second(cx) ;return time to caller
caig nargs,upper ;upper limit supplied ?
jrst timenu ;no, so don't test
skipn upper(cx) ;address for upper limit ?
jrst timenu ;no, so don't test
skipn @upper(cx) ;upper limit non-zero ?
jrst timenu ;no, so don't test
camle t2,@upper(cx) ;yes, so are we in range ?
jrst timer3 ;no, complain and try again
timenu: caig nargs,lower ;lower limit supplied ?
jrst timenl ;no, don't test
skipn lower(cx) ;address for it ?
jrst timenl ;no, so don't test
skipn @lower(cx) ;lower limit non-zero ?
jrst timenl ;no, don't check it
camge t2,@lower(cx) ;ok, are we in range ?
jrst timer3 ;no, complain and try again
timenl: confirm timerp ;and confirm command
ret ;all ok
;
; Here on various parse and range check errors.
;
timer1: errmes errgen ;issue error
timern: hrroi t1,[ASCIZ/, try again please/] ;usual request
skipe hlpbfr ;is there some helpful help ?
jrst timrn1 ;yes, use it instead
psout% ;type it
jrst timerp ;and go again
timrn1: tmsg <, please > ;be polite
hrroi t1,hlpbfr ;point to the help message
psout% ;and type it
jrst timerp ;go round again
timer2: errmes errtim ;complain about time
jrst timern
timer3: errmes errtmr ;time not in range
jrst timern
subttl Construct TIMEIN help message
;
; Construct help message for TIMEIN function
;
makhlt: hrroi t1,hlpbfr ;point to help buffer
hrroi t2,[asciz/Enter a time/] ;beginning of help
setzb t3,t4
sout% ;write out message prefix
caig nargs,lower ;lower limit ?
jrst makht1 ;no
skipn @lower(cx) ;lower limit non-zero ?
jrst makht1 ;no
hrroi t2,[asciz/, after /] ;yes, so prepare to add lower limit
setzb t3,t4
sout% ;write next part of help
hrrz t4,@lower(cx) ;get lower limit
movx q1,ot%nda ;no date
odtnc% ;put out lower time
makht1: caig nargs,upper ;upper limit ?
jrst makht2 ;no
skipn @upper(cx) ;upper limit non-zero ?
jrst makht2 ;no
hrroi t2,[asciz/, before /] ;yes, so prepare to add upper limit
setzb t3,t4
sout% ;write next part of help
hrrz t4,@upper(cx) ;get upper limit
movx q1,ot%nda ;no date
odtim% ;put out upper time
makht2: hrroi t1,hlpbfr ;point to help buffer
ret ;back to caller
subttl KYWORD - read a key word from a table
;
; Routine to read a keyword selected from a specified table
;
; CALL KYWORD(PROMPT,KTABLE,KEYNUM,FAIL[,BACK[,HELP[,DEFALT[,STRING]]]])
;
; prompt - ASCIZ prompt string
; ktable - the table of keywords built by the user
; keynum - number of the keyword as specified by user in table
; fail - 0 if ok, else +ve
; back - label to return to on getting "^"
; help - ASCIZ help text for ?, optional
; defalt - ASCIZ default answer, optional
; string - ASCIZ returned text, full key word indicated by user
;
forarg <prompt,ktable,keynum,fail,back,help,defalt,string>
sixbit /kyword/
kyword: setzm @fail(cx) ;indicate no error
move t2,retrys ;get users retry count
movem t2,tried ;save count for this field
keywrp: movei t1,prompt ;Point to prompt argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t1,@prompt(cx) ;point to prompt
call cmdini ;initialize COMND
move t1,[fld(.cmkey,cm%fnc)!cm%brk] ;get function, indicate breakset
caig nargs,help ;help argument ?
jrst keywnh ;no, so don't store
skipn @help(cx) ;did they supply any ?
jrst keywnh ;no, so skip
movei t1,help ;Point to help argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t2,@help(cx) ;yes, get users help
movem t1,fdb+.cmhlp ;store it
move t1,[fld(.cmkey,cm%fnc)!cm%brk!cm%hpp!cm%sdh]
;indicate a help message is supplied
keywnh: movem t1,fdb ;store function code, flags
setzm bakfdb+.cmdef ;assume no default supplied
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!exifdb
;clear default flag in bakfdb
movem t2,bakfdb ;and store
caig nargs,defalt ;number of arguments indicate default ?
jrst keywnd ;no, so don't supply one
skipn defalt(cx) ;user supplied default ?
jrst keywnd ;no, so indicate no default
skipn @defalt(cx) ;is the default null ?
jrst keywnd ;yes, so skip this
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!cm%dpp!exifdb
;set default flag in bakfdb
movem t2,bakfdb ;and store
movei t1,defalt ;Point to default argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t1,@defalt(cx) ;point to user's default
hrroi t2,defbfr ;point to buffer for defaults
setzb t3,t4 ;terminate on null
sin% ;write out default string
hrroi t1,defbfr ;point to default buffer
movem t1,bakfdb+.cmdef ;and store in the fdb
move t1,t2 ;get pointer to end of string
call strblk ;strip trailing blanks
keywnd: movei t1,@ktable(cx) ;get the address of the table
addi t1,2 ;bypass info at top of table
movem t1,fdb+.cmdat ;store func-specific data
keywi2: movei t1,brkmsk ;get break mask for keywords
movem t1,fdb+.cmbrk ;store it
SETEXT ;decide whether to use EXIT/UNKNOWN
movei t1,cmdblk ;point to command state block
movei t2,bakfdb ;point to function block
comnd% ;parse a key word
erjmp cmderr ;die
movei t4,@fail(cx) ;get address of fail flag for chpars
movei q3,@keynum(cx) ;get the address of the answer for chpars
setz q2, ;clear return address
caig nargs,back ;alternate return given ?
jrst keywch ;no, so skip
skipe @back(cx) ;is it zero ?
movei q2,@back(cx) ;no, get return address if "^" entered
keywch: call chpars ;check on which fdb used to parse
jrst kywerr ;fail, so try for error handling
hrre t3,(t2) ;get contents of table entry
movem t3,@keynum(cx) ;return the key number to user
caig nargs,string ;enough arguments for a string ?
jrst kywor2 ;no, skip this
push p,t2 ;save pointer into table
movx t1,string ;want pointer to caller's array
call gtbypt ;may be f77 character
caig t2,0 ;a length of 0 means f66
jrst [pop p,t2 ; retrieve pointer
hlro t2,(t2) ; point to user's answer
setzb t3,t4 ; terminate writing on null
sout% ; and copy answer to caller's buffer
jrst kywor2] ; and continue
;
;set up the block of accumulators for the movslj instruction, with blank fill
;
; _________________________________
; t1 | 000 | source string length |
; t2 |{ source string byte ptr }|<- keyword table
; t3 |{ }|
; t4 | 000 | dest. string length |<
; q1 |{ dest. string byte ptr. }|<- from gtbypt
; q2 |{ }|
; ---------------------------------
;
dmove t4,t1 ;get destination length, from gtbypt.
exch t4,q1 ;...get destination pointer
move t2,[point 7,0] ;make source pointer
pop p,t3 ;restore source address from stack
hlr t2,(t3) ;...add in the address to pointer
move t3,t2 ;duplicate pointer
setz t1, ;zero length count
kywln1: ildb t3 ;get a byte
skipn 0 ;was it null ?
skipa ;yes, leave length in t1
aoja t1,kywln1 ;no, increment count and loop
movcha t1, ;move string with blank fill (MACRO)
kywor2: confirm keywrp ;confirm command
call ptspac ;return f77 string space
ret ;no problems, so return
;
; Here on parse error
;
kywerr: movei t1,.fhslf ;point to our fork
geter% ;find error code
erjmp cmderr
hrrzs t2 ;discover just error code
cain t2,npxamb ;ambiguous ?
jrst kyamb ;yes
errmes errgen,keywrp ;no, issue general error
kyamb: errmes erramk,keywrp
kywer1: tmsg <, try again please> ;prompt for more
jrst keywrp ;go round again
subttl YESNO - read a yes or a no
;
; Routine to read a yes or a no from the terminal
;
; CALL YESNO(PROMPT,ANWSER,FAIL[,BACK[,HELP[,DEFALT]]])
;
; prompt - ASCIZ prompt string
; answer - -1 =yes 1=no 0= unknown
; fail - 0 if ok, else +ve
; back - label to return to on getting "^"
; help - ASCIZ help text for ?, optional
; defalt - ASCIZ default answer, optional
;
forarg <prompt,answer,fail,back,help,defalt>
sixbit /yesno/
yesno: setzm @fail(cx) ;indicate no error
move t2,retrys ;get users retry count
movem t2,tried ;save count for this field
yesnrp: movei t1,prompt ;Point to prompt argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t1,@prompt(cx) ;point to prompt
call cmdini ;initialize COMND
move t1,[fld(.cmkey,cm%fnc)] ;get function
caig nargs,help ;help argument ?
jrst yesnnh ;no, so don't store
skipn @help(cx) ;did they supply any ?
jrst yesnnh ;no, so skip
movei t1,help ;Point to help argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t2,@help(cx) ;yes, get users help
movem t1,fdb+.cmhlp ;store it
movx t1,fld(.cmkey,cm%fnc)!cm%sdh!cm%hpp
;indicate a help message is supplied
yesnnh: movem t1,fdb ;store function code, flags
setzm bakfdb+.cmdef ;assume no default supplied
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!exifdb
;clear default flag in bakfdb
movem t2,bakfdb ;and store
caig nargs,defalt ;number of arguments indicate default ?
jrst yesnnd ;no, so don't supply one
skipn defalt(cx) ;user supplied default ?
jrst yesnnd ;no, so indicate no default
skipn @defalt(cx) ;is the default null ?
jrst yesnnd ;yes, so skip this
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!cm%dpp!exifdb
;set default flag in bakfdb
movem t2,bakfdb ;and store
call copydf ;and copy the default over, stripping
hrroi t2,defbfr ;get a byte pointer to default
movem t2,bakfdb+.cmdef ;and store in the fdb
yesnnd: movei t1,[2,,2
[asciz/No/],,1
[asciz/Yes/],,-1] ;get the address of the table
movem t1,fdb+.cmdat ;store func-specific data
yesni2: SETEXT ;decide whether to use EXIT/UNKNOWN
movei t1,cmdblk ;point to command state block
movei t2,bakfdb ;point to function block
comnd% ;parse a key word
erjmp cmderr ;die
movei t4,@fail(cx) ;get address of fail flag for chpars
movei q3,@answer(cx) ;get the address of the answer for chpars
setz q2, ;clear return address
caig nargs,back ;alternate return given ?
jrst yesnch ;no, so skip
skipe @back(cx) ;is it zero ?
movei q2,@back(cx) ;no, get return address if "^" entered
yesnch: call chpars ;check on which fdb used to parse
jrst yeserr ;fail, so try for error handling
move t2,(t2) ;get contents of table entry
hrrem t2,@answer(cx) ;return the key number to user
confirm yesnrp ;confirm command
call ptspac ;return f77 string space
ret ;no problems, so return
;
; Here on parse error
;
yeserr: errmes errgen ;issue general error
yeser1: tmsg <, try again please> ;prompt for more
jrst yesnrp ;go round again
;
; Here to copy a user default string
;
copydf: movei t1,defalt ;Point to default argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t1,@defalt(cx) ;as we must copy the user's default
hrroi t2,defbfr ;across to our own space
movei t3,deflen ;to remove any trailing blanks
setz t4, ;first terminate on null
sin% ;do it
move t1,[point 7,defbfr] ;now point to the default buffer
movei t2,deflen ;get its maximum length
copylp: ildb t3,t1 ;get a character
jumpe t3,[ret] ;if 0, all over, it was null anyway
cain t3," " ;is it a space ?
jrst [setz t3, ;yes, get a null
dpb t3,t1 ;and drop it over the space
ret] ;and back to caller
sojn t2,copylp ;no, so examine the next character
ret
subttl SEXIN - read a sex
;
; Routine to read a sex from the terminal
;
; CALL SEXIN(PROMPT,ANWSER,FAIL[,BACK[,HELP[,DEFALT]]])
;
; prompt - ASCIZ prompt string
; answer - -1 = male 1 = female 0 = unknown
; fail - 0 if ok, else +ve
; back - label to return to on getting "^"
; help - ASCIZ help text for ?, optional
; defalt - ASCIZ default answer, optional
;
forarg <prompt,answer,fail,back,help,defalt>
sixbit /sexin/
sexin: setzm @fail(cx) ;indicate no error
move t2,retrys ;get users retry count
movem t2,tried ;save count for this field
sexnrp: movei t1,prompt ;Point to prompt argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t1,@prompt(cx) ;point to prompt
call cmdini ;initialize COMND
move t1,[fld(.cmkey,cm%fnc)] ;get function
caig nargs,help ;help argument ?
jrst sexnnh ;no, so don't store
skipn help(cx) ;did they supply any ?
jrst sexnnh ;no, so skip
movei t1,help ;Point to help argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
;* hrroi t2,@help(cx) ;yes, get users help
movem t1,fdb+.cmhlp ;store it
movx t1,fld(.cmkey,cm%fnc)!cm%sdh!cm%hpp
;indicate a help message is supplied
sexnnh: movem t1,fdb ;store function code, flags
setzm bakfdb+.cmdef ;assume no default supplied
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!exifdb
;clear default flag in bakfdb
movem t2,bakfdb ;and store
caig nargs,defalt ;number of arguments indicate default ?
jrst sexnnd ;no, so don't supply one
skipn defalt(cx) ;user supplied default ?
jrst sexnnd ;no, so indicate no default
skipn @defalt(cx) ;is the default null ?
jrst sexnnd ;yes, so skip this
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!cm%dpp!exifdb
;set default flag in bakfdb
movem t2,bakfdb ;and store
movei t1,defalt ;Point to default argument
call gtascz ;may be fortran v7
;* call gtbypt ;Get a byte pointer to it
movem t1,bakfdb+.cmdef ;store it
sexnnd: movei t1,[2,,2 ;get the address of the table
[asciz/Female/],,-1
[asciz/Male/],,1]
movem t1,fdb+.cmdat ;store func-specific data
sexni2: SETEXT ;decide whether to use EXIT/UNKNOWN
movei t1,cmdblk ;point to command state block
movei t2,bakfdb ;point to function block
comnd% ;parse a key word
erjmp cmderr ;die
movei t4,@fail(cx) ;get address of fail flag for chpars
movei q3,@answer(cx) ;get the address of the answer for chpars
setz q2, ;clear return address
caig nargs,back ;alternate return given ?
jrst sexich ;no, so skip
skipe @back(cx) ;is it zero ?
movei q2,@back(cx) ;no, get return address if "^" entered
sexich: call chpars ;check on which fdb used to parse
jrst sexerr ;yes, so try for error handling
move t2,(t2) ;get contents of table
hrrem t2,@answer(cx) ;return the key number to user
confirm sexnrp ;confirm command
call ptspac ;return f77 string space
ret ;no problems, so return
;
; Here on parse error
;
sexerr: errmes errgen ;issue general error
sexer1: tmsg <, try again please> ;prompt for more
jrst sexnrp ;go round again
subttl NUMIN - read integer number
;
; Routine to read an integer number
;
; CALL NUMIN(PROMPT,ANSWER,FAIL[,BACK[,LOLIM[,HILIM[,HELP[,DEFALT]]]]])
;
; prompt - ASCIZ prompt string
; answer - Returned integer number, typed by user
; fail - 0 if ok, else +ve
; back - label to return to on getting "^"
; lolim - lower limit of acceptability, inclusive
; hilim - higher limit of acceptability, inclusive
; help - ASCIZ help text for ?, optional
; defalt - ASCIZ default answer, optional
;
forarg <prompt,answer,fail,back,lolim,hilim,help,defalt>
sixbit /numin/
numin: setzm @fail(cx) ;indicate no error
move t2,retrys ;get users retry count
movem t2,tried ;save count for this word
numrp: movei t1,prompt ;point to the prompt
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@prompt(cx) ;point to first argument
call cmdini ;initialize COMND
movx t1,fld(.cmnum,cm%fnc)!cm%sdh!cm%hpp
;get function, parse whole number indicate a help message is supplied
movem t1,fdb ;store function code, flags
setzm bakfdb+.cmdef ;assume no default supplied
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!exifdb
;clear default flag in bakfdb
movem t2,bakfdb ;and store
caig nargs,defalt ;number of arguments indicate default ?
jrst numnd ;no, so don't supply one
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!cm%dpp!exifdb
;set default flag in bakfdb
movem t2,bakfdb ;and store
move t2,@defalt(cx) ;get the default number
hrroi t1,defbfr ;point to area for default text
movx t3,^d10 ;o/p a leading digit a. and allow ovfl
nout% ;output the number
erjmp cmderr ;cannot recover from these errors
hrroi t1,defbfr ;point to default
movem t1,bakfdb+.cmdef ;store pointer in fdb
numnd: movx t1,^d10 ;read number in base ten
movem t1,fdb+.cmdat ;no func-specific data
caig nargs,help ;help argument ?
jrst numnh ;no, so don't store
skipn @help(cx) ;null help ?
jrst numnh ;yes, so don't store
movei t1,help ;point to the help
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@help(cx) ;get users help
movem t1,fdb+.cmhlp ;and store it
jrst numi2 ;don't construct our own help
numnh: call makhln ;make our help message
hrroi t1,hlpbfr ;point to it
movem t1,fdb+.cmhlp ;store pointer
numi2: SETEXT ;decide whether to use EXIT/UNKNOWN
movei t1,cmdblk ;point to command state block
movei t2,bakfdb ;point to function block
comnd% ;parse an integer number
erjmp cmderr ;die
movei t4,@fail(cx) ;get address of fail flag for chpars
movei q3,@answer(cx) ;get the address of the answer for chpars
setz q2, ;clear return address
caig nargs,back ;alternate return given ?
jrst numich ;no, so skip
skipe @back(cx) ;is it zero ?
movei q2,@back(cx) ;no, get return address if "^" entered
numich: call chpars ;check on which fdb used to parse
jrst numerr ;fail, so try for error handling
;
; We have an integer number
;
movem t2,@answer(cx) ;give user the answer anyway
caig nargs,lolim ;lower limit supplied ?
jrst numnhi ;no, also no high limit, so skip
movx t1,.infin ;infinity means no limit
camn t1,lolim(cx) ;did user ask to check low limit ?
jrst numnl ;no, so skip test
camge t2,@lolim(cx) ;is it >= lower limit
jrst numlow ;no, so send error message
numnl: caig nargs,hilim ;higher limit supplied ?
jrst numnhi ;no, so skip
movx t1,.infin ;infinity means no limit
camn t1,hilim(cx) ;did user ask to check high limit ?
jrst numnhi ;no, so skip test
camle t2,@hilim(cx) ;is it =< higher limit
jrst numhi ;no, so send error message
numnhi: confirm numrp ;confirm command
call ptspac ;return f77 string space
ret ;no problems, so return
;
; range check error arrives here
;
numlow: errmes errnsm ;too small error message
jrst numer1 ;go to prompt for more
numhi: errmes errnlg ;too large error message
jrst numer1 ;go to prompt for more
;
; Here on parse error
;
numerr: errmes errgen ;issue general error
numer1: hrroi t1,[ASCIZ/, try again please/] ;usual request
skipe hlpbfr ;is there some helpful help ?
jrst numer2 ;yes, use it instead
psout% ;type it
jrst numrp ;and go again
numer2: tmsg <.
Please > ;be polite
hrroi t1,hlpbfr ;point to the help message
psout% ;and type it
jrst numrp ;go round again
subttl Construct NUMIN help message
;
; Construct help message for NUMIN function
;
makhlN: hrroi t1,hlpbfr ;point to help buffer
hrroi t2,[asciz/enter a whole number/] ;beginning of help
setzb t3,t4
sout% ;write out message prefix
caig nargs,lolim ;lower limit ?
jrst makhn1 ;no
skipn @lolim(cx) ;lower limit non-zero ?
jrst makhn1 ;no
hrroi t2,[asciz/, at least /] ;yes, so prepare to add lower limit
setzb t3,t4
sout% ;write next part of help
move t2,@lolim(cx) ;get lower limit
movx t3,^d10 ;write in decimal
nout% ;put out lower limit
erjmp cmderr
makhn1: caig nargs,hilim ;upper limit ?
jrst makhn2 ;no
skipn @hilim(cx) ;upper limit non-zero ?
jrst makhn2 ;no
hrroi t2,[asciz/, not more than /];yes, prepare to add upper limit
setzb t3,t4
sout% ;write next part of help
move t2,@hilim(cx) ;get upper limit
movx t3,^d10 ;write in decimal
nout% ;do it
erjmp cmderr ;errors are extremely serious
makhn2: hrroi t1,hlpbfr ;point to help buffer
ret ;back to caller
subttl REALIN - read real number
;
; Routine to read a real number
;
; CALL REALIN(PROMPT,ANSWER,FAIL[,BACK[,LOLIM[,HILIM[,HELP[,DEFALT]]]]])
;
; prompt - ASCIZ prompt string
; answer - Returned real number, typed by user
; fail - 0 if ok, else +ve
; back - label to return to on getting "^"
; lolim - lower limit of acceptability, inclusive
; hilim - higher limit of acceptability, inclusive
; help - ASCIZ help text for ?, optional
; defalt - ASCIZ default answer, optional
;
forarg <prompt,answer,fail,back,lolim,hilim,help,defalt>
sixbit /realin/
realin: setzm @fail(cx) ;indicate no error
move t2,retrys ;get users retry count
movem t2,tried ;save count for this field
realrp: movei t1,prompt ;point to the prompt
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@prompt(cx) ;point to first argument
call cmdini ;initialize COMND
movx t1,fld(.cmflt,cm%fnc)!cm%sdh!cm%hpp
;get function, parse floating point number indicate a help message is supplied
movem t1,fdb ;store function code, flags
setzm bakfdb+.cmdef ;assume no default supplied
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!exifdb
;clear default flag in bakfdb
movem t2,bakfdb ;and store
caig nargs,defalt ;number of arguments indicate default ?
jrst realnd ;no, so don't supply one
movx t2,fld(.cmtok,cm%fnc)!cm%sdh!cm%dpp!exifdb
;set default flag in bakfdb
movem t2,bakfdb ;and store
move t2,@defalt(cx) ;get the default number
hrroi t1,defbfr ;point to area for default text
movx t3,fl%one!fl%pnt!fl%ovl ;o/p a leading digit a. and allow ovfl
flout% ;output the number
erjmp cmderr ;cannot recover from these errors
hrroi t1,defbfr ;point to default
movem t1,bakfdb+.cmdef ;store pointer in fdb
realnd: setzm fdb+.cmdat ;no func-specific data
caig nargs,help ;help argument ?
jrst realnh ;no, so don't store
skipn @help(cx) ;did they supply any ?
jrst realnh ;no, so don't store
movei t1,help ;point to the help
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@help(cx) ;get users help
movem t1,fdb+.cmhlp ;store pointer to user's help
jrst reali2 ;don't construct our own help
realnh: call makhlr ;construct our help message
movem t1,fdb+.cmhlp ;store pointer to it in fdb
reali2: SETEXT ;decide whether to use EXIT/UNKNOWN
movei t1,cmdblk ;point to command state block
movei t2,bakfdb ;point to function block
comnd% ;parse a real number
erjmp cmderr ;die
movei t4,@fail(cx) ;get address of fail flag for chpars
movei q3,@answer(cx) ;get the address of the answer for chpars
setz q2, ;clear return address
caig nargs,back ;alternate return given ?
jrst realch ;no, so skip
skipe @back(cx) ;is it zero ?
movei q2,@back(cx) ;no, get return address if "^" entered
realch: call chpars ;check on which fdb used to parse
jrst reaerr ;fail, so try for error handling
;
; We have a real number
;
movem t2,@answer(cx) ;give user the correct answer
caig nargs,lolim ;lower limit supplied ?
jrst reanhi ;no, also no high limit, so skip
movx t1,.infin ;infinity means no limit
camn t1,lolim(cx) ;did user ask to check low limit ?
jrst realnl ;no, so skip test
camge t2,@lolim(cx) ;is it >= lower limit
jrst realow ;no, so send error message
realnl: caig nargs,hilim ;higher limit supplied ?
jrst reanhi ;no, so skip
movx t1,.infin ;infinity means no limit
camn t1,hilim(cx) ;did user ask to check high limit ?
jrst reanhi ;no, so skip test
camle t2,@hilim(cx) ;is it =< higher limit
jrst realhi ;no, so send error message
reanhi: confirm realrp ;confirm command
call ptspac ;return f77 string space
ret ;no problems, so return
;
; range check error arrives here
;
realow: errmes errnsm ;too small error message
jrst reaer1 ;go to prompt for more
realhi: errmes errnlg ;too large error message
jrst reaer1 ;go to prompt for more
;
; Here on parse error
;
reaerr: errmes errgen ;issue general error
reaer1: hrroi t1,[ASCIZ/, try again please/] ;usual request
skipe hlpbfr ;is there some helpful help ?
jrst reaer2 ;yes, use it instead
psout% ;type it
jrst realrp ;and go again
reaer2: tmsg <.
Please > ;be polite
hrroi t1,hlpbfr ;point to the help message
psout% ;and type it
jrst realrp ;go round again
subttl Construct REALIN help message
;
; Construct help message for REALIN function
;
makhlr: hrroi t1,hlpbfr ;point to help buffer
hrroi t2,[asciz/enter a number/] ;beginning of help
setzb t3,t4
sout% ;write out message prefix
caig nargs,lolim ;lower limit ?
jrst makhr1 ;no
skipn @lolim(cx) ;lower limit non-zero ?
jrst makhr1 ;no
hrroi t2,[asciz/, at least /] ;yes, so prepare to add lower limit
setzb t3,t4
sout% ;write next part of help
move t2,@lolim(cx) ;get lower limit
movx t3,fl%one!fl%pnt!fl%ovl ;o/p a leading digit a. and allow ovfl
flout% ;put out lower limit
erjmp cmderr
makhr1: caig nargs,hilim ;upper limit ?
jrst makhr2 ;no
skipn @hilim(cx) ;upper limit non-zero ?
jrst makhr2 ;no
hrroi t2,[asciz/, not more than /];yes, prepare to add upper limit
setzb t3,t4
sout% ;write next part of help
move t2,@hilim(cx) ;get upper limit
movx t3,fl%one!fl%pnt!fl%ovl ;o/p a leading digit a. and allow ovfl
flout% ;do it
erjmp cmderr ;errors are extremely serious
makhr2: hrroi t1,hlpbfr ;point to help buffer
ret ;back to caller
subttl TABLE - routine to add entries to a TBLUK table
;
; This routine is a low-level routine to allow users to build up
; TBLUK tables for COMND.
;
; CALL TABLE(KEYWORD,KEYNUM,TAB,STRINGS,FAIL)
; where
; KEYWORD - ASCIZ keyword to place in table
; KEYNUM - Value to be associated with keyword
; TAB - Array of length MAXKEYS+3 - stores TBLUK table
; STRINGS - Array large enough to hold all strings + 2 words.
; FAIL - 0 if success, else 11 - Entry is already in table
; 12 - Table is full.
;
; On the first call, the first word of the TAB array must contain the
; length of the array. The STRING array must be all 0.
; The arrays are used as follows:
; POINTS: Pointer to next free loc in strings
; Absolute address of strings
; TBLUK table
;
FORARG <KEYWRD,KEYNUM,POINTS,STRINGS,FAIL>
sixbit /table/
table: skipe @strings(cx) ;is the string array zero ?
jrst table1 ;no, so continue to add
move t1,@points(cx) ;yes, so get the length of the table
subi t1,2 ;subtract 2 words for overhead
movei t2,@points(cx) ;get address of array
movem t1,2(t2) ;and store start of TBLUK table
move t1,[point 7,] ;get left half of ASCII byte pointer
movei t3,@strings(cx) ;get address of strings array
hrr t1,t3 ;construct full byte pointer to strings
movem t1,(t2) ;store in start of POINTS array
movem t3,1(t2) ;and remember address of strings in case
;of later array movement
table1: setzm @fail(cx) ;assume no failure yet
movei t1,keywrd ;point to the keyword
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
move t2,@points(cx) ;get the byte pointer to strings
movem t2,q1 ;save for use in TBADD
;* hrroi t1,@keywrd(cx) ;point to user's keyword
setzb t3,t4 ;terminate writing on null
sin% ;write the string into our array
call ptspac ;return f77 string space
call trim ;remove any trailing blanks
idpb t3,t2 ;put a null on the end
hrrzs t2,t2 ;now strip address out of string ptr
aoj t2, ;make it point to the next word
hrli t2,(point 7,) ;and make it a byte pointer again.
;
; All the above is because TBLUK strings must start on a word boundary.
;
movem t2,@points(cx) ;store our new byte pointer
hrlz t2,q1 ;now get address where we wrote strings
hrr t2,@keynum(cx) ;and get tag that user wants to leave
movei t1,@points(cx) ;point to users table
addi t1,2 ;but we use first two words, so...
tbadd% ;add the word in
erjmp tberr ;if error, process
ret ;return to caller
;
; Routine to remove trailing blanks from copied string. Input
; byte pointer in t2, updated on return. May use t1 freely.
;
trim: ldb t1,t2 ;get a byte
caie t1," " ;is it space ?
ret ;no, so we have finished
seto t1, ;yes, so backspace the pointer
adjbp t1,t2 ;by one or so..
move t2,t1 ;return pointer where we found it
jrst trim ;and try again
tberr: movx t1,.fhslf ;our process
geter% ;get the error, please
hrrzs t2,t2 ;strip off process handle
movei t1,errful ;assume tables full
cain t2,taddx1 ;was that the error
jrst tberr1 ;yes, so ok
caie t2,taddx2 ;was it duplicate entry ?
jrst cmderr ;no, some fatal error, so die
movei t1,errmul ;code for duplicate entry
tberr1: movem t1,@fail(cx) ;store user error code
movem q1,@points(cx) ;store old string space pointer
ret ;back to caller
subttl TBLOOK - routine to lookup entries in a TBLUK table.
;
; This routine is a low-level routine to allow users to lookup
; TBLUK tables for COMND.
;
; CALL TBLOOK(KEYWORD,TABLE,RESULT,FAIL)
; where
; KEYWORD - ASCIZ keyword to lookup in table
; TABLE - TBLUK table constructed with TABLE routine
; RESULT - number associated with keyword in table, if OK
; FAIL - 0 if success, else 16 - Entry is not in table
; 17 - Entry is ambiguous
;
FORARG <KEYWRD,TAB,KEYNUM,FAIL>
sixbit /tblook/
TBLOOK: setzm @fail(cx) ;clear failure code
setzm @keynum(cx) ;and result code
movei t1,keywrd ;point to the keyword
call gtascz ;may be fortran v7
;* call gtbypt ;may be fortran v7
;* hrroi t1,@keywrd(cx) ;point to keyword to check
hrroi t2,atmbfr ;and a place to copy it to
setzb t3,t4 ;terminate copy on null
sin% ;read it in.
call ptspac ;return f77 string space
call trim ;strip trailing blanks from it
idpb t3,t2 ;Put on end of string
hrroi t2,atmbfr ;point to newly cleaned string
movei t1,@tab(cx) ;and to user's keyword table
addi t1,2 ;plus the offset to the real bit
tbluk% ;try a lookup for them.
erjmp cmderr ;only error is bad table
txne t2,tl%nom ;no match bit on ?
jrst [movei t1,errnsk ;yes, return no such keyword
movem t1,@fail(cx) ;to the patient user
ret] ;and go back to them
txne t2,tl%amb ;ambiguous keyword ?
jrst [movei t1,erramk ;yes, so return a fail code
movem t1,@fail(cx) ;to our caller
ret] ;and let them handle it
hrre t1,(t1) ;else grab the keyword code
movem t1,@keynum(cx) ;return it to the caller
ret ;and go home
subttl TBRLOC - relocate a command table written out to disk
;
; This routine is called to relocate all pointers in a command
; table which may no longer be at the memory address which it originally
; resided at. It uses pointers set up by TABLE initially, and resets those
; pointers on exit.
; Use: CALL TBRLOC(TABLE,STRINGS)
;
forarg <POINTS,STRINGS>
Sixbit /tbrloc/
tbrloc: movei t1,@points(cx) ;get address of table start
movei t2,@strings(cx) ;and of string stuff
addi t1,2 ;point to real start of TBLUK table
move t3,-1(t1) ;get old string address
sub t2,t3 ;find difference from new one
jumpe t2,[ret] ;if none, we can exit now.
hlrz t3,(t1) ;else get number of entries in TBLUK
tbrlo1: aoj t1, ;point to next entry in table
hlrz t4,(t1) ;get an address from the table
add t4,t2 ;relocate it
hrlm t4,(t1) ;put it back where we found it
sojn t3,tbrlo1 ;and loop through all entries
movei t1,@points(cx) ;now point to table start again
hrrz t3,(t1) ;retrieve next free string address
add t3,t2 ;relocate that too
hrrm t3,(t1) ;put it back where we got it
movei t2,@strings(cx) ;now get new address of strings
movem t2,1(t1) ;plonk it back in the pointers array
ret ;and go back to friendly caller
subttl KYALOW/KYDALW - insert or remove characters from break table
;
; This routine is called to modify the break tables used in the KYWORD
; routine. Normally, the standard keyword breakset, plus .,#, ,(,),/,:,',
; % and * are permitted. Both KYALOW and KYDALW are called with a single
; parameter - a string of characters to be inserted or removed from the
; break table. KYALOW adds the characters as valid ones (ie removes them
; from the breakset) ; KYDALW disallows the characters as keyword
; constituents (ie adds them to the breakset.) Using a null argument
; for either routine restores the default breakset.
;
FORARG <newset>
kyalow: seto t1,
skipa
kydalw: setz t1, ;flag allow or disallow
move t2,cx ;save arg pointer
trvar <alwflg> ;place to put flag
move cx,t2 ;restore arg pointer
movem t1,alwflg ;save it
movei t1,newset ;point to arg string
call gtascz ;retrieve string, ascizize if necessary
setz t2, ;zero count of characters done
kyalop: ildb t3,t1 ;else get a character
jumpe t3,kyrset ;if null, check for null string to do a reset
;
; Now take the ascii code, and divide by 32 to get quotient (word
; of mask to fiddle) and remainder (bit number within the word.)
; Then get a word with bit 0 on, and right shift by the remainder
; to get a word with a bit turned on correctly.
;
idivi t3,40 ;work out which word of the breakset to fiddle
push p,t1 ;lose the byte pointer for a bit
push p,t2 ;and the count
movx t1,1b0 ;get the most significant bit
movns t4 ;make the bit number negative for right shift
lsh t1,(t4) ;and move the bit to the right place
move t2,brkmsk(t3) ;get the word we have to fiddle
move t4,[tdo t2,t1] ;assume we light the bit (disallow)
skipe alwflg ;is that correct ?
move t4,[tdz t2,t1] ;no, we must clear to allow
xct t4 ;set or clear the bit
movem t2,brkmsk(t3) ;and put the mask back where we got it
pop p,t2 ;restore count
pop p,t1 ;and input pointer
aoja t2,kyalop ;loop for all characters
;
; Come here after reading null. If no characters processed, then
; call was a request to reset to default.
;
kyrset: push p,t2 ;save count (destroyed in FOROTS)
call ptspac ;unwind char stack, if necessary
pop p,t2 ;get count back
jumpn t2,r ;if non zero, just return
dmove t1,defbrk ;else get two words of default break
dmovem t1,brkmsk ;store in breakset area
dmove t1,defbrk+2 ;get the other two
dmovem t1,brkmsk ;store them too.
ret ;all done !
subttl CMDS - Initialize COMND, print errors, etc.
;
; This routine sets up the command storage block. Done once only.
;
cmdset: hrroi t1,cmdstg ;point to text buffer
movem t1,cmdblk+.cmptr ;store
movem t1,cmdblk+.cmbfp ;pointer to start-of-buffer
move t1,[.priin,,.priou] ;input,output jfns
movem t1,cmdblk+.cmioj ;store
setzm cmdblk+.cminc ;zero chars after pointer
movei t1,bufsiz*5 ;number of chars avail in buffer
movem t1,cmdblk+.cmcnt ;store
hrroi t1,atmbfr ;pointer to atom buffer
movem t1,cmdblk+.cmabp ;store in command state block
movei t1,atmsiz*5 ;number of chars avail in atom buf
movem t1,cmdblk+.cmabc ;store
setom initf ;mark intialized
ret ;return to CMDINI
;
; CMDINI - called by all routines to initialize prompt, set up
; for reparse.
; Called with t1 containing a prompt to prompt string
;
cmdini: IFNDEF $MACY,<
skipa ;don't call routine to set up data in...
call ftncmd ;...fortran common block
>
movem t1,cmdblk+.cmrty ;save prompt pointer
skipn initf ;initialized command block ?
call cmdset ;no, so do it
pop p,savret ;set up return address for reparse
movem p,savp ;save pushdown pointer
hlre t1,-1(cx) ;get number of arguments from FORTRAN
movnm t1,nargs ;store as a positive number
movei t1,reparse ;address of auto reparse routine
txz t1,cm%rai ;assume lowercase is lowercase
skipe raise ;does user want conversion to upper ?
txo t1,cm%rai ;yes, so light that bit
movem t1,cmdblk+.cmflg ;save in state block
movei t1,cmdblk ;get address of command state block
movei t2,[flddb. (.cmini)] ;function block for init
comnd% ;do it
erjmp cmderr ;some sort of error...
setzm hlpbfr ;clear our help message
jrst @savret ;return to caller via saved stuff
;
; Come here on a reparse
;
repars: move p,savp ;get back saved stack pointer
jrst @savret ;jump to caller of CMDINI for a reparse
;
; ENDCOM - called to confirm a command
; Returns +1 on error, +2 ok
;
endcom: movei t1,cmdblk ;address of command state block
movei t2,[ flddb. (.cmcfm)] ;get function - confirm
comnd% ;so confirm, baby
erjmp cmderr ;awful error
txnn t1,cm%nop ;parse OK ?
retskp ;yes, so return ok
skipn endnse ;confirm errors allowed ?
retskp ;yes, so return ok
ret ;no, so return badly
;
; Routine called when CONFIRM fails
;
cfmerr: skipn endnse ;are CONFIRM errors permitted ?
retskp ;yes, so just return
cfmer1: movem t1,t3 ;save reprompt address
errmes errcfm,,q1 ;print error
tmsg <, try again please>
pop p,t1 ;throw away return address
jrst (t3) ;and go and do it agian
;
; Routine called when fatal JSYS errors occure in COMND
;
cmderr: call tstcol ;get a new line if required
tmsg <?FTNCMD - unexpected, unrecoverable error: >
movei t1,.priou ;output JSYS error to terminal
hrloi t2,.fhslf ;this process, most recent error
setz t3, ;a message of any length
erstr% ;do so
trn
trn ;ignore errors in errors
tmsg <.
Please inform the software services manager of this problem. Apologies for
any inconvenience caused.
>
IFNDEF $MACY,<call crhalt> ;now get fortran to clean up
IFDEF $MACY,<HALTF%>
;
; Routine to strip trailing blanks from a string
; CALL with byte pointer to end of string in t1. A null is deposited
; over the first blank at the end of the string. All registers
; are preserved
;
strblk: push p,t1 ;save a register
push p,t2 ;or two
strbl1: ldb t2,t1 ;get a byte from the end of the string
caie t2," " ;is it a space ?
jrst strbl2 ;no, so put out the null
seto t2, ;yes, so get -1
adjbp t2,t1 ;back up the byte pointer by one
movem t2,t1 ;get the pointer back in the right ac
jrst strbl1 ;look at the next byte
strbl2: setz t2, ;get a null
idpb t2,t1 ;put it out over the space
pop p,t2 ;get back saved register
pop p,t1 ;and the other one
ret ;back to caller
;
; Routine to test cursor position, output a new line if required.
; CALL TSTCOL
; Returns +1 always.
;
tstcol: movei t1,.priou ;point at terminal
rfpos% ;read position
hrrz t2,t2 ;get just column position
jumpe t2,r ;if at left margin, just return
tmsg <
> ;else output a new line
ret ;and return too
SUBTTL chpars - call to check type of parse
;
; Routine to
; check which fdb was used to parse the input, t4 is address of fail flag
; Returns +1 error
; +2 ok - FDB address used in t3
;
chpars: txne t1,cm%nop ;no parse ?
ret ;yes, error return
hrrzs t3,t3 ;get the address of fdb used in parse
cain t3,fdb ;was it the main one ?
retskp ;return ok
cain t3,exifdb ;was it exit or unknown ?
jrst [hrrz t2,(t2) ;get contents of table entry
jrst (t2) ] ;jump to exit or unknown routine
cain t3,bakfdb ;was it ^ ?
jrst [movni t2,3 ;yes, so return a -3
movem t2,(t4) ;send to fail flag
call endcom ;get confirmation
jrst [setzm (t4) ;no, so clear fail flag !
ret ] ;and do error stuff
pop p,q4 ;get rid of return to macro routine
cain q2,0 ;alternate return not supplied ?
ret ;yes, return ok to fortran direct
setzm (t4) ;clear fail flag as we are doing it
pop p,q4 ;get rid of fortran return
jrst (q2) ] ;do alternate return
retskp ;if no match, assume extra fdbs (as in
; TEXTIN)
exit: call endcom ;get confirmation
ret ;no so do error stuff
pop p,q4 ;get rid of return to macro routine
skipn exilab ;is exit label provided ?
jrst [movni t2,2 ;no so set fail flag to -2
movem t2,(t4) ;and move to fail
ret ] ;and return to fortran
pop p,q4 ;yes, get rid of fortran return
jrst @exilab ;take return to exit label
unknow: call endcom ;get confirmation
ret ;no so do error stuff
pop p,q4 ;get rid of return to macro routine
movni t2,1 ;set fail flag to -1
movem t2,(t4) ;and move to fail
movem (q3) ;set answer to 0
ret ;and return to fortran
;
END