PDP-10.its/src/klh/macros.84

IF2 .INEOF		; Never read on 2nd pass, nothing to re-define.
IF1 IFDEF %%%MAC .INEOF	; This checks for file already .INSRT'd.
%%%MAC==1		; Aha, first!  Prevent other .INSRT's from winning.
;----------------------------------------------------------------------------

; Determine what OS to assemble for.  To force a particular OS,
; simply set OS%==SIXBIT/foo/ where foo is one of
;	ITS,CMU,SAIL,DEC,TENEX,TWENEX	mutually exclusive.
;	T10		equivalent to DEC
;	T20,20X		equivalent to TWENEX
;	10X		equivalent to TENEX
;	TNX		indicates either 10X or 20X, macro determines which.
; The following symbols are defined by this section:
;	Flag		Set if assembling for:
;	OS%ITS		ITS system (AI,ML,MC,DM)
;	OS%CMU		CMU system
;	OS%SAI		SAIL system
;	OS%T10		a vanilla Tops-10 system (neither SAIL nor CMU)
;	OS%DEC		set for all of the above 3 Tops-10 based systems.
;	OS%10X		BBN TENEX
;	OS%20X		DEC Tops-20 (TWENEX)
;	OS%TNX		set for both of the above 2 (10X or 20X).

ifndef os%,os%==.osmidas
%%t==0
irp pair,,[[ITS,its],[DEC,t10],[CMU,cmu],[SAIL,sail],[TENEX,10X],[TNX,tnx],[10X,10x],[20X,20x],[TWENEX,20x]]
  irp sys,flg,[pair]
  ife os%-sixbit/sys/, os%!flg==1
  .else ifndef os%!flg, os%!flg==0
  %%t==%%t+os%!flg
  .istop
  termin
termin
ife %%t,.err Can't determine OS to assemble for!
expunge %%t

	; Fixups...
ifn os%tnx,[		; If TNX of some kind, find exact variety.
ife .osmidas-sixbit/tenex/, os%10x==1
.else os%20x==1
]
os%tnx==os%10x+os%20x	; TNX on if either 10X or 20X.
os%t20==os%20x		; T20 synonym for 20X.
os%dec==os%t10\os%cmu\os%sai	; DEC means a T10-like sys.

;------------------------------------------------------------------
; Note: the following stuff is not completely thought out.  Mainly it
; tries to ensure that a standard exists for specifying CPU type
; and that all CPU-dependent symbols are properly defined.
; This benefits various .insrt-able packages like NUUOS.

; Find what CPU to assemble for.  To force a particular CPU,
; set CPU%==SIXBIT/foo/ where foo is one of:
;	KA	defaults to this.  Standard vanilla PDP-10
;	KI	very slightly hairier.
;	KL	current zenith, standard for 20X.
;	K*	means set flags to "good guess".
;	RUNTIM	means use run-time determination.
; The following symbols are defined by this section:
;	CPU%KA		set if should assemble specifically for KA
;	CPU%KI		 "   "    "       "         "        "  KI
;	CPU%KL		 "   "    "       "         "        "  KL
;	CPU%X		set if should use run-time determination.
;
; In general, code should be written to run on any processor.  These
; flags are intended to be used only for special circumstances where
; the differences can be significant and binary portability is not
; as important.  (For runtime determination of OS and CPU, see
; forthcoming .insrt-able routines, which should set variable flags
; of the form OS.TNX, CPU.KA, etc. )

ifndef cpu%, cpu%==sixbit/KA/	; Always force to KA unless overridden
irp pair,,[[KA,ka],[KI,ki],[KL,kl],[RUNTIM,x]]
irp m,s,[pair]
  ife cpu%-sixbit/m/, cpu%!m==1
  .else cpu%!m==0
termin
termin
ife cpu%-sixbit/K*/,{	; Make good guess
	ifn os%20x, cpu%kl==1
	.else cpu%ka==1
}
ife cpu%ka\cpu%ki\cpu%kl\cpu%x, .err Can't determine CPU to assemble for!

;------------------------------------------------------------------

DEFINE INFORM A,B,C,D,E,F,G
PRINTX \A!B!C!D!E!F!G
\
TERMIN

	; DEFAULT no-op'ing of purification macros if they're
	; not already defined to do something.
IFNDEF BVAR,[
DEFINE BVAR		; Make BVAR, EVAR, and LVAR all do nothing.
TERMIN
EQUALS EVAR,BVAR
EQUALS LVAR,BVAR
DEFINE VARCHK		; VARCHK always has this side effect.
VARIABLES
TERMIN ]

	; Defs for ITS .CALL system call.
IFN OS%ITS,[
CIMM==1000,,0	; Immediate arg  (also seen as MOVEI)
CRET==2000,,0	; Value returned (also seen as MOVEM)
CERR==3000,,0	; Error code returned
CTL== 4000,,0	; Control bits at loc
CTLI==5000,,0	; Control bits, immediate

DEFINE SYSCAL A,B
	.CALL [SETZ ? SIXBIT/A/ ? B ((SETZ))]
TERMIN
]

%SIGN==SETZ	; Define full-word Sign bit.
%HSIGN==400000	; and Halfword sign bit.

	; Common byte-pointer LH's
IFNDEF $OPCOD,$OPCOD==331100	; Instruction op-code
IFNDEF $ACFLD,$ACFLD==270400	; Instruction AC field
IFNDEF $IFLD,$IFLD==220400	; Instruction (I) field (maybe shd be $XFLD)
IFNDEF $ATFLD,$ATFLD==260100	; Instruction @ field (maybe shd be $IFLD)
IFNDEF $ERRCD,$ERRCD==220600	; Error code from .STATUS wd (ITS only)
IFNDEF $PFLD,$PFLD==360600	; P field of byte pointer
IFNDEF $SFLD,$SFLD==300600	; S field of byte pointer

	; Macro to decrement 7-bit byte ptr in ac (no checking)
DEFINE MDBP7 AC,FOO
ADD AC,[70000,,0]	; Increase P
CAIG AC,0		; Skip,
 SUB AC,[430000,,1]	; unless went off edge, in which case reset.
TERMIN
EQUALS MD7BPT,MDBP7	; Remain compatible with old names
EQUALS MDBPT, MDBP7

	; Page-size parameters, OS dependent
IFNDEF PG$BTS,{	IFN OS%TNX, PG$BTS==9.		; # bits of address in a page.
		IFN OS%ITS, PG$BTS==10.
}
PG$SIZ==1_PG$BTS	; Page size in # words.
PG$MSK==PG$SIZ-1	; Mask for page address bits.


	; Define some "instructions".
IFNDEF P,P=:17 ? .ERR P undefined, using P=17.
IFNDEF CALL,CALL==:<PUSHJ P,>	; More efficient than macro.
IFNDEF RETURN,RETURN==:<POPJ P,>
IFNDEF RET,RET==:<POPJ P,>
IFNDEF CALRET,CALRET==:JRST	; Better name for PJRST.
IFNDEF PJRST,PJRST==:JRST	; JRST to a popj'ing routine
IFNDEF NOP,NOP=:<IFN CPU%KL,{TRN}.ELSE {JFCL}>	; What the hell.

DEFINE PUSHAE AC,LIST
IRP LOC,,[LIST]
PUSH AC,LOC
TERMIN
TERMIN

DEFINE POPAE AC,LIST
IRP LOC,,[LIST]
POP AC,LOC
TERMIN
TERMIN

	; TMPLOC <loc>,<parenthesized arg> - puts argument at given LOC
	;	without changing location counter outside macro call.
DEFINE TMPLOC VAL,?ARG
%%%TLC==.
LOC VAL
ARG
LOC %%%TLC
TERMIN

IFNDEF %%%ASC,%%%ASC==0	; Default is old mode, i.e. ASCNT [str]
IFE %%%ASC,[
	; ASCNT [string] - produces word of <char cnt>,,<addr to string>
DEFINE ASCNT STR
.LENGTH 
STR
,,[ASCIZ 
STR
]!TERMIN

DEFINE LITSTR STRING
[ASCNT [STRING]]TERMIN

	; ASCSTR [string] - produces 2 words of constant string descriptor,
	;	<char cnt> ? <BP to string>
DEFINE ASCSTR STR
.LENGTH 
STR

440700,,[ASCIZ 
STR
]!TERMIN

] ; end IFE %%%ASC

IFE %%%ASC-1,[		; New style, i.e. ASCNT /str/

DEFINE ASCNT &STR&
.LENGTH STR,,[ASCIZ STR]!TERMIN

DEFINE LITSTR &STR&
[ASCNT STR]!TERMIN

DEFINE ASCSTR &STR&
.LENGTH STR
440700,,[ASCIZ STR]!TERMIN

] ; IFE %%%ASC-1

; NETHANG - macro interface to use NETBLK call.  Hangs until specified
; net channel changes state, or call times out.
;	MOVEI AC,<channel>
;	NETHANG <timeout in 30th's>,AC,<hang state>,[<winning states>]
;	 failure return (timed out or non-winning new state)
;	win return (changed to winning state)
; Always returns new state in AC.

IFN OS%ITS,[	; Only for ITS (in theory could hack for TNX)
DEFINE NETHANG TIMOUT,AC,HANGST,NEWSTL
JRST [	MOVEM AC,TMSTOR'
	MOVE AC,[TIMOUT]
	EXCH AC,TMSTOR
	SYSCAL NETBLK,[AC ? [HANGST] ? TMSTOR ? CRET AC]
	 JRST .+1
IRP CODE,,[NEWSTL]
	CAIN AC,CODE
	 JRST .+2
TERMIN
	JRST .+1]
TERMIN
] ; IFN OS%ITS

; BLKINI, BLKADD - couple of hairy macros that take a given <blockname>
;	and turn it into repository of text, initialized by BLKINI <name>
;	added to by BLKADD <name>,[<text to add>].
;	To dump text, simply stick <name> someplace after all has been added.

DEFINE BLKINI BLKNAM	; Initialize specified blockname.
DEFINE BLKNAM ARG
ARG
TERMIN
TERMIN

DEFINE BLKADD BLKNAM,NEW	; Add stuff to specified blockname.
BLKNAM [DEFINE BLKNAM ARG
ARG]NEW
TERMIN
TERMIN


IFN OS%ITS,[	; Clock stuff really not used by anything much.

	; Macro to clear clock and set frame time for interrupts
DEFINE CLKSET (TMOLOC)
	PUSH P,A
	MOVE A,[600000,,TMOLOC]
	.REALT A,
	JFCL
	POP P,A
TERMIN

	;to enable clock interrupts
DEFINE CLKON
	.SUSET [.SAPIRQC,,[%PIRLT]]	;turn off any pending realt
	.SUSET [.SIMASK,,[%PIRLT]]	;enable it
TERMIN

	;to disable
DEFINE CLKOFF
	.SUSET [.SAMASK,,[%PIRLT]]
TERMIN

] ; IFN OS%ITS

;-------------------------------------------------------------
; Old Super duper macro to make output a breeze.  Requires UUOS.
; This stuff is obsoleted by an even more super-duper macro
; contained in the OUT output package, but can still be used for
; the sake of compatibility.
IFNDEF $$OUUO,$$OUUO==0	; Default is not to use old output UUOs.

DEFINE FWRITE CH,LIST
IFE $$OUUO, MOVEI OC,CH
%F==0
IRP ITM,REM,[LIST]
IFN %F,[%F==0 ? .STOP]
IFNSQ [ITM] .GO O
IFNDEF %%.!ITM, .GO O
IRP ARG,,[REM] ? %%.!ITM CH,[ARG] ? .ISTOP ? TERMIN
%F==1 ? .STOP
.TAG O
%%.TC CH,[[.LENGTH 
ITM
,,[ASCII 
ITM
]]]
TERMIN
TERMIN

DEFINE MAKSTR LOC,LIST	; For making string in one fell swoop.
BCONC
FWRITE STRC,[LIST]
ECONC LOC
TERMIN

DEFINE CONC LOC,LIST	; For concatenating stuff to existing string.
BCONC LOC
FWRITE STRC,[LIST]
ECONC LOC
TERMIN

DEFINE DEFWR ITM,INSTR,INTNAM	; Make easy to define simple items.
IFN $$OUUO,{			; Use old output UUOs
DEFINE %%.!ITM C,ARG
OU!ITM C,ARG
TERMIN .STOP }

IFB [INSTR]{IFB [INTNAM] DEFX2 %%.!ITM,MOVE U3,OX!ITM
		.ELSE	DEFX2 %%.!ITM,MOVE U3,INTNAM
	.STOP }
IFB [INTNAM] DEFX2 %%.!ITM,INSTR,OX!ITM
.ELSE	DEFX2 %%.!ITM,INSTR,INTNAM
TERMIN

DEFINE DEFX2 WITM,INSTR,RTN
DEFINE WITM C,ARG
INSTR,ARG
CALL OUT"RTN
TERMIN
TERMIN

;------------------- FWRITE item routines ------------------
; item is in form "%%.<item-name> <channel>,<argument>"
;  Note that if item takes no argument and it is the last thing in FWRITE,
; a space should follow the comma, as in FWRITE CH,[[foo],WAI, ]
; Otherwise MIDAS botches it with no err message.

DEFWR TLS,,OXLS		; "TLS" - Text, List String.
DEFWR TA,MOVEI U1,OXAR	; "TA" - Text, Area.  outputs whole area.
DEFWR TS,MOVEI U3,OXS	; "TS" - Text, String.  outputs string var.
DEFWR N10,,OXN10.	; "N10" - Number, base 10 ; signed decimal value,
DEFWR N9,,OXN10		; "N9" - N10 without decimal point.  Kludge.
DEFWR N8,,OXN8		; "N8" - Number, base 8.  Signed octal value.
EQUALS %%.OCT,%%.N8	; "OCT" - N8
EQUALS %%.DEC,%%.N10	; "DEC" - N9
DEFWR NFL,,OXNFL	; "NFL" - Number, FLoating.  From MACLISP.
DEFWR TI,MOVEI U1,OXC	; "TI" - Text Immediate.  Outputs arg as char
DEFWR TZ,MOVEI U3,OXZA	; "TZ" - Text ASCIZ.  Outputs asciz string
DEFWR TC,,OXTC		; "TC" - Text, Count.  Outputs ASCNT string at arg
DEFWR TPZ,,OXZ		; "TPZ" - Text, BP ASCIZ.  c(ARG) is BP to asciz string
DEFWR TPC,,OXPC		; "TPC" - Text, BP Count.  c(ARG) is #,,[bp]
DEFWR 6F		; "6F" - outputs c(arg) as sixbit without trailing bls
DEFWR 6W		; "6W" - outputs all of c(arg) as sixbit
DEFWR 6Q		; "6Q" - like 6F but puts ^Q in front of punct. chars

; Weird cookies

IFN $$OUUO,[
DEFINE DEFWRN ITM,INSTR,UUO
DEFINE %%.!ITM C,ARG
INSTR U4,ARG
UUO C,U4
TERMIN
TERMIN

DEFWRN RH,MOVE,OUNRH	; "RH" - outputs RH of c(ARG) in octal (6 chars)
DEFWRN LH,HLRZ,OUNRH	; "LH" - outputs LH of c(ARG) in octal (6 chars)
DEFWRN RHV,HRRZ,OUN8	; "RHV" - rh(arg) as octal number, not bit pattern
DEFWRN LHV,HLRZ,OUN8	; "LHV" - lh(arg) as octal number
DEFWRN RHS,HRRE,OUN8	; "RHS" - rh(arg) as signed octal number
DEFWRN LHS,HLRE,OUN8	; "LHS" - lh(arg) as signed octal number

DEFINE DEFWH ITM
DEFINE %%.!ITM C,ARG
%%.L!ITM C,ARG
%%.TZ C,[[ASCIZ /,,/]]
%%.R!ITM C,ARG
TERMIN
TERMIN

DEFWH H		; "H" - outputs c(ARG) in halfwd format (LH,,RH)
DEFWH HV	; "HV" - lhv,,rhv
DEFWH HS	; "HS" - lhs,,rhs

DEFINE %%.TZ$ C,ARG	; "TZ$" - Text ASCIZ crock. RH(c(arg)) is addr of asciz
MOVE U4,ARG		;	(like OUTZ C,@ARG but avoids more indirection)
OUTZ C,(U4)
TERMIN
] ; IFN $$OUUO

IFE $$OUUO,[
DEFWR RH,HRRZ U3	; RH(aval) - Right halfword, full.
DEFWR LH,HLRZ U3,OXRH	; LH(aval) - Left halfword, full.
DEFWR RHV,HRRZ U3,OXN8	; RHV(aval) - RH as octal num, not bit pattern.
DEFWR LHV,HLRZ U3,OXN8	; LHV(aval) - LH as octal num, not bit pattern.
DEFWR RHS,HRRE U3,OXN8	; RHS(aval) - RH as signed octal num
DEFWR LHS,HLRE U3,OXN8	; LHS(aval) - LH as signed octal num
DEFWR H,,OXHWD		; H(aval) - Halfword (123,,456)
DEFWR HV		; HV(aval) - LHV,,RHV
DEFWR HS		; HS(aval) - LHS,,RHS
DEFWR TZ$,HRRZ U3,OXZA	; TZ$(a-[a-asciz]) like TZ(@A) but avoids
] ;IFE $$OUUO

DEFINE %%.ERR C,ARG	; "ERR" - System error message.  If arg is blank,
IFN $$OUUO,MOVEI OC,C
IFB [ARG] CALL OUT"OXERRL	; use last err, otherwise arg is error code
.ELSE	MOVE U3,ARG ? CALL OUT"OXERR
TERMIN

DEFINE DEFWRT ITM,RTN,OUTRTN
DEFINE %%.!ITM!I C,ARG		; Def the "immediate" version.
%%.!ITM C
TERMIN
IFN $$OUUO,{
DEFINE %%.!ITM C,ARG
PUSH P,A
IFNB [ARG] MOVE A,ARG
.ELSE CALL TIMGET
CALL RTN
%%.TC C,A
POP P,A
TERMIN
.STOP }	; IFN $$OUUO

DEFINE %%.!ITM C,ARG
IFB [ARG]{	; If no arg, use current time.
	IFN OS%ITS, CALL OUT"UTMGTS
	IFN OS%TNX, SETO U3,
} .ELSE MOVE U3,ARG
	MOVEI U1,OUT"OUTRTN
	CALL OUT"OXTXS
TERMIN
TERMIN

DEFWRT WA,TIMDTM,OXTMDT	; "WA" - When, type A. "mm/dd/yy hh:mm:ss"
DEFWRT WB,TIMEXP,OXTME	; "WB" - When, type B. "dd mmm yy hhmm zon"
DEFWRT WC,TIMTIM,OXTMTS	; "WC" - When, type C. "hh:mm:ss"
DEFWRT WD,LTMEXP,OXTMX	; "WD" - When, type D. "dd month yyyy hh:mm zon"

; "HN" - takes host # from arg and outputs number, performing
; simplifications where appropriate.  Intended for use with new (HOSTS3)
; host table.
; Note that the $$OUUO==1 version is obsolete, and should be flushed asap.

IFN $$OUUO,[

DEFINE DEFWRH ITM,RTN
DEFINE %%.!ITM C,ARG
MOVE U4,ARG
LDB U3,[NETWRK"NW$BYT,,U4]	; If no string exists, check number.
CAIN U3,12			; Arpanet?
 PUSHJ P,[
IFDEF $$HST3,IFN $$HST3,.ERR You are going to lose.  Flush the $$OUUO==1 !!
	TDNE U4,[777,,77700774]	; Are any extended bits set?
	 POPJ P,		; If so, just print number (hack "/" fmt later)
	DPB U4,[170200,,U4]	; Move host # ahead of imp #
	LSH U4,-9.
	ANDI U4,377
	POPJ P,]		; finally output old-form number
RTN C,U4	; not arpanet?? just print.
TERMIN
TERMIN

DEFWRH HN,OUN8		; Output host number in octal
DEFWRH HND,OUN9		; Ditto in decimal

; "HST" - takes host # from arg and outputs name or #
; This version works with new host table file
DEFINE %%.HST C,ARG	; "HST" - takes host # from arg and outputs name or #
	PUSHAE P,[A,B,D] ;clobbered by HSTSRC routine 
	SKIPN B,ARG 
	 MOVE B,OWNHST 
	PUSHJ P,NETWRK"HSTSRC	;make A point to asciz name
	 PUSHJ P,[
		%%.HN C,B	; Output number.
		JRST POPJ1]
	OUTZ C,(A)
	POPAE P,[D,B,A]
TERMIN
] ;IFN $$OUUO

IFE $$OUUO,[
IRP ITM,,[HN,HND,HST]
DEFINE %%.!ITM C,ARG
MOVE U3,ARG
CALL OUT"OX!ITM
TERMIN
TERMIN
] ;IFE $$OUUO

;		Character Table Macros

;	These macros facilitate use of 200-word arrays indexed by
; an ASCII character.  A standard table definition is furnished which
; can be inserted where desired, and each insertion may be altered
; as necessary.


	; Character class flag definitions - all in LH

ch%msk==377000		; Note sign bit not included; user can set.

ch%ul== 200000		; Uppercase Letter (A-Z)
ch%ll== 100000		; Lowercase Letter (a-z)
ch%d==   40000		; Digit (0-9)
ch%pt==  20000		; Printing (41-176; all but CTLs, SP, DEL)
ch%wsp== 10000		; Whitespace (SP, TAB)
ch%fmt==  4000		; ForMaT effector (^H, ^I, ^J, ^K, ^L, ^M)
ch%lbr==  2000		; Left BRacket  (<[{
ch%rbr==  1000		; Right BRacket }]>)

		; Some useful combinations
ch%l==ch%ul+ch%ll	; Letter (upper or lower case)
ch%ld==ch%l+ch%d	; Letter or Digit
ch%uld==ch%ul+ch%d	; Uppercase Letter or Digit
ch%lld==ch%ll+ch%d	; Lowercase Letter or Digit
ch%br==ch%lbr+ch%rbr	; Brackets

; CHTMAC - macro defining a character table with standard flags.
;	Can be used as-is just by putting "chtmac" someplace, but
;	also serves as a model for defining non-standard tables.

define CHTMAC
chrtab==.		; Addr of latest table.
repeat 200,c.set \.rpcnt,0	; Reserve 200 locs and set values to char only.
chrgrp addl,.ascvl/A,.ascvl/Z,,ch%ul	; Add flag ch%ul to chars "A-"Z incl
chrgrp addl,.ascvl/a,.ascvl/z,,ch%ll	; Add flag ch%ll to chars "a-"z
chrgrp addl,.ascvl/0,.ascvl/9,,ch%d	; Add flag ch%d  to chars "0-"9
chrgrp addl,41,176,,ch%pt	; Add flag ch%pt to chars 041-176 inclusive
chrgrp addl,^I,," ",ch%wsp	; Add flag ch%wsp to chars ^I and 40
chrgrp addl,^H,^M,,ch%fmt	; Add flag ch%fmt to chars ^H-^M inclusive
chrgrp addl,133,,"(<{",ch%lbr	; Add flag ch%lbr to 133 = [ and (,<,{.
chrgrp addl,135,,"}>)",ch%rbr	; Add flag ch%rbr to 133 = ] and },>,).
termin

; CHRGRP - Macro for easily setting ranges of chars in a table.
; Syntax is:
;	chrgrp <mode>,<beg>,<end>,<string>,<value>
; Applies <value> to specified chars according to <mode>.
; The range of chars to set can be specified in two ways; either
; or both can be used.
;	* All chars from <beg> to <end> INCLUSIVE.
;		If <end> is null, use only <beg>.
;		If <beg> is null, use nothing.
;		<beg> and <end> must be expressions, not chars.
;	* All chars in <string>, which has "strung" syntax.
;		If <string> is null, use nothing.
; Applicable modes are:
;	SET  -	like MOVE
;	SETR -	like HRR
;	ADD  -	like TDO
;	ADDL -	like TLO

define chrgrp mode,ch1,ch2,*str*,?val
if1 .stop
ifsn [ch1][]{
	ifsn [ch2][] %%%nc==1+<ch2>-<ch1>
		.else %%%nc==1
	%%%tlc==.
	loc chrtab+<ch1>
	 repeat %%%nc,c.!mode \<<ch1>+.rpcnt>,val
	loc %%%tlc
}
ifse [str][] .stop
%%%tlc==.
irpc c,,[str]
	loc chrtab+<.ascvl /c>
	c.!mode \<.ascvl /c>,val
	termin
loc %%%tlc
termin

; Define the <mode>s for CHRGRP.
define c.set #chr#,?val
<ch%!chr==val>
termin
define c.add #chr#,?val
<ch%!chr==ch%!chr\val>
termin
define c.addl #chr#,?val
<ch%!chr==ch%!chr\<val,,>>
termin
define c.setr #chr#,?val
<ch%!chr==<-1,,>&ch%!chr\val>
termin