github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-24 03:18:05 +00:00
Code Issues Releases Wiki Activity
PDP-10.its/src/klh/out.250
Eric Swenson a94bfe9cf7 Added support for FTP client and server.
2016-11-24 21:43:54 +01:00

2709 lines
74 KiB
Plaintext
Executable File
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; -*- Mode:MIDAS -*-
SUBTTL Switch setup, to-do comments.
;PRINT VERSION NUMBER
.TYO6 .IFNM1
.TYO 40
.TYO6 .IFNM2
PRINTX/ included in this assembly.
/
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; ;;;;;
;;;;; "OUT" ;;;;;
;;;;; NEW OUTPUT PACKAGE INTERFACE ;;;;;
;;;;; ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; ;;;;;
;;;;; Documentation in MC:KSC;?OUT > ;;;;;
;;;;; or [SRI-NIC]<NICPROG>OUT.DOC ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; REQUIRES:
;;;;; .INSRT MACROS - KSC;MACROS or <NICPROG>MACROS
;;;;; U1,U2,U3,U4 - Sequential ACs
;;;;; P - PDL AC
;;;;; AUTPSY - JSR'd to for fatal errors
;;;;; Certain items will require other defs if they are assembled.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
IFNDEF $$O%1T,$$O%1T==0 ; Initialize once-only flag
IFE $$O%1T-.PASS, .INEOF ; If already seen OUT package this pass, flush.
$$O%1T==.PASS
IFNDEF $$OUT,$$OUT==1 ; 1 = Using new OUT stuff. Flush flag eventually.
IFNDEF $$DQ,$$DQ==0 ; Not using DQ: device unless we understand it.
; Various item class conditional switches
IFNDEF $$OFLT,$$OFLT==0 ; Floating point output
IFNDEF $$OBUF,$$OBUF==0 ; UC$BUF Buffered output (must .INSRT PAGSER)
IFNDEF $$OTIM,$$OTIM==0 ; Time output items (must .INSRT TIMRTS)
IFNDEF $$OHST,$$OHST==0 ; Network Host name/# (on ITS, must .INSRT NETWRK)
IFNDEF $$OERR,$$OERR==0 ; OS Error string output (on ITS must define ERRCHN)
IFNDEF $$OPRF,$$OPRF==0 ; PRINTF routine hack
; More conditional switches needed when not using NUUOs.
IFNDEF UAREAS,UAREAS==0 ; Disable "uuo area" stuff
IFNDEF ULISTS,ULISTS==0 ; Likewise "uuo lists"
IFNDEF USTRGS,USTRGS==0 ; ditto "strings" stuff.
; Parameters
IFNDEF $$CHMX,$$CHMX==:20 ; Max # of channels user can use.
comment |
To-do stuff:
Interpreted O.-instrs vs. inline code
Interpretation: compact but slower.
Inline: faster, but larger. More flexible?
Finally decided to flush all $$ORID code (retaining old copy in case
it ever becomes useful, which seems unlikely)
Protocol for OC channel AC
Must preserve U2 (esp over UUO's) if == to OC.
Reshuffle 4 UUO ac's, so OC not in middle?(interfers with 2-ac stuff)
STDCH macro to set OC explicitly.
Should OUT save/restore? Yes - can specify alternate chan.
Should STDOUT?
For STDOUT(ch,arg) should preserve? force use of STDCH
to explicitly set.
Can use file of 2-AC instrs for CREFFin to find dependencies.
See whether any dep on U1/U2. If not, make U1 the channel AC?
Problem: UUO's clobber it, so can't simply make it
"default"... only within an OUT or similar.
Allow use of STDOUT, STDOBP.
Extend STDOUT macro to take chan, byte addr args?
Add STROUT plus ditto?
Pain to save/restore (unless all use OUT call?)
Screw if smashed by sub. User must know how to save/restore OC.
Put STRMOVE (from FSCOPY) in for string ops, allow direct access.
Have error macro to replace JSR AUTPSY, so that can specify string.
Something like:
CALL @[OUTERR ? ASCIZ /text/]
Implement recursive FMT... problem with hacking temp buffer. May
need to allocate extra space, etc.
Should allow user to specify string rtn for XCT-type channels.
Actually should specify vector holding everything necessary
such as string-mode rtn addr, unit-mode instr, overflow rtn addr,
etc.
|
subttl .BEGIN OUT - Macro definitions
.BEGIN OUT ; Start symbol block
.NSTGW ; Lots of hairy defs, make sure no storage assembled.
QMTCH==.QMTCH ; Save value and ensure
.QMTCH==0 ; package assembles with traditional quoting style.
SLEV==0 ; Stack level at start of OUT macro.
IF1 [ ; Begin moby conditional for macro defs
; Only assemble if pass 1.
;;; Establish stack macro
DEFINE .M"STK ; To use instead of (P).
(P)-OUT"SLEV!TERMIN
DEFINE DEFMOC NAME,*PRE*,*POST* ; Intermediate useful macro.
DEFINE NAME (CH,A=$,B=$,C=$,D=$,E=$,F=$,G=$,H=$,I=$,J=$,K=$,L=$,M=$,N=$,O=$,Q=$,R=$,S=$,T=$,U=$,V=$,W)
PRE
OUT"$!A
OUT"$!B
OUT"$!C
OUT"$!D
OUT"$!E
OUT"$!F
OUT"$!G
OUT"$!H
OUT"$!I
OUT"$!J
OUT"$!K
OUT"$!L
OUT"$!M
OUT"$!N
OUT"$!O
OUT"$!Q
OUT"$!R
OUT"$!S
OUT"$!T
OUT"$!U
OUT"$!V
.ERR No more than 20 arguments allowed!
.TAG HO
POST
TERMIN
TERMIN
DEFMOC .M"OUTCOD,|
IFNB [CH]{ PUSH P,OC ? MOVEI OC,CH ? OUT"SLEV==OUT"SLEV+1 }
|,|IFNB [CH]{ POP P,OC ? OUT"SLEV==OUT"SLEV-1 }|
DEFMOC .M"OUTCAL,|
PUSHJ P,[
IFNB [CH]{ HRLM OC,(P) ? MOVEI OC,CH }
OUT"SLEV==OUT"SLEV+1
|,|IFNB [CH]{ HLRZ OC,(P) }
OUT"SLEV==OUT"SLEV-1
POPJ P,]|
EXPUNGE DEFMOC
;;; Establish default for simple "OUT" to use.
EQUALS .M"OUT,OUTCOD ; For now, default is inline.
;EQUALS .M"OUT,OUTCAL ; Alternative would be default of CALL.
;;;-----------------------------------------------------------------
;;; Fundamental "OUT" item definitions
;;; These are critical to proper operation of the OUT macro!!
DEFINE $$ ; Invoked when no arg furnished, to terminate macro.
.GO HO
TERMIN
; Define appropriate macro for constant text output.
; Optimizes 1-char case.
DEFINE $ &TEXT&
IFN <.LENGTH TEXT>-1,{
MOVE U3,[.LENGTH TEXT,,[ASCII TEXT]]
CALL OUT"OXTC
}
.ELSE {
MOVEI U1,<ASCII TEXT>_-29.
STDOUT
}
TERMIN
; Continuation of single OUT, in case want to squeeze more items
; into a single OUT statement.
DEFINE $OUT (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V)
OUTCOD(,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V)
TERMIN
;;;--------------------------------------------------------
;;; More standard OUT items
;;; Not so fundamental to macro hackery,
;;; but closely tied to package.
DEFINE $CH (ARG) ; CH(chan) - Force to a new channel
MOVEI OC,ARG
TERMIN
DEFINE $OPEN (TYP,ARG,L,BS) ; Open the channel
MOVEI U1,TYP
MOVEI U3,[IFSN [ARG][]{ARG} .ELSE {[0]}
L+0
BS+0 ]
IFSN [L!BS][] TLO U3,<IFSN [L][]{(UC%LIM)} .ELSE {0} IFSN [BS][]{\(UC%BSZ)}>
CALL OUT"UOPEN3
TERMIN
DEFINE $PTV (ARG) ; Read channel I/O ptr
CALL OUT"UPTV
MOVEM U1,ARG
TERMIN
DEFINE $FRC ; Force out buffered stuff on channel
CALL OUT"OXFRC
TERMIN
DEFINE $RST ; Reset channel
CALL OUT"OXRST
TERMIN
DEFINE $CLS ; Close channel
CALL OUT"OXCLS
TERMIN
DEFINE $PUSH ; Push channel on IO PDL
CALL OUT"OXPUSH
TERMIN
DEFINE $POP ; Pop off PDL into channel
CALL OUT"OXPOP
TERMIN
DEFINE $POPALL ; Pop entire PDL
CALL OUT"OXPDLR
TERMIN
DEFINE $CALL (ARG) ; Invoke random routine.
CALL ARG
TERMIN
; Maybe this macro should take an initial arg saying
; how many additional instrs the field should apply to???
DEFINE $FMT (A,B,C,D)
OUT"$FMB(B,C,D)
OUT"$!A
OUT"$FME
TERMIN
DEFINE $FMB (WID,PREC,FILL,NUM=E,) ; Last "," needed to end default val.
HRREI U1,WID
IFB [PREC!FILL]{ CALL OUT"OXFST1 ? .STOP }
IFB [PREC] HRLOI U3,377777
.ELSE MOV!NUM!I U3,PREC
IFB [FILL]{ CALL OUT"OXFST2 ? .STOP }
MOVEI U4,FILL
CALL OUT"OXFST3
TERMIN
DEFINE $FME
CALL OUT"OXFDON
TERMIN
DEFINE $XCT (A)
A
TERMIN
;-----------------------------------------------------------------
; Value-printing "OUT" item routines.
; General fmt of numerical output items is
; N(<addr of num>,width,prec,fill)
; where N = O - Octal
; D - Decimal
; X - Hexadecimal
; F - Floating (at moment really G)
; E - Floating E fmt (at moment really G)
; G - Floating F/E fmt (whichever "best")
; See "FMT" for explanation of width,prec,fill.
IRP NAM,,[O,D,X,F,E,G]RDX,,[8,10,16,F,E,G]
DEFINE $!NAM (NUM,A,B,C)
IFNB [A!!B!!C] OUT"$FMB(A,B,C,N)
MOVE U3,NUM
CALL OUT"OXN!RDX
IFNB [A!!B!!C] OUT"$FME
TERMIN
TERMIN
DEFINE $N10 (ARG) ; "N10" - Number, base 10 ; signed decimal value,
MOVE U3,ARG ; with decimal point.
CALL OUT"OXN10
STDOUT(".)
TERMIN
; Following setup for DEFITM isn't very pretty, but is necessary
; to produce minimal macro code for each item. If only MIDAS
; had string variables!!!
DEFINE DEFIT2 ITM,*INSTR*,INTNAM ; Auxiliary for DEFITM below.
IFNB [INTNAM]{ DEFINE $!ITM (ARG)
INSTR
CALL OUT"INTNAM
TERMIN .STOP }
DEFINE $!ITM (ARG)
INSTR
CALL OUT"OX!ITM
TERMIN
TERMIN
DEFINE DEFITM ITM,INSTR,INTNAM ; Macro for standard item definitions.
IFSE [INSTR][]{ DEFIT2 ITM,"MOVE U3,ARG",INTNAM
.STOP }
IFSE [INSTR][-]{ DEFIT2 ITM,,INTNAM
.STOP }
IFE <INSTR>&17,{ DEFIT2 ITM,"INSTR U3,ARG",INTNAM
.STOP }
DEFIT2 ITM,"INSTR,ARG",INTNAM
TERMIN
DEFITM CRLF,- ; CRLF() - obvious
DEFITM EOL,- ; EOL() - same as CRLF
DEFITM TAB,- ; TAB() - output a tab
DEFITM SP,- ; SP() - output a space
DEFITM TLS,,OXLS ; TLS([slp]) - Text, List String.
DEFITM TA,MOVEI U1,OXAR ; TA(arpt) - Text, Area. Outputs whole area.
DEFITM TS,MOVEI,OXS ; TS([,,# ? bp]) - Text, String variable.
EQUALS $N9,$D
EQUALS $N8,$O
EQUALS $OCT,$O ; "OCT" - OCTal value of word, same as N8.
EQUALS $DEC,$N10 ; "DEC" - DECimal value of word, same as N10.
DEFITM NFL,,OXNFL ; NFL(aval) - floating number (G fmt)
DEFITM TZ,MOVEI,OXZA ; TZ(a-asciz) - Outputs asciz string
DEFITM TZ$,HRRZ,OXZA ; TZ$(a-[a-asciz]) like TZ(@A) but avoids
; further indirection (if LH non-z)
DEFITM TC,,OXTC ; TC([#,,[asciz]]) Outputs ASCNT string
DEFITM TPZ,,OXZ ; TPZ([bp]) - Outputs BYTEZ string
DEFITM TPC,,OXPC ; TPC([#,,[bp]]) a bit of a kludge.
DEFITM W,,OXWD ; W(aval) - 36 bit binary word, as-is.
DEFITM WLH,HLRZ,OXWD ; WLH(aval) - left halfword, binary, ditto.
DEFITM WRH,HRRZ,OXWD ; WRH(aval) - right halfword, ...
DEFITM WBA,,OXWBA ; WBA(#,,[ascii]) binary ASCNT (36 bit chars)
DEFITM RH,HRRZ ; RH(aval) - Right halfword, full (6 digits)
DEFITM LH,HLRZ,OXRH ; LH(aval) - Left halfword, full.
DEFITM HWD ; HWD(aval) - "LH,,RH"
EQUALS $H,$HWD ; H(aval) - same as HWD
DEFITM RHV,HRRZ,OXN8 ; RHV(aval) - RH as octal num, not bit pattern.
DEFITM LHV,HLRZ,OXN8 ; LHV(aval) - LH as octal num, not bit pattern.
DEFITM HV ; HV(aval) - LHV,,RHV
DEFITM RHS,HRRE,OXN8 ; RHS(aval) - RH as signed octal num
DEFITM LHS,HLRE,OXN8 ; LHS(aval) - LH as signed octal num
DEFITM HS,,OXNHS ; HS(aval) - LHS,,RHS
DEFITM 6F ; 6F(aval) - Outputs as sixbit without trailing sp.
DEFITM 6W ; 6W(aval) - Outputs all 6 sixbit chars
DEFITM 6Q ; 6Q(aval) - like 6F but quotes punct. chars with ^Q
; Arpanet host output items. Requires HOSTS3 and NETWRK, unless OS%TNX.
; For all 4 items, argument is a host number value (normally HOSTS3 fmt)
DEFITM HN ; HN(aval) - Host # simplifying if possible
DEFITM HND ; HND(aval) - like HN but decimal Internet fmt.
DEFITM HST ; HST(aval) - Host name (becomes HND if no name)
; HOST(aval,{item}) - Host name; if no name,
; output alternate item spec instead.
DEFINE $HOST (ARG,ALTITM)
MOVE U3,ARG
CALL OUT"OXHOST
IFB [ALTITM] NOP
.ELSE OUTCAL(,ALTITM)
TERMIN
;;; Idiosyncratic items
DEFINE $C (CH) ; C - character (furnish immediate value)
MOVEI U1,CH
STDOUT
TERMIN
DEFINE $S (CNT,BP) ; S - String([#],[bp])
MOVE U3,BP
SKIPLE U4,CNT
CALL @OUT"USCOPT(OC)
TERMIN
DEFINE $SL (SLP,SAR) ; String, List. SAR is optional LSE addr.
MOVE U3,SLP
IFB [SAR] CALL OUT"OXSL ? .STOP
SKIPE U1,SAR ; Feeble robustness.
CALL OUT"OXSLA
TERMIN
; Define item names for various chars which would fuck up
; MIDAS macro parsing if seen in literal string. Other
; baddies are CRLF and sometimes comma or double-quote.
IRP ITM,,[LABR,RABR,LBRK,RBRK,LBRC,RBRC,LPAR,RPAR]VAL,,[74,76,133,135,173,175,50,51]
DEFINE $!ITM
STDOUT(VAL)
TERMIN
TERMIN
DEFINE $ERR (ARG) ; "ERR" - System error message. If arg is blank,
IFB [ARG] CALL OUT"OXERRL ; use last err, otherwise arg is error code
.ELSE MOVE U3,ARG ? CALL OUT"OXERR
TERMIN
DEFINE $TIM (TYP,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"T$!TYP
CALL OUT"OXTXS
TERMIN
; DEFT - for matching subtype names with routines.
; Subtypes are defined in the $$OTIM section.
DEFINE DEFT ITM,RTN
IF2 T$!ITM==:RTN
TERMIN
] ;END MOBY PASS 1 CONDITIONAL
IF2 [ ; Only assemble if pass 2
; For anything that needs pass2 def?
] ; END PASS 2
.YSTGW ; OK to gen code now.
;;; Resolve a few awkward defs that are shared with other files
;;; which may or may not be inserted (specifically NUUOS)
IF2 IFNDEF AUTPSY, AUTPSY:
0 ? JRST 4,.
IF1 $$O%BP==0
IF1 IFNDEF MADBP7,$$O%BP==1
IFN $$O%BP,[ ; Needs 7-bit ADJBP macro and tables
DEFINE MADBP7 BP,CNT
MULI BP,5
ADD BP+1,UADBP7(BP)
ADD BP+1,CNT
MOVE BP,BP+1
IDIVI BP,5
SUB BP,UHADB7(BP+1)
TERMIN
; Subtracted from 0,,addr to give appropriate BP pointing at
; indexed char (ILDB to get it).
UHADB7: -010700,,1
-350700,,0
-260700,,0
-170700,,0
-100700,,0
-010700,,0 ; 5th char, may want to index table by UHADB7+1(A)
; so as to get pointer for LDB, not ILDB.
133500,,0 ; to handle -5 produced by 440700
repeat 4,0
UADBP7: -54300,,5
-104300,,4
-134300,,3
-164300,,2
-214300,,1
] ; IFN $$O%BP
SUBTTL Output package channel definitions
; $UNCHS - Establish how many channels will be used, and
; set things up so that package-related channel #'s
; will have space reserved for them, altho illegal for
; "user" channels.
IF1 [
%%LSV==. ? OFFSET -.+$$CHMX
UFLDC:: 0 ; OUT package field-output channel
IFDEF USTRGS,IFNDEF STRC,.M"STRC:: 0 ; UUO package string area channel
.M"$UNCHS:: ; REAL maximum legal # of channels.
OFFSET 0 ? LOC %%LSV ; Don't waste space
EXPUNGE %%LSV
] ;IF1
SUBTTL OUT channel maintenance - basic support
;;;;;;;;;;;;; Unit Output Inline Macro for OUT Channels ;;;;;;;;
; STDOUT outputs single byte in U1 on channel in OC.
; STDOUT(arg) outputs byte "arg" on channel in OC, clobbers U1.
DEFINE .M"STDOUT (A)
IFSN [A][] MOVEI U1,A
AOSLE @OUT"UCHCNT(OC)
PUSHJ P,OUT"UCHMP
XCT OUT"UCOPT(OC)
TERMIN
; STDOBP - variant of STDOUT to be used when there is a BP in
; U3 that may be susceptible to "bumping".
DEFINE .M"STDOBP (A)
IFSN [A][] MOVEI U1,A
AOSLE @OUT"UCHCNT(OC)
PUSHJ P,OUT"UCHMPX
XCT OUT"UCOPT(OC)
TERMIN
;;;;;;;;;;;;;;;;; Tables for OUT channels ;;;;;;;;;;;;;;;;;;;;
BVAR
UCOPT: BLOCK $UNCHS ; XCT'd unit-mode instruction
USCOPT: BLOCK $UNCHS ; Addr of string-mode routine
UCHCNT: BLOCK $UNCHS ; Addr of char countdown
UCNTS: BLOCK $UNCHS ; Char countdown if non-area
UCHLIM: BLOCK $UNCHS ; Original count allowed
UCHTYP: BLOCK $UNCHS ; <flags>,,<chan type>
IFN OS%TNX,UCHJFN: BLOCK $UNCHS ; JFN for channel if any
UCHSTB: BLOCK $UNCHS ; Byte ptr (UC$BPT) or ARPT (UC$UAR)
IFN UAREAS,[
UBMPSP: 0 ; Holds special ptr for string output UUO's to avoid area-shift
; clobberage.
; UCHSTB, and locs immediately following up to NUSPBP, will be
; adjusted automatically to compensate for any shifts of UUO areas.
NUSPBP==.-UCHSTB ]
EVAR
;-----------------------------------------------------------------
; OUT Channel types.
.M"UC$UAR==0 ; UAR - UUO area output. Channel type 0 for easy check.
.M"UC$XCT==1 ; XCT - Execute given instr for each output char
.M"UC$BPT==2 ; BPT - Byte PTr
.M"UC$IOT==3 ; IOT - .IOT/SIOT (or BOUT/SOUT)
.M"UC$BUF==4 ; BUF - Buffered UC$IOT
.M"UC$TRN==5 ; TRN - Translate into another chan.
.M"UC$NUL==6 ; NUL - Null output sink
.M"UC$NX==7 ;==> # of executable channel types.
.M"UC$SAO==7 ; SAO - Like UAR for LSE's String-Area.
.M"UC$NO==10 ;==> # of OPEN-able channel types.
UC%FLD==<7_5>,,0 ; Mask for type number (in AC field).
.M"UC%LIM==1000,,0 ; Arg flag meaning byte # limit specified.
.M"UC%BSZ==2000,,0 ; Arg flag meaning bytesize specified.
UC%DBF==200000 ; UCHTYP flag, means dynamic UC$BUF buffer.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Item OPEN(type,arg,arg2) - Opens an OUT channel. See OUT doc.
; If there is any chance that U3 will have I or X bits set at
; this point, then the following instr should be uncommented.
; In theory the $OPN macro will never use it.
;UOPEN2: HRRI U3,@U3 ; Set RH to true effective address.
; Entry point for $OPN macro invocation.
; OC - Channel #
; U1 - channel type
; U3 - <flags> <type>,[<arg1addr> ? <arg2addr> ? ... ]
UOPEN3: CAIL U1,UC$NO ; Check type
JSR AUTPSY ; Unknown type! Bad argument.
;; Should the following code be implemented?? Would it break
;; any programs, or be grossly inefficient, or what? --KLH 11/11/82
;; SKIPN UCHTYP(OC) ; Check existing channel type
;; JRST [ PUSHAE P,[U1,U3] ; Ugh, it's still open!
;; CALL OXCLS ; Close up the channel!
;; POPAE P,[U3,U1]
;; JRST .+1]
MOVEM U1,UCHTYP(OC) ; Store channel type, with zeroed flags.
PJRST @UOPENT(U1) ; Dispatch for further processing.
UOPENT: UOPNAR ; Area
UOPNX ; XCT
UOPNBP ; BPT
UOPNIO ; IOT
UOPNBF ; BUF
UOPNTR ; Transl.
UOPNNL ; NUL
UOPNSA ; SAO
IFN UC$NO-<.-UOPENT> .ERR UOPENT table loses
; Common return point for some types.
; U1 - unit-mode instr
; U4 - <lim>,,<no lim> rtn addrs for string-mode output.
UOPN3: MOVEM U1,UCOPT(OC) ; Store instruction for unit-mode byte output.
TLNE U3,(UC%LIM) ; Was limit explicitly specified?
JRST [ HLRZM U4,USCOPT(OC) ; Yes, use limit-type string routine.
MOVN U4,@1(U3) ; And get specified limit value.
JRST UOPN4]
HRRZM U4,USCOPT(OC) ; No, use no-limit string routine.
MOVSI U4,(SETZ) ; And use max neg # for "limit".
UOPN4: MOVEM U4,UCHLIM(OC) ; Set up limit.
MOVEM U4,UCNTS(OC) ; and count.
MOVEI U1,UCNTS(OC) ; Find addr of count
MOVEM U1,UCHCNT(OC) ; and store that.
RET
; UC$UAR - Channel type AREA
UOPNAR:
IFE UAREAS,JSR AUTPSY ; Lose if no area hackery assembled.
.ELSE [
MOVEI U4,@(U3) ; Get ARPT to area
UOPNA1: MOVEM U4,UCHSTB(OC) ; Store ARPT, instead of a BP
HLL U4,$ARTYP(U4) ; Get type bits.
MOVEI U1,$ARWPT(U4) ; Get addr to write place,
HRLI U1,(IDPB U1,) ; and insert instruction to XCT.
TLNN U4,%ARTCH ; But if area is in binary mode
MOVE U1,[CALL UOL.AW] ; need hairy insn
MOVEM U1,UCOPT(OC) ; Store XCT for unit mode,
MOVEI U1,$ARCHL(U4)
MOVEM U1,UCHCNT(OC) ; and addr to find char countdown in.
MOVEI U1,UOL.AR ; Get addr of string output rtn
TLNN U4,%ARTCH ; But if area is in binary mode
MOVEI U1,UOL.AB ; need different rtn
MOVEM U1,USCOPT(OC) ; and set up.
UOPNA9: CAIGE U3, ; Now, if sign bit was set in flags,
CALL UXRST ; reset the area.
RET
; UOL.AW - Binary word output routine for UC$ARs.
UOL.AW: MOVE U4,UCHSTB(OC) ; Get ARPT for area
MOVE U3,$ARWPT(U4) ; Get write ptr
MOVEM U1,@U3 ; Store down it
AOS $ARWPT(U4) ; Update ptr
RET
; UOL.AR - String output routine for UC$UAR type.
UOL.AR: ADDM U4,@UCHCNT(OC) ; Add into count
SKIPLE @UCHCNT(OC) ; Check it.
PUSHJ P,UCHMPX ; If no room left, go get some.
IFE OC-U2, PUSH P,U2
MOVE U2,@UCOPT(OC) ; Get BP used by the IDPB (from $ARWPT)
ILDB U1,U3
IDPB U1,U2
SOJG U4,.-2
IFE OC-U2,[
EXCH U2,(P) ; Now restore BP to area's $ARWPT
POP P,@UCOPT(OC) ]
.ELSE MOVEM U2,@UCOPT(OC)
RET
; UOL.AB - Binary-mode string output routine for UC$UAR type.
UOL.AB: ADDM U4,@UCHCNT(OC) ; Add into count
SKIPLE @UCHCNT(OC) ; Check it
PUSHJ P,UCHMPX ; If no room left, go get some
IFE OC-U2, PUSH P,U2
MOVE U2,UCHSTB(OC) ; Get area pointer
ILDB U1,U3 ; Get source word
MOVEM U1,@$ARWPT(U2) ; Write into the area
AOS $ARWPT(U2) ; Increment ptr
SOJG U4,.-3 ; Loop for all output wds
IFE OC-U2, POP P,U2
RET
] ; IFN UAREAS
; UC$XCT - Channel type XCT
UOPNX: MOVE U4,[UOL.X,,UOS.X] ; Specify string-mode rtns to use
MOVE U1,@(U3) ; Get instr to XCT
JRST UOPN3
; String output, XCT
UOL.X: SKIPG U1,U4
RET
ADDB U1,@UCHCNT(OC)
JUMPL U1,UOS.X2
CALL OVFS ; Handle overflow.
UOS.X: ADDM U4,@UCHCNT(OC)
UOS.X2: ILDB U1,U3
XCT UCOPT(OC) ; for now, really unit-mode.
SOJG U4,.-2
RET
; UC$BPT - Channel type BPT (Byte Ptr)
UOPNBP: MOVE U1,@(U3) ; Get byte ptr
MOVEM U1,UCHSTB(OC) ; And use that as channel state.
MOVE U1,[IDPB U1,UCHSTB]
ADDI U1,(OC) ; Make IDPB point to right BP
MOVE U4,[UOL.BP,,UOS.BP] ; Specify string-mode output rtns.
JRST UOPN3 ; Store instruction & other stuff.
; String output, BP
UOL.BP: SKIPG U1,U4
RET
ADDB U1,@UCHCNT(OC)
JUMPL U1,UOS.B2
CALL OVFS ; Handle overflow.
UOS.BP: ADDM U4,@UCHCNT(OC) ; Inc. count
UOS.B2: ILDB U1,U3
IDPB U1,UCHSTB(OC) ; BP lives there.
SOJG U4,.-2
RET
; UC$IOT - Channel Type IOT ("Hard" channel)
UOPNIO:
IFN OS%ITS,[ MOVE U1,[.IOT U1] ; Get unit operation
CAILE OC,17 ; Ch # must fit into AC field.
JSR AUTPSY
DPB OC,[$ACFLD,,U1] ; Store ch # into instr
]
IFN OS%TNX,[ MOVE U1,@(U3) ; Get JFN for channel
MOVEM U1,UCHJFN(OC) ; store
MOVE U1,[CALL U.BOUT] ; Set up instr to xct
]
MOVE U4,[UOL.IO,,UOS.IO] ; Specify string-mode output rtns
JRST UOPN3
IFN OS%TNX,[
U.BOUT: PUSHAE P,[1,2] ; Routine called for UC$IOT byte output
MOVE 1,UCHJFN(OC)
MOVE 2,U1
BOUT
POPAE P,[2,1]
POPJ P,
]
;String output, .IOT
UOL.IO: SKIPG U1,U4
RET
ADDB U1,@UCHCNT(OC)
JUMPL U1,UOS.I2
CALL OVFS ; Handle overflow.
UOS.IO: ADDM U4,@UCHCNT(OC) ; Bump cnt.
UOS.I2:
IFN OS%ITS,[ SYSCAL SIOT,[OC ? U3 ? U4] ; Trivial!
JSR AUTPSY ; ?!?!
]
IFN OS%TNX,[ PUSHAE P,[1,2,3]
MOVE 1,UCHJFN(OC) ; Set up JFN
MOVE 2,U3 ; bp to string
MOVN 3,U4 ; byte count
SOUT
POPAE P,[3,2,1]
]
RET
; UC$BUF - Channel type BUF (buffered UC$IOT)
; This code assumes U3 is of form
; <flags> <typ>,[ [arg] ? [lim] ? [bytesize]]
; <arg> is as for UC$IOT - on TNX, the JFN to use.
; <bytesize> is the size of bytes to use.
; Defaults to 7.
; <lim> is the buffer size, IN BYTES, to use.
; Defaults to one page.
; If negative, it is treated as an AOBJN pointer to
; the buffer; LH is # of WORDS.
; If unspecified or zero, the buffer is dynamically allocated.
; Be sure to CLS the channel, or the buffer will
; stay around forever!
UOPNBF:
IFE $$OBUF,JSR AUTPSY
.ELSE [ MOVE U1,U3 ; Get arg ptr into better place
IFN OS%TNX,[
MOVE U4,@(U1) ; Get 1st arg (JFN)
MOVEM U4,UCHJFN(OC) ; Store...
]
TLNN U1,(UC%BSZ) ; Was byte-size specified?
JRST [ MOVEI U3,440700 ; No, default to 7-bit. Set up BP LH
HRLZM U3,UCHSTB(OC)
MOVEI U4,5 ; and use this many bytes/wd
JRST UOPNB2]
SKIPLE U4,@2(U1) ; Get byte-size...
CAILE U4,36. ; Make sure it's reasonable.
JSR AUTPSY
MOVEI U3,440000
DPB U4,[060600,,U3] ; Insert it into S field of BP LH
HRLZM U3,UCHSTB(OC) ; and store LH for later use.
MOVEI U3,36.
IDIV U3,@2(U1) ; Find # bytes per word
MOVE U4,U3 ; Save
; Have <bytes per wd> in U4, now find buffer length.
UOPNB2: TLNN U1,(UC%LIM) ; Byte limit specified?
JRST UOPNBD ; Nope, use default.
SKIPGE U3,@1(U1) ; If <lim> is AOBJN, it specifies # words.
JRST [ HLRO U3,U3 ; Get -<# wds>
MOVN U3,U3
JRST UOPNB3] ; Go set up stuff.
JUMPE U3,UOPNBD ; If zero, use default of one page.
PUSH P,U3 ; Save # bytes
IDIVI U3,(U4) ; Find # words to use
CAIE U4, ; If any remainder,
ADDI U3,1 ; round up to next # of words.
POP P,U4 ; Restore # bytes (want to use exact # given).
JRST UOPNB4
UOPNBD: MOVEI U3,PG$SIZ
UOPNB3: IMULI U4,(U3) ; Find # bytes to use in buffer.
UOPNB4: MOVNM U4,UCHLIM(OC) ; Save -<# bytes> as limit.
MOVNM U4,UCNTS(OC) ; and set up actual countdown.
; Now have buffer length in U3 as # words. See if must allocate.
TLNE U1,(UC%LIM) ; Check again for <lim> existence.
SKIPL U1,@1(U1) ; Clobber arg ptr, skip if AOBJN given.
CAIA
JRST UOPNB5 ; Needn't allocate! U1 RH has buf addr!
IFE U2-OC,PUSH P,OC
MOVEI U1,(U3) ; Ask for this many wds.
IFDEF CORGET,CALL CORGET ; Get buffer space, return addr in U2
.ELSE JSR AUTPSY ? IF2 .ERR PAGSER package must be inserted for UC$BUF!!
MOVEI U1,(U2)
IFE U2-OC,POP P,OC ; Need hair when U2 == OC.
MOVSI U4,UC%DBF ; Must set "dynamic buffer" flag
IORM U4,UCHTYP(OC) ; so we remember to de-allocate later.
UOPNB5: ADDI U3,(U1) ; Find last addr + 1
HRLM U1,UCHLIM(OC) ; Save start addr of buffer
HRRM U1,UCHSTB(OC) ; and set up initial BP addr.
HRLI U1,(U1)
ADDI U1,1 ; Set up src,,src+1 for BLT zap.
SETZM -1(U1)
CAILE U3,(U1) ; Handle screw case of 1-wd buffer.
BLT U1,-1(U3) ; Clean out the buffer.
MOVEI U4,UCNTS(OC)
MOVEM U4,UCHCNT(OC) ; Set addr of countdown
MOVEI U4,UOL.BF ; Set string-mode rtn addr.
MOVEM U4,USCOPT(OC) ; Set it.
MOVEI U1,UCHSTB(OC)
HRLI U1,(IDPB U1,) ; Cons up unit-mode instr
MOVEM U1,UCOPT(OC) ; Set.
RET ; Done...
UOL.BF: SKIPG U1,U4 ; Get temp in U1
RET ; making sure something to write.
ADDB U1,@UCHCNT(OC) ; Add into count
JUMPGE U1,UOLBF1 ; Jump if buffer would be filled up.
ILDB U1,U3 ; Nope, just copy light-heartedly.
IDPB U1,UCHSTB(OC)
SOJG U4,.-2
RET
; "Overflow". Note that unlike usual case, we come here even
; when count is zero, in order to optimize bulk I/O.
; The idea behind this optimization is that if buffer is
; empty and byte sizes for request/output are same, we
; can output directly and skip the copy overhead!
; This is also done if stuff is already in the buffer but
; the new stuff is large enough to force two system calls anyway.
; Only possible problem is if something depends on size of
; string output for each sys call, eg if one wants to do PMAP
; type stuff. If that ever becomes desirable, a new output type
; or flag can be created.
UOLBF1: PUSH P,U3
HRRO U3,UCHLIM(OC) ; Get original limit (fill out LH)
SUB U1,U4 ; Get original countdown, -<# left>
CAMG U1,U3 ; Countdown increased from original?
JRST UOLBF2 ; No, making huge request of virgin buffer - Optimize!
MOVM U3,U3 ; Get positive buffer length
SUB U3,U1 ; Add # bytes of room left in buffer
CAMGE U3,U4 ; Will we need more than one sys call?
JRST UOLBF4 ; No, jump to copy & output.
UOLBF2: PUSH P,U1 ; Save -<# left>
LDB U1,[$SFLD,,-1(P)] ; Get S field of source BP
LDB U3,[$SFLD,,UCHSTB(OC)] ; Ditto for buffer BP
CAIE U1,(U3) ; If same, way's clear!
JRST UOLBF3 ; Nope, must convert via copy.
IFN OS%ITS,[
;;; Following code prevents the disoptimization of doing non-word-aligned
;;; SIOTs which are very slow in ITS
CAIE U1,7 ; Only if byte size is 7
JRST UOLB2A
PUSH P,U2
MOVN U1,(P) ; Space available in buffer
IDIVI U1,5
JUMPN U2,UOLB2B ; Mustn't SIOT
MOVE U1,U4 ; Amount to be output
IDIVI U1,5
JUMPN U2,UOLB2B
POP P,U2 ; Okay, go ahead
UOLB2A:
;;; End of antidisoptimization code
] ;IFN OS%ITS
EXCH U4,(P) ; Save output cnt on PDL, get back -<# left>
HRRO U3,UCHLIM(OC) ; Get -<buflen> for quick check...
MOVEM U3,UCNTS(OC) ; and reset limit in case no force-out.
CAMGE U3,U4 ; Anything at all in buffer?
CALL UFRCBI ; Yes, force it out using U4 for UCNTS.
POPAE P,[U4,U3] ; Then restore original source BP and cnt
CALRET UOS.I2 ; and go output directly via UC$IOT rtn!
IFN OS%ITS,[
UOLB2B: POP P,U2 ; This could be smarter!
]
UOLBF3: POP P,U1 ; Restore -<# left>
UOLBF4: EXCH U4,(P) ; Save output cnt, get back BP
MOVE U3,U4 ; Put BP in usual place
JUMPGE U1,UOLBF6 ; If buffer already full, skip copy.
ADDM U1,(P) ; Update saved output cnt.
MOVM U4,U1 ; and get cnt of chars to copy.
ILDB U1,U3 ; Twiddle
IDPB U1,UCHSTB(OC) ; twaddle
SOJG U4,.-2
UOLBF6: PUSH P,U3 ; Save source BP
CALL UFRCBA ; Buffer always full here; output All.
POP P,U3 ; Now restore source BP
POP P,U4 ; and updated count
JRST UOL.BF ; and start over...
; UFRCBF - Force out buffer. Clobbers U1,U3,U4.
; Alternate entry points UFRCBI - takes -<#left> countdown in U4 (Immediate)
; UFRCBA - sets -<#left> countdown to 0 (All of buffer)
UFRCBA: TDZA U4,U4
UFRCBF: MOVE U4,UCNTS(OC) ; Get -<# left>
UFRCBI: CAILE U4, ; Make sure something didn't trash buffer!
JSR AUTPSY ; Ugh, buffer overflowed?!?!
CALL UBFRST ; Reset buffer cnt/ptr, get -len in U1.
SUB U4,U1 ; -<# left> - -<buflen> = # to output.
JUMPG U4,UOS.I2 ; Output buffer as per UC$IOT type.
RET
; UBFRST - Called to reset buffer channel.
; Doesn't clobber U4, and leaves -<buffer len> in U1.
; UFRCBF depends on this.
UBFRST: MOVE U1,UCHLIM(OC) ; Get <bufaddr>,,<-len>
HLRZ U3,U1
HLL U3,UCHSTB(OC) ; Cons up new BP to start of buffer
TLZ U3,770000
TLO U3,440000 ; Force P to 1st byte in word.
MOVEM U3,UCHSTB(OC) ; and set up new ptr.
TLO U1,-1 ; Make length a kosher neg. num.
MOVEM U1,UCNTS(OC) ; Store to re-initialize countdown.
RET
] ;IFN $$OBUF
; UC$TRN - Channel type TRANSL (translate to another UUO chan)
; Ignores any count specified.
; Main hair is setting things up so unit-mode AOS and XCT
; will work; for everything else including string-mode, the
; mapping is straightforward.
UOPNTR: MOVE U4,@(U3) ; Get channel to translate to.
CAIL U4,$UNCHS ; Make sure it's reasonable!
JSR AUTPSY
MOVE U1,[XCT UCOPT]
ADDI U1,(U4) ; Do a XCT UCOPT+chan
MOVEM U1,UCOPT(OC)
MOVE U1,[@UCHCNT] ; Assemble an indirect into
ADDI U1,(U4) ; the target channel's countdown.
MOVEM U1,UCHCNT(OC)
MOVE U1,UCHSTB(U4) ; Just copy UCHSTB
MOVEM U1,UCHSTB(OC)
MOVEM U4,UCNTS(OC) ; and hide true channel # in unused count slot.
MOVEI U3,UOS.TR
MOVEM U3,USCOPT(OC)
RET
;String output, Translate.
UOS.TR: PUSH P,OC
MOVE OC,UCNTS(OC) ; Find right channel # to use.
CALL @USCOPT(OC) ; and go hack.
POP P,OC
RET
; UC$NUL - Null output sink
UOPNNL: MOVE U4,[UOS.NL,,UOS.NL] ; Specify string-mode rtns to use
MOVE U1,[NOP] ; Get instr to XCT
TLZ U3,(UC%LIM) ; Ignore any specified limit.
JRST UOPN3
UOS.NL: ADDM U4,@UCHCNT(OC) ; Might as well keep track of count.
RET ; But that's it.
; UCHMP - called when byte count on channel runs out during unit-mode
; output; see the STDOUT macro for context. Only other place this
; routine is called is from UAR-type string output.
; OC - channel #,
; @UCHCNT(OC) contains positive # of chars "over-run".
; for output to areas, this is # of chars needed.
; UCHMPX - variant in which
; U3 contains a BP that must be preserved across area bumps.
UCHMPX:
IFN UAREAS,[
MOVEM U3,UBMPSP ; Save U3 in holy place,
PUSHJ P,UCHMP ; so that its input ptr is bumped correctly if nec.
MOVE U3,UBMPSP ; Restore from sanctuary.
POPJ P,
]
UCHMP: PUSHAE P,[U1,OC,U3,U4]
UCHMP0: MOVE U1,UCHTYP(OC) ; Get channel type
JRST @OVFTAB(U1) ; Dispatch to appropriate handler
OVFTAB: OVFLAR ; UAR
OVFLX ; XCT
OVFLBP ; BPT
OVFLIO ; IOT
OVFLBF ; BUF
OVFLTR ; TRAN
OVFLNL ; NUL
IFN .-<OVFTAB+UC$NX>, .ERR OVFTAB Loses
; TRAN type overflow.
OVFLTR: MOVE OC,UCNTS(OC) ; Translate, get real chan #
JRST UCHMP0 ; and try again.
; BUF type overflow.
OVFLBF:
IFE $$OBUF,JSR AUTPSY
.ELSE [
SOS @UCHCNT(OC) ; Restore #-left to zero.
CALL UFRCBF ; Force out buffer
AOS @UCHCNT(OC) ; Allow for char wanting output
JRST UCHMP9 ; And return normally.
]
; NUL, XCT, IOT, and BPT type overflow.
OVFLNL:
OVFLX:
OVFLIO:
OVFLBP: MOVE U1,UCHLIM(OC) ; Get limit for channel
CAME U1,[SETZ] ; If using maximum, no limit.
JRST OVFLIM ; uh-oh, actually limiting... go handle.
MOVEM U1,UCNTS(OC) ; No limit, just reset count.
JRST UCHMP9 ; Return and output char.
; UAR type overflow
OVFLAR:
IFE UAREAS,JSR AUTPSY
IFN UAREAS,[
MOVE U1,UCHSTB(OC) ; Get ARPT for area
SKIPG U3,$ARCHL(U1) ; In char mode get # chars needed
JSR AUTPSY ; Ugh?? Called when not supposed to?
IFN USTRGS,[
CAIN U1,USTRAR ; Is this the string output area?
PUSHJ P,USTRGC ; Ugh, yes. Go see about GC'ing.
JRST OVFAR2 ; Didn't GC, proceed normally and expand
SKIPL $ARCHL(U1) ; If still need room after possible GC,
JRST OVFAR2 ; go expand normally.
ADDB U3,$ARCHL(U1) ; GC'd! Add to cnt of chars now available
JUMPL U1,UCHMP9 ; and exit if have enough now
OVFAR2:] ; else drop thru to normal expansion.
HLL U4,$ARTYP(U1) ; Get area type bits
TLNN U4,%ARTCH ; If binary mode
JRST OVFAR5 ; can write into whole thing
ADDI U3,4 ; Char mode - need to convert len to wds
IDIVI U3,5 ; Round up to # wds needed (clobbers U4)
MOVEM U3,ARUNIT ; Insert # as arg to UABUMP
PUSHJ P,UABUMP ; Go bumpit - adjusts $ARCHL.
SKIPLE $ARCHL(U1) ; Check to be SURE.
JSR AUTPSY ; Foo, didn't update or didn't get enough.
JRST UCHMP9
OVFAR5: MOVE U4,$ARWPT(U1) ; Current write ptr.
ADD U4,U3 ; New stuff would put us here.
CAMGE U4,$ARTOP(U1) ; If this would fit
JRST UCHMP9 ; no need to bump the area.
MOVEM U3,ARUNIT ; Else insert # as arg to UABUMP.
PUSHJ P,UABUMP ; Go bumpit.
JRST UCHMP9
] ;IFN UAREAS
OVFLIM: SOS @UCHCNT(OC) ; Restore original count
UCHMP8: AOS -4(P) ; Abnormal return - DON'T output char!!
UCHMP9: ; Normal return - output char.
POPAE P,[U4,U3,OC,U1]
POPJ P,
; OVFS - General-purpose overflow handler for string-mode routines.
; Only invoked for channels which are definitely being limited;
; it allows output only up to the limit specified.
; See BPT, IOT, etc. routines for context.
; This is a bit inefficient, could be improved by turning
; unit/string mode ops into NOPs.
; OC - channel #
; U1 - # chars overflowed
; U3 - source BP
; U4 - source cnt
; (P) - place to return for no-limit output
; -1(P) - place to return for no output at all.
OVFS: SUB U1,U4 ; Find original count of -<# left>
MOVEM U1,@UCHCNT(OC) ; Store back
MOVN U4,U1 ; Smash source cnt to max allowable
CAIG U4, ; If result is non-null then skip to output
POP P,U1 ; Else flush 1st return, take 2nd for no output
RET
; Old doc
; OUTPTV CH,[<returned cnt>] For use with UUO channels.
; Returns to c(E) the cnt of chars outputted on channel since
; opened. For channels opened into an area, this is
; the # of chars between start of area and current Write BP.
; End of Old doc
UPTV: MOVE U1,UCHTYP(OC) ; Get channel type.
PJRST @UPTTAB(U1)
UPTTAB: UPTAR ; Area
UPTX ; XCT
UPTBP ; BPT
UPTIO ; IOT
UPTBF ; BUF
UPTTR ; Transl.
UPTNL ; NUL
IFN UC$NX-<.-UPTTAB> .ERR UPTTAB table loses
UPTAR:
IFE UAREAS, JSR AUTPSY
.ELSE [ MOVE U4,UCHSTB(OC) ; Get ARPT
MOVE U1,$ARWPT(U4) ; Get write ptr into area
IFE OC-U2,PUSH P,U2
HRRZ U2,$ARLOC(U4) ; and "ptr" to start.
CALL UPDIF7 ; Find diff between the 2 ptrs
MOVE U1,U2
IFE OC-U2,POP P,U2
RET
]
UPTIO: UPTX: UPTNL: ; These types share similar code.
UPTBP: SKIPA U1,UCHLIM(OC) ; Find beginning count.
UPTBF: HRRO U1,UCHLIM(OC) ; BUF type has cruft in the LH.
SUB U1,@UCHCNT(OC) ; <-max> - <-max + cnt> = -cnt
MOVM U1,U1
RET
UPTTR: PUSH P,OC
MOVE OC,UCNTS(OC) ; Get true channel #
CALL UPTV
POP P,OC
RET
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Other maintenance routines
; OUTINI - Initialize output package.
OUTINI: PUSH P,OC
PUSH P,[$UNCHS] ; Keep cnt on PDL cuz ACs clobbered.
OUTIN2: SOSGE OC,(P)
JRST OUTIN3
CALL OXCLS ; Close channel
JRST OUTIN2
OUTIN3:
; Set up for field-output channel.
OUTCOD(,CH(UFLDC),OPEN(UC$BPT,[440700,,UFBUF],[$LUBUF]))
SUB P,[1,,1]
POP P,OC
RET
OIFRC:
OXFRC:
IFN $$OBUF,[
HRRZ U1,UCHTYP(OC) ; Get channel type
CAIN U1,UC$BUF ; If type BUF,
CALRET UFRCBF ; Go force it out,
]
RET ; else just return.
; Reset channel. Only meaningful for UAR and BUF.
OIRST:
OXRST: HRRZ U1,UCHTYP(OC) ; Get channel type
IFN $$OBUF,[
CAIN U1,UC$BUF
CALRET UBFRST ; Do special buffer reset if BUF.
]
IFN UAREAS,[
CAIN U1,UC$UAR
JRST [ MOVE U4,UCHSTB(OC) ; Get ARPT to area
HLL U4,$ARTYP(U4) ; and set up type bits
PJRST UXRST] ; and go reset area.
]
RET
OICLS:
OXCLS: HRRZ U1,UCHTYP(OC) ; Get channel type
CALL @OXCLST(U1) ; Do whatever needed for specific type
OXCLS7: MOVEI U1,UCNTS(OC)
MOVEM U1,UCHCNT(OC) ; Set safe address for count (not zero!!!)
MOVE U1,[CALL OBADCH]
MOVEM U1,UCOPT(OC) ; Store unit-mode instruction
MOVEM U1,USCOPT(OC) ; and string-mode rtn addr.
SETZM UCHTYP(OC) ; Make channel type "closed" (actually UAR,
IF2 IFNDEF APOPJ,APOPJ:
RET ; but what to do? Set -1?)
OXCLST: APOPJ ; Area
APOPJ ; XCT
APOPJ ; BPT
OCCLS ; IOT
OXCLS3 ; BUF
APOPJ ; Transl.
APOPJ ; NUL
APOPJ ; SAO
IFN UC$NO-<.-OXCLST> .ERR OXCLST table loses
OXCLS3:
IFE $$OBUF, JSR AUTPSY
IFN $$OBUF,[ ; Buffered output close.
CALL UFRCBF ; Buffered, must force out vestiges.
MOVE U3,UCHTYP(OC) ; Now get flags in LH
HLRZ U1,UCHLIM(OC) ; and buffer addr in U1
TLNE U3,UC%DBF ; Dynamically allocated buffer?
CALL CORREL ; Yup, must release it!
; Now drop thru to call OCCLS and proceed.
]
OCCLS:
IFN OS%ITS,{SYSCAL CLOSE,[OC] ? JSR AUTPSY }
IFN OS%TNX,{
PUSH P,1
HRRZ 1,UCHJFN(OC)
CLOSF
ERJMP .+1
POP P,1
}
RET
OBADCH: JSR AUTPSY ; Output attempted on closed channel.
RET
; IO Channel "PDL" - PUSH, POP, POPALL
IFN UAREAS,[
.SCALAR IOPDLP ; Address of ARBLK for IOPDL area.
.SCALAR IOPCNT ; # of channels pushed.
OXPUSH: ; Save channel vars
SKIPN U4,IOPDLP ; Get address of ARBLK
JRST [ UAROPN U4,[0 ? [200]] ; Must create, so make one.
HRRZM U4,IOPDLP
SETZM IOPCNT
JRST .+1]
AOS IOPCNT
HRRZ U1,$ARWPT(U4) ; Get write ptr,
HRRZ U3,$ARTOP(U4) ; and 1st non-ex addr,
CAIL U1,-$OCFRM(U3) ; and ensure enough room.
JRST [ MOVEI U4,$OCFRM
UAREXP U4,@IOPDLP ; Expand the area.
MOVE U4,IOPDLP ; Restore ARPT
HRRZ U1,$ARWPT ; Restore write ptr.
JRST .+1]
ADD U1,[1,,-1] ; Avoid PDLOV interrupt overhead and get ptr.
%%OCNT==.
IRP LOC,,[UCOPT,USCOPT,UCHCNT,UCNTS,UCHLIM,UCHTYP,UCHSTB]
PUSH U1,LOC(OC)
TERMIN
IFN OS%TNX,PUSH U1,UCHJFN(OC)
$OCFRM==:<.-%%OCNT> ; Get # wds per frame.
ADDI U1,1
HRRZM U1,$ARWPT(U4) ; Store new write ptr.
HRRZ U1,UCHTYP(OC)
CAIE U1,UC$IOT
CAIN U1,UC$BUF
CAIA
CALRET OXCLS7
IFN OS%ITS,[
MOVE U1,[.IOPUSH]
DPB OC,[$ACFLD,,U1]
XCT U1
]
CALRET OXCLS7 ; Softwarily close channel.
CALL OXPOP
OXPDLR: SKIPLE IOPCNT
JRST .-2
UARCLS @IOPDLP
SETZM IOPDLP
RET
OXPOP: SOSGE IOPCNT
JSR AUTPSY
CALL OXCLS ; Close channel currently in slot.
; Restore channel vars.
SKIPN U4,IOPDLP
JSR AUTPSY ; Attempt to pop empty stack...
MOVE U1,$ARWPT(U4)
SUB U1,[1,,1]
IFN OS%TNX,POP U1,UCHJFN(OC)
IRP LOC,,[UCHSTB,UCHTYP,UCHLIM,UCNTS,UCHCNT,USCOPT,UCOPT]
POP U1,LOC(OC)
TERMIN
ADDI U1,1
HRRZM U1,$ARWPT(U4)
; Fix up channel vars in case popped into different channel.
HRRZ U3,UCHTYP(OC)
JRST @.+1(U3)
%%OTMP==.
OXPUAR
OXPXCT
OXPBPT
OXPIOT
OXPBUF
OXPTRN
OXPNUL
IFN <.-%%OTMP>-UC$NX, .ERR UXPOP table loses
OXPBUF:
OXPIOT:
IFN OS%ITS,[
DPB OC,[$ACFLD,,UCOPT(OC)] ; Set up new chan for unit-mode .IOT
MOVE U1,[.IOPOP]
DPB OC,[$ACFLD,,U1]
XCT U1 ; Pop back hardware channel.
]
CAIE U3,UC$BUF
JRST OXPNUL
OXPBPT: MOVEI U1,UCHSTB(OC)
HRRM U1,UCOPT(OC)
OXPXCT:
OXPNUL: MOVEI U1,UCNTS(OC)
MOVEM U1,UCHCNT(OC)
OXPUAR:
OXPTRN:
RET
] ; IFN UAREAS
SUBTTL OUT - Formatting routines
OXFLD: JSP U4,@U3 ; Call routine
JRST OXFST1 ; Return vectors according to # params.
JRST OXFST2
JRST OXFST3
BVAR
UFFLG: 0 ; If -1, format params in effect.
UFWID: 0 ; If non-z, specifies a field width.
UFPREC: 0 ; Specifies "precision" for strings & floating output
UFFILL: -1 ; Fill char, defaults to neg (meaning blank).
UFSCNT: 0 ; Saved channel char cnt
UFSCHN: 0 ; Saved channel #
EVAR
OXFST1: HRLOI U3,377777 ; Specify width only. Set prec to max.
OXFST2: SETO U4, ; Specify width & prec only. Set fill char to blank.
OXFST3: MOVEM U4,UFFILL ; Set fill
MOVEM U3,UFPREC ; Set prec
MOVEM U1,UFWID ; Set width
SETOM UFFLG ; Say hacking format parameters.
; Set up channel for temporary buffer storage
MOVEM OC,UFSCHN ; Save current channel, and
MOVEI OC,UFLDC ; substitute "field" channel.
SKIPN UCOPT(OC) ; Make sure something there...
OUTCAL(,OPEN(UC$BPT,0,[$LUBUF])) ; If not, open it with limit.
MOVE U1,[440700,,UFBUF]
MOVEM U1,UCHSTB(OC) ; Reset write-pointer
SKIPL U1,UFPREC ; Use desired limit. If negative,
CAILE U1,$LUBUF ; or too large,
MOVEI U1,$LUBUF ; use maximum.
MOVNM U1,UCNTS(OC) ; Reset byte countdown to limit.
MOVNM U1,UCHLIM(OC) ; And save limit being used.
RET
; Finalize formatting... called when output done.
OXFDON: SETZM UFFLG ; Turn off formatting.
CAIE OC,UFLDC ; Make sure channel is correct one.
JSR AUTPSY ; Got zapped in meantime!!??
MOVE U1,UCNTS(OC) ; Get resulting byte countdown
SUB U1,UCHLIM(OC) ; <-max + cnt> - <-max> = <# chars written>
MOVE OC,UFSCHN ; Now can restore previous channel.
SKIPL U3,UFWID ; What sort of justification?
JRST OXFRD ; Right justifying.
; Left justifying, so output buffer, then fill.
ADD U3,U1 ; <# chars written> + -<field width>
PUSH P,U3 ; Save -<# pads>
SKIPG U4,U1 ; Set up <# chars> for output
JRST OXFDL3 ; Nothing to output?
MOVE U3,[440700,,UFBUF]
CALL @USCOPT(OC) ; Output buffered stuff to real channel.
OXFDL3: POP P,U4 ; Restore -<# pads>
JUMPGE U4,[RET] ; If no fill needed, return.
MOVM U4,U4 ; Get <# pads>
SKIPGE U1,UFFILL ; If strange fill char,
CAIL U4,$LBSTR ; or filling more than is reasonable,
JRST OXFDF ; jump to handle special case.
MOVE U3,[440700,,UBLSTR] ; Normal case will efficiently
PJRST @USCOPT(OC) ; output string of padding blanks and return.
; Finalize right-justified string...
OXFRD: PUSH P,U1 ; Save <# chars written>
SUB U1,U3 ; Find -<# pads to prepend>
JUMPGE U1,OXFDR4 ; Jump if none; can simply output stuff.
SKIPGE UFFILL ; If strange fill char,
CAMGE U1,[-$LBSTR] ; or too much padding,
JRST OXFDR3 ; do it hard way.
MOVE U3,[440700,,UFBUF]
MADBP7 U3,U1 ; Adjust BP in U3 by cnt in U1
POP P,U4
SUB U4,U1 ; <# writ> - <- # pad> = total to write out
PJRST @USCOPT(OC) ; Output string of blanks AND data together!!
OXFDR3: MOVM U4,U1 ; Move <# pads> to right place
CALL OXFDF ; Output fill chars one at a time.
OXFDR4: POP P,U4 ; Restore # chars written originally
MOVE U3,[440700,,UFBUF] ; Point at field buffer
JUMPG U4,@USCOPT(OC) ; Output and return.
RET
OXFDF: SKIPGE U1,UFFILL ; If fill char negative,
MOVEI U1,40 ; means regular blank.
OXRPTC: STDOUT ; Repeatedly output byte...
SOJG U4,OXRPTC
RET
BVAR
$LBSTR==5*30. ; # blanks in filler buffer
UBLSTR: .BYTE 7
REPEAT $LBSTR,40
.BYTE ; Note buffers contiguous!!
$LUBUF==$LBSTR ; # chars avail in field-adjusting buffer
UFBUF: BLOCK <$LUBUF+4>/5
EVAR
SUBTTL OUT - Basic output routines
; Item C(char) - Output byte
OXC: STDOUT ; Direct entry pt (if needed)
RET
; Items EOL,CRLF,TAB,SP - Output specific chars
OXCRLF:
OXEOL: STDOUT(^M)
STDOUT(^J)
RET
OXTAB: SKIPA U1,[^I] ; For convenience.
OXSP: MOVEI U1,40 ; Ditto
STDOUT
RET
; Item TZ([asciz]) - Output ASCIZ string
OXZA: HRLI U3,440700 ; form byte ptr
JRST OXZ ; Jump into loop
; Item PZ([bp]) - Output BYTEZ string
OXZ1: STDOBP ; Output byte (BP in U3 in case count out)
OXZ: ILDB U1,U3 ; Get input byte
JUMPN U1,OXZ1 ; Loop til hit zero byte.
RET
; Item PC([#,,[bp]) - Crock kept for compatibility
OXPC: HLRZ U4,U3 ; Direct entry - get cnt
MOVE U3,(U3) ; Get the bp
JUMPN U4,@USCOPT(OC) ; Dispatch
RET
; Item TC([#,,[asciz]]) - Output ASCNT string
OXTC: HLRZ U4,U3 ; Get cnt
HRLI U3,440700 ; Form BP in U3
JUMPG U4,@USCOPT(OC) ; Dispatch
RET
; Item TS([,,# ? bp]) - Output byte string var
OXS: HRRZ U4,(U3) ; Get byte cnt
MOVE U3,1(U3) ; Get byte ptr
JUMPG U4,@USCOPT(OC) ; Jump into output rtn
RET ; Return if null string.
SUBTTL OUT - Sixbit output
; Item 6W(aval) - Output val as 6 SIXBIT chars
OX6W: MOVE U4,[440600,,U3]
OX6W1: ILDB U1,U4 ; Get 6bit char
ADDI U1,40 ; Convert to ASCII
STDOUT ; Output
TLNE U4,770000 ; BP counted out yet?
JRST OX6W1
RET
; Item 6F(aval) - Output val as SIXBIT with no trailing spaces
OX6F: SETZ U4, ; Direct calling sequence SKIPE U3,ARG ? CALL OX6F
ROTC U3,6
STDOUT(40(U4))
JUMPN U3,OX6F
RET
; Item 6Q(aval) - Output val as SIXBIT like 6F, but quotes punctuation with ^Q
OX6Q: SETZ U4,
ROTC U3,6 ; Get next character in 6bit
CAIN U4,'- ; If other than letter, number, or hyphen
JRST OX6Q3 ; will need a ^Q to quote it.
CAIL U4,'0
CAILE U4,'Z
JRST OX6Q2
CAILE U4,'9
CAIL U4,'A
JRST OX6Q3
OX6Q2: STDOUT(^Q)
OX6Q3: STDOUT(40(U4))
JUMPN U3,OX6Q
RET
SUBTTL OUT - Numerical output
; Item O(aval) - Octal
; Item D(aval) - Decimal
; Item X(aval) - Hexadecimal
OXN10.: MOVEI U1,10.
CALL OXNTYP
STDOUT(".)
RET
OXNTY5: MOVM U3,U3 ; Negative, print minus sign.
MOVE U4,U1 ; Save radix
STDOUT("-)
MOVE U1,U4 ; Restore radix
JRST OXNTY1
; Direct call entry points to numerical typeout rtn.
OXN16: MOVEI U1,16. ? JRST OXNTYP
OXN8: SKIPA U1,[8.]
OXN10: MOVEI U1,10.
OXNTYP: JUMPL U3,OXNTY5 ; Go print minus sign.
OXNTY1: IDIVI U3,(U1)
JUMPE U3,OXNTY2
HRLM U4,(P) ; save digit on stack.
PUSHJ P,OXNTY1
HLRZ U4,(P)
OXNTY2: CAILE U4,9.
SKIPA U1,-10.(U4)+["A ? "B ? "C ? "D ? "E ? "F] ; For hex output
MOVEI U1,"0(U4) ;put char in u1
STDOUT
POPJ P,
SUBTTL OUT - Halfword output
; First, experimental Item W(aval) - outputs a single 36 bit word.
; WLH(aval) and WRH(aval), ditto for halfwords.
; The user could call STDOUT directly, but this way he can
; include it from an OUT macro call too.
OXWD: MOVE U1,U3 ; Fetch arg.
STDOUT ; Output it.
RET ; What could be simpler?
; Item RH(aval) - Output RH of arg as 6 octal digits
; Item LH(aval) - ditto for LH
; Item HWD(aval) - LH,,RH
OXHWD: PUSH P,U3
CALL OXLH
POP P,U3
STDOUT(54) ; Comma
STDOUT(54)
CALRET OXRH
; Item HV(aval) - Output val as LHV,,RHV (positive octal values)
; Item HS(aval) - Output val as LHS,,RHS (signed octal values)
OXHV: PUSH P,U3
HLRZ U3,U3
CALL OXN8
POP P,U3
STDOUT(54)
STDOUT(54)
HRRZ U3,U3
CALRET OXN8
OXHS: PUSH P,U3
HLRE U3,U3
CALL OXN8
POP P,U3
STDOUT(54)
STDOUT(54)
HRRE U3,U3
CALRET OXN8
OXLH: HLRZ U3,U3 ; Somewhat useless since can just setup arg to
; call OXRH directly, but for completeness...
OXRH: MOVE U4,[220300,,U3] ; Set up BP, 6 bytes of 3 bits.
OXRH1: ILDB U1,U4
STDOUT("0(U1)) ; Convert & output
TLNE U4,770000 ; BP counted out yet?
JRST OXRH1
RET
; Item WBA (output Ackermans?) a cross between W and TC.
; WBA([#,,[asciz]]) - Output ascnt string in binary
OXWBA: HLRZ U4,U3 ; Get cnt
HRLI U3,440700 ; Form BP in U3
JUMPG U4,@USCOPT(OC) ; Dispatch
RET
SUBTTL OUT - Floating-point output
IFN $$OFLT,[
.SCALAR OFLTFS ; Indicates type of output. - E, + F, 0 G.
FLT%FE==400000,,0
FLT%FF==200000,,0
IFNDEF E,E=:D+1
IFGE E-U1, .ERR ACs will lose for floating output!
OXNE: SKIPA U1,[OUT"FLT%FE] ; E format, m.nnnnnE+ee
OXNF: MOVEI U1,OUT"FLT%FF ; F format, mmm.nn
PJRST OXNFL
OXNG: SETZ U1, ; G format; F if within range, else E. Maximum prec.
OXNFL: PUSHAE P,[A,B,C,D,E,OFLTFS]
MOVEM U1,OFLTFS ; Set flags to use
PUSHJ P,UNFO
POPAE P,[OFLTFS,E,D,C,B,A]
RET
; This routine adapted from that in MACLISP.
UNFO: SKIPL A,U3
JRST UFP1
STDOUT("-)
MOVN A,U3
UFP1: SKIPLE OFLTFS ; If want F-format,
JRST UFP1F ; Go straight to it.
SETZB B,D ; For E-fmt, B holds add'l signif bin digits
CAMGE A,[.01] ; and D is exponent sign indicator
JRST UFP4 ; D=0 => negative exponent [x < 1.0e-2]
CAML A,[1.0^8]
AOJA D,UFP4F ; D=1 => positive exponent [x > 1.0e+8 - 1]
SKIPGE OFLTFS ; Made it, can use F fmt, but is E required?
JRST [ CAMGE A,[1.0] ; Yes, test to get exponent sign.
JRST UFP4 ; Neg exp
AOJA D,UFP4F] ; Pos exp
; "F" format. "G" comes here for 1.0e-2 <= x < 1.0e8
UFP1F: CAMGE A,[1.0] ; First find -<# digits to right of point.>
JRST [ MOVNI E,10.
CAML A,[.1] ; .1 <= x < 1.0
JRST UFP3
SOJA E,UFP3] ; .01 <= x < .1
PUSHJ P,UFPL10 ; <# digits to left of .>+1 will now be in E
SUBI E,9. ; Get -<# digits to right.>
UFP3: SETZB B,C
ASHC A,-27. ; Split exponent part off
ASHC B,-243(A) ; Split number into integral and fract part
MOVE U3,B ; Output integer part
PUSHJ P,OXN10
STDOUT(".)
MOVE B,C ; Move fract part
MOVM D,E ; D now holds # digits to print to right of .
MOVSI E,200000 ; Compute position of last significant bits
ASH E,-243+1+<43-27.>(A)
SKIPE U4,UFFLG ; Format params in effect?
MOVN U4,UFPREC ; Yes, get precision (# columns to right of .)
UFP3A: MOVE A,B
MULI A,10.
IMULI E,10.
CAMGE B,E
JRST UFPX0
MOVN C,E
TLZ C,400000
CAMLE B,C
AOJA A,UFPX0 ; Last sig digit, but round upwards
; Note only truncate when U4 was positive to start with.
SOJE U4,[TLNE B,200000 ; If forcing last digit, round upwards.
CAIL A,9. ; Round. This is a KLUDGE check since
JRST UFPX0 ; can't carry the roundup further (digits
AOJA A,UFPX0] ; already output). Oh well.
STDOUT("0(A))
CAIN D,2 ; On ninth output digit, use only half a digit
ASH E,-1 ; for end-of-precision test
SOJG D,UFP3A
JUMPG U4,UFPX1
POPJ P, ; Last significant digit, so stop
UFPX0: STDOUT("0(A))
SOJG U4,UFPX1 ; Skip if precision not done yet.
RET
UFPX1: MOVEI U1,40 ; Need to pad out. Default filler is space,
SKIPGE OFLTFS ; but if doing E fmt,
MOVEI U1,"0 ; then pad with zeros instead.
CALRET OXRPTC ; Go pad out.
; ----------- Here for "E" format -------------------
UFP4: JUMPN A,UFP4F ; Floating point "E" format
STDOUT("0)
STDOUT(".)
STDOUT("0)
SKIPE U4,UFFLG
MOVN U4,UFPREC ; If formating, get precision.
SOJG U4,UFPX1 ; If must space out, do so.
POPJ P,
UFP4F: MOVEI E,1
JUMPE D,UFP4E ; Jump out if negative exponent.
UFP4E0: FDVL A,UFP10.0 ; Double-prec div by 10.0 until
FDVRI A+1,(10.0) ; quotient is < 10.0
FADL A,A+1
CAML A,UFP10.0
AOJA E,UFP4E0
JRST UFP4B
UFP4E: FMPRI A+1,(10.0)
MOVEM A+1,A+2 ; Double-precision mul by 10.0 until
FMPL A,UFP10.0 ; product is >= 1.0
UFA A+1,A+2 ; Keeping count in E
FADL A,A+2
CAMGE A,UFP1.0
AOJA E,UFP4E
UFP4B: PUSH P,E ; Save exponent
PUSH P,(D)["- ? "+] ; Save sign of exponent
SETZ B,
MOVNI E,8.
MOVSI U4,(FLT%FE) ; Indicate hacking E format.
IORM U4,OFLTFS
PUSHJ P,UFP3 ; Num has been normalized for 1.0 <= x < 10.0
STDOUT("E)
POP P,U1 ; Restore sign char
STDOUT ; Output it.
POP P,U3 ; Restore exponent value
CAIL U3,100. ; Shouldn't be possible to exceed, but...
PJRST OXN10 ; hack more than 2 digits in exponent.
IDIVI U3,10.
STDOUT("0(U3)) ; Always use 2 digits in output.
STDOUT("0(U4))
POPJ P,
UFPL10: MOVEI E,8
CAMGE A,UFP1.0-1(E)
SOJG E,.-1
POPJ P,
UFP1.0: REPEAT 8,1.0^.RPCNT
UFP10.0=UFP1.0+1
] ;end IFN $$OFLT
SUBTTL C-style PRINTF routine
IFN $$OPRF,[
; PRINTF for the OUT package. This code was mostly done for the hell
; of it -- it is considerably less efficient than simply using the OUT
; macro directly!
; The following description is taken almost verbatim from "The C Programming
; Language" by Kernighan and Ritchie, 1978, p. 145-146.
; The PRINTF control string is composed of ordinary chars (which are output
; as-is) and conversion specifications. Each conversion spec is introduced
; by the char "%" and ended by a conversion char. Between the % and the
; conversion char there may be:
; A minus sign, which specifies left adjustment of the converted arg
; in its field.
; A digit string specifying a minimum field width. The converted
; number will be printed in a field at least this wide, and
; wider if necessary. If the converted arg has fewer chars
; than the field width it will be padded on the left (or
; right, if the left adjustment indicator has been given) to
; make up the field width. The padding char is blank normally
; and zero if the field width was specified with a leading zero
; (this zero does not imply an octal field width).
; A period, which separates the field width from the next digit string.
; A digit string (the precision), which specifies the maximum number
; of chars to be printed from a string, or the number of digits
; to be printed to the right of the decimal point of a FLOAT
; or DOUBLE.
; A length modifier "l" which indicates that the corresponding data
; item is a LONG rather than an INT.
; The conversion chars and their meanings are:
; d - The arg is converted to decimal notation.
; o - The arg is converted to unsigned octal notation (without a leading
; zero).
; x - The arg is converted to unsigned hexadecimal notation (without a
; leading 0x).
; u - The arg is converted to unsigned decimal notation.
; c - The arg is taken to be a single char.
; s - The arg is a string; chars from the string are printed until a
; null char is reached or until the number of chars indicated
; by the precision specification is exhausted.
; e - The arg is taken to be a FLOAT or DOUBLE and converted to decimal
; notation of the form [-]m.nnnnE[-+]xx where the length of the
; string of n's is specified by the precision. The default
; precision is 6.
; f - The arg is taken to be a FLOAT or DOUBLE and converted to decimal
; notation of the form [-]mmm.nnnn where the length of the string
; of n's is specified by the precision. The default precision is
; 6. Note that the precision does not determine the # of
; significant digits printed in F format.
; g - Use %e or %f, whichever is shorter; non-significant zeros are not
; printed.
; If the char after the % is not a conversion char, that char is printed;
; thus % may be printed by %%.
DEFINE PRINTF (CH,&STR&,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P)
IFNB [CH]{ PUSH P,OC ? MOVEI OC,CH }
MOVEI U1,[ASCIZ STR]
MOVEI U3,[A ? B ? C ? D ? E ? F ? G ? H ? I ? J ? K ? L ? M ? N ? O ? P]
CALL OXPNTF
IFNB [CH]{ POP P,OC }
TERMIN
OXPNTF: HRLI U1,440700
PUSH P,U1
TLO U3,(@) ; Turn on the indirect bit in arg pointer
PUSH P,U3
JRST OXPT10
OXPT05: STDOUT
OXPT10: ILDB U1,-1(P) ; Get char from string
CAIN U1,"%
JRST OXPT20 ; Special escape char, hack it.
JUMPN U1,OXPT05
OXPT90: SUB P,[2,,2] ; End of string, done!
RET
OXPT15: AOS (P) ; Done with one arg, point to next.
JRST OXPT10
; Handle special escape within string!
; Need the following vars:
; Minus-sign flag
; Padding-char value (blank or 0)
; Field-width value
; Precision value
; Possible argtype indicator (L, indirect, immediate etc)
OXPT20: SETZB U3,U4 ; Clear minus,,pad and field width
ILDB U1,-1(P) ; Get next char (indicating type)
CAIN U1,"- ; Minus sign?
JRST [ TLO U3,(SETZ) ; Use negative field
ILDB U1,-1(P) ; and get another char.
JRST .+1]
CAIE U1,"0 ; First digit a 0?
HRRI U3,40 ; No, so use blank for pad-char.
OXPT22: CAIL U1,"0
CAILE U1,"9
JRST OXPT25 ; Jump when done with field-width arg
IMULI U4,10.
ADDI U4,-"0(U1)
ILDB U1,-1(P)
JRST OXPT22
OXPT25: TLZE U3,(SETZ) ; If minus was given,
MOVNS U4 ; make field width negative.
PUSH P,U3 ; Save fill char value
SETZ U3, ; Clear val of prec field
CAIE U1,".
JRST OXPT30 ; No precision field
OXPT26: ILDB U1,-2(P) ; Get next char (note stack index changed)
CAIL U1,"0
CAILE U1,"9
JRST OXPT30 ; Jump when done with precision arg
IMULI U3,10.
ADDI U3,-"0(U1)
JRST OXPT26
; (P)/ pad char
; U4/ field width (0 if none)
; U3/ precision (0 if none)
; U1/ break char (either the modifier or the conversion char)
OXPT30: CAIE U1,"l ; For now, ignore all arg modifiers.
CAIN U1,"L
JRST [ILDB U1,-2(P)
JRST .+1]
; Now have conversion char in U1. Make uppercase.
JUMPE U1,[POP P,U1 ? JRST OXPT90] ; Fail here if string gone.
CAIL U1,"a
CAILE U1,"z
CAIA
TRO U1,40
CAIN U3,
JUMPE U4,[SETZM (P) ; Jump if no field specs whatsoever.
JRST OXPT40]
; Hacking field formatting!
CAIE U1,"S ; Unless type is S,
MOVNS U3 ; Ensure precision (if any) is negative!
EXCH U1,U4 ; Get field width in U1,
EXCH U4,(P) ; pad char in U4, and conversion char in (P)
CAIN U1, ; If no width given,
HRLOI U1,377777 ; Use maximum.
CAIN U3, ; If no prec given,
MOVNI U3,6 ; Likewise specify max (for numbers, default 6)
CALL OXFST3 ; Set up field output stuff!
SETO U1,
EXCH U1,(P) ; Say we're formatting!
; (P)/ non-zero if formatting
; U1/ conversion char
OXPT40: CAIN U1,"C ; C - Output char value
JRST [ MOVE U1,@-1(P)
JRST OXPT69]
CAIN U1,"S ; S - Output an ASCIZ string.
JRST [ MOVE U3,@-1(P)
TLCE U3,-1 ; If all zeros, skip
TLCN U3,-1 ; If all ones, don't skip
HRLI U3,44070 ; If LH is 0 or -1, substitute this.
CALL OXZ ; Output zero-terminated byte string
JRST OXPT70]
CAIN U1,"D ; D - Output decimal value
JRST [ MOVE U3,@-1(P)
CALL OXN10
JRST OXPT70]
CAIN U1,"O ; O - Output octal value
JRST [ MOVE U3,@-1(P)
CALL OXN8
JRST OXPT70]
CAIN U1,"X ; X - Output hexadecimal value
JRST [ MOVE U3,@-1(P)
CALL OXN16
JRST OXPT70]
CAIN U1,"U ; U - Output unsigned decimal value
JRST [ SKIPL U3,@-1(P)
JRST [ CALL OXN10
JRST OXPT70]
LSHC U3,-35.
LSH U4,-1. ; Get low 35 bits in U4, high bit in U3
DIVI U3,10. ; Get quotient in U3, rem in U4
PUSH P,U4
CALL OXN10 ; Output all but last decimal digit
POP P,U3 ; Restore last digit value
ADDI U3,"0 ; Make ASCII
JRST OXPT69] ; Output and done.
CAIN U1,"E ; E - Output floating point
JRST [ MOVE U3,@-1(P)
CALL OXNE
JRST OXPT70]
CAIN U1,"F ; F - Output floating point
JRST [ MOVE U3,@-1(P)
CALL OXNF
JRST OXPT70]
CAIN U1,"G ; G - Output floating point
JRST [ MOVE U3,@-1(P)
CALL OXNG
JRST OXPT70]
; No match, illegal type spec... just output it!
SOS -1(P) ; Decrement count to nullify later increment.
OXPT69: STDOUT ; Output char
OXPT70: POP P,U1 ; Pop format indicator off stack.
JUMPE U1,OXPT15 ; Back to normal loop!
CALL OXFDON ; We were formatting, wrap up.
JRST OXPT15
] ;IFN $$OPRF
SUBTTL Various special item output
IFN UAREAS,[
OXAR: SKIPN $AROPN(U1) ; Make sure it's open.
RET ; Just return if it isn't.
MOVE U3,$ARWPT(U1) ; Get write pointer (end of used area)
SUB U3,$ARLOC(U1) ; Make relative to beg
MULI U3,5 ; do bp hack
ADD U4,UADBP7(U3) ; Get # chars.
MOVE U3,$ARLOC(U1) ; Now cons up a BP to start.
HRLI U3,440700
JUMPG U4,@USCOPT(OC) ; Finally dispatch to string output,
RET ; unless nothing to output.
] ;IFN UAREAS
IFN ULISTS,[
; Item TLS(slp) - Output string that SLP points to
OXLS:
OXSL: ; Preferred label.
IF1 IFNDEF LISTAR, NOP ; 1st pass may not have macro def'd yet.
.ELSE MOVE U3,LISTAR(U3)+1 ; Get its SPT.
HLRZ U4,U3 ; Get count.
ADD U3,$LSLOC(L) ; Make address absolute
HRLI U3,440700 ; and turn into a BP.
JUMPG U4,@USCOPT(OC) ; Jump into output loop if anything there.
RET ; Else no-op.
; List-String relative to specific LSE.
; U1 - addr of LSE
; U3 - SLP to SLN within that LSE.
OXSLA: EXCH L,U1 ; For addressing purposes...
IF1 IFNDEF LISTAR, NOP ; 1st pass may not have macro def'd yet.
.ELSE MOVE U3,LISTAR(U3)+1 ; Get the SPT.
ADD U3,$LSLOC(L) ; Make address absolute.
MOVE L,U1 ; Restore original L.
HLRZ U4,U3 ; Get count,
HRLI U3,440700 ; make BP,
JUMPG U4,@USCOPT(OC) ; and off to output it.
RET
] ;IFN ULISTS
; UC$SAO output type - replaces old SAOBEG UUO.
; Initializes for standard UUO output into SA area; argument is
; a LSE pointer, e.g. OPEN(UC$SAO,$ARLOC+MSGAR) or OUTOPN CH,[$UCSAO,,L].
; The %LTSAO type bit in MAKELN will form a string LN of accumulated
; output.
UOPNSA:
IFE ULISTS, JSR AUTPSY
.ELSE [ SKIPN U4,@(U3) ; Get pointer to LSE
MOVE U4,L ; If none specified, use current LSE.
MOVE U1,$LSFRE(U4)
ADD U1,$LSLOC(U4) ; Get abs start addr
HRLI U1,440700 ; Form BP
MOVEM U1,$LSWPT(U4) ; and set up new write ptr for area.
MOVEI U1,(U1)
SUB U1,$LSTOP(U4) ; Get -<# wds left>
IMULI U1,5
MOVEM U1,$LSCHL(U4) ; Store as $ARCHL for SA.
MOVEI U4,$LSAR(U4) ; Finally get pointer to string-area ARPT.
MOVEI U1,UC$UAR ; Replace channel type with normal area.
MOVEM U1,UCHTYP(OC)
PJRST UOPNA1 ; Dispatch to complete normal area-open.
] ;IFN ULISTS
SUBTTL ERR item output
IFN $$OERR,[
; Code for ERR output type.
; Arg is error #.
; If arg -1, use "last error".
; Include crocks for compatibility with old kludge.
ERRMOA: SKIPA U3,A
ERRMO: SETO U3,
PUSH P,OC
MOVEI OC,(B)
CALL OXERR
POP P,OC
RET
; Item ERR(val) - Output system error string for given error #
; If no val or -1 specified, use last syscal error.
OXERRL: MOVE U3,[-1] ; Entry pt to use last error
OXERR:
IFN OS%ITS,[
MOVEI U4,4 ; Assume # specified,
CAIGE U3, ; But if want "last error",
MOVEI U4,1 ; ask system for that.
IFNDEF ERRCHN,.ERR ERRCHN must be defined for $$OERR to work.
SYSCAL OPEN,[CIMM ERRCHN
[SIXBIT/ERR/] ? U4 ? U3 ]
JRST [ MOVEI U3,[ASCIZ "?? Can't get error msg from ERR device ??"]
PJRST OXZA]
OXERR2: .IOT ERRCHN,U1
CAIGE U1,40
JRST [ .CLOSE ERRCHN,
RET ]
STDOUT
JRST OXERR2
] ;END IFN ITS
IFN OS%TNX,[
PUSHAE P,[1,2,3]
MOVEI 2,(U3)
HRLI 2,.FHSLF ; 2 = <fork>,,<err #>
MOVSI 3,-UERBFL ; 3 = -<# chs>,,
HRROI 1,UERBUF ; 1 = -1,,<dest addr>
ERSTR ; Get error string
ERJMP [MOVEI U3,[ASCIZ /<Illegal error #: /]
CALL OXZA
MOVEI U3,(2)
CALL OXN8
MOVEI U3,[ASCIZ />/]
JRST OXERR5]
JRST [ MOVEI U3,[ASCIZ /<Bad ERSTR call?!>/]
JRST OXERR5]
SETZ 3,
IDPB 3,1
MOVEI U3,UERBUF
OXERR5: POPAE P,[3,2,1]
PJRST OXZA
UERBFL==140. ; Max # chars in err msg
.VECTOR UERBUF(<UERBFL+4>/5)
] ;END IFN TNX
];end IFN $$OERR
SUBTTL Host name/number output
; NOTE: this code now assumes addresses are in HOSTS3 format!
; Item HN(aval) - Output host num in octal (single #)
; Item HND(aval) - Output host num in decimal (Internet fmt)
OXHN: CALRET OXN8 ; Simply output in octal
OXHND: PUSH P,U3
IF1, BLOCK 3
IF2 [ IFDEF NETWRK"CVH3NA, EXCH A,(P) ? CALL NETWRK"CVH3NA ? EXCH A,(P)
.ELSE JRST .+3 ? JRST 4,. ? JRST 4,.
]
TLNE U3,(17_32.) ; Internet address?
JRST [ LDB U3,[.BP <17_32.>, (P)] ; No, so exhibit high 4 bits.
CALL OXN8 ; Note octal!
STDOUT(":)
JRST .+1]
REPEAT 4,[
IFN .RPCNT, STDOUT(".)
LDB U3,[.BP <377_<8.*<3-.RPCNT>>>, (P)]
CALL OXN10
]
POP P,U3
RET
IFN $$OHST,[
; Item HST(aval) - Output host name for given address (else number)
LSQBR==:133 ; "[" character
RSQBR==:135 ; "]" character
OXHST:
; Special hack for COMSAT only... host number 0 means self.
IFN OS%ITS,IFE .FNAM1-<SIXBIT /COMSAT/>, CAIN U3, ? MOVE U3,OWNHST
CALL OXHOST ; Output host name if possible
SKIPA ; Not possible
RET ; Won
STDOUT(LSQBR) ; Do it as "[a.b.c.d]" format
CALL OXHND ; since this is supposed to be a hostname.
STDOUT(RSQBR)
RET
; Item HOST(aval,{altitm}) - Output host name and skip, else no skip
; so that alternate item is output instead.
OXHOST:
IFN OS%ITS,[
PUSHAE P,[A,B,D] ;clobbered by HSTSRC routine
MOVE B,U3
;; Make A point to ASCIZ name.
IFE $$DQ,{ ; Not doing DQ: device hackery
IF2, IFNDEF NETWRK"HSTSRC,.FATAL Missing NETWRK but $$OHST is on!
CALL NETWRK"HSTSRC
JRST OXHST4 ; Lookup failed, take nonskip return.
}
.ELSE { ; Are doing DQ: hacking
IF2, IFNDEF RESOLV"HSTSRC,.FATAL Missing RESOLV but $$OHST and $$DQ are on!
MOVE A,[440700,,HSTBUF] ;A has dest, B has host address.
CALL RESOLV"HSTSRC
JRST OXHST4
MOVE A,[440700,,HSTBUF]
} ; Done with DQ: hacking
MOVEI U3,(A)
CALL OXZA
AOS -3(P) ; Won, so skip on return.
OXHST4: POPAE P,[D,B,A]
RET
.VECTOR HSTBUF(24.) ;Buffer to hold host name string from RESOLV.
] ;IFN ITS
IFN OS%TNX,[
UHSTBL==20. ; Allow hostname up to 99. chars long
PUSHAE P,[1,2,3,4]
MOVEI 1,.GTHNS ; Number to Name
HRROI 2,1(P) ; Dest string ptr
ADD P,[UHSTBL,,UHSTBL] ; Make room on PDL
MOVE 3,U3
GTHST
JRST OXHST6 ; Lost, take nonskip return.
MOVEI U3,-<UHSTBL-1>(P)
CALL OXZA
AOS -<4+UHSTBL>(P) ; Won, take skip return.
OXHST6: SUB P,[UHSTBL,,UHSTBL]
POPAE P,[4,3,2,1]
RET
] ;IFN TNX
] ;IFN $$OHST
SUBTTL Time Output
IFN $$OTIM,[
; Requires that DATIME package be .INSRT'd someplace;
; The external defs needed from it include:
; (ITS) TIMADY - rtn to cvt sys-int timeword to abs (used for finding DOW)
; (ITS) TIMGET - rtn to get current sys-int time, with DST bit set.
; (ITS) TMONTB - table of month names
; Sub-types for "TIM" output item. Up to 4 letters significant.
; YOU try to think of better names for F1, F2, etc!!
DEFT HMS,OXTMTS ; HMS - Time as "hh:mm:ss". (old WC)
DEFT MDY,OXTMD ; MDY - Date as "mm/dd/yy"
DEFT YMD,OXTYMD ; YMD - Date as "yymmdd"
DEFT MDYT,OXTMDT ; MDYT - Datime as "mm/dd/yy hh:mm:ss" (old WA)
DEFT TNX,OXTTNX ; TNX - Datime as "dd-Mon-yy hh:mm:ss" (TNX default)
DEFT MONTH,OXTLMN ; MONTH - Month as "Month"
DEFT MON,OXTMON ; MON - Month as "Mon"
DEFT MONU,OXTMN ; MONU - Month as "MON"
DEFT DOW,OXTLDW ; DOW - Day of week as "Fooday"
DEFT DOW3,OXTDW ; DOW3 - Day of week as "Foo"
DEFT F1,OXTME ; F1 - Datime as "dd MON yy hhmm ZON" (old WB)
DEFT F2,OXTMX ; F2 - Datime as "dd Month yyyy hh:mm ZON" (old WD)
DEFT F3,OXTMF3 ; F3 - Datime as "dd MON yy hhmm-ZON"
DEFT RFC1,OXTRF1 ; RFC1 - Datime as RFC822 "dd Mon yy hh:mm:ss ZON"
DEFT RFC2,OXTRF2 ; RFC2 - Datime as RFC822 (RFC1) but with short DOW.
; OUT invocations
; with TIM() use the sequence
; (arg in U3)
; MOVEI U1,OXTnam
; CALL OXTXS
; with TIMA() use sequence like TIM() but CALL OXTXA.
; with TIMB() use the sequence
; (arg in UTMAC)
; CALL OXTnam
IFNDEF $LTIMB,[
; Define time-block here if not already def'd elsewhere
TM.YR==:0
TM.MON==:1
TM.DAY==:2
TM.HR==:3
TM.MIN==:4
TM.SEC==:5
TM.ZON==:6 ; <DST flag>,,<timezone value>
TM.DOW==:7 ; 0 = Monday, 6 = Sunday
$LTIMB==:10
]
IFN U2-OC, UTMAC==:U2 ; Normal case
.ELSE UTMAC==:U4 ; Screw case
; OXTXS - Execute time-routine using System-internal time.
; OC/ <channel>
; U1/ <time-rtn addr>
; U3/ <system-internal timeword>
OXTXS:
IFE U2-OC, PUSH P,OC
MOVEI U2,1(P) ; Get pointer to timeblock
ADD P,[$LTIMB,,$LTIMB] ; Make room for timeblock
CALL OXTCSB ; Insert values in timeblock
IFE U2-OC, MOVEI U4,(U2) ? MOVE OC,-$LTIMB(P)
CALL (U1) ; Process stuff
IFN U2-OC, SUB P,[$LTIMB,,$LTIMB]
.ELSE SUB P,[$LTIMB+1,,$LTIMB+1]
RET
; OXTCSB - Convert System-internal timeword to timeblock.
; U2/ <ptr to timeblock>
; U3/ <system-internal timeword>
; Smashes U3, U4 only
OXTCSB:
IFN OS%ITS,[
LDB U4,[DATIME"TM$YR,,U3]
ADDI U4,1900.
MOVEM U4,TM.YR(U2)
LDB U4,[DATIME"TM$MON,,U3]
MOVEM U4,TM.MON(U2)
LDB U4,[DATIME"TM$DAY,,U3]
MOVEM U4,TM.DAY(U2)
SKIPN U4,UTZLV ; Get local timezone
JRST [ CALL UTZGET ; Get if not initialized
JRST .-1] ; Repeat after init.
TRNE U3,1 ; DST bit set?
TLOA U4,-1 ; Yes, set LH to -1
TLZ U4,-1 ; No, ensure LH clear
MOVEM U4,TM.ZON(U2)
MOVEI U3,(U3)
LSH U3,-1
IDIVI U3,60.*60.
MOVEM U3,TM.HR(U2)
MOVEI U3,(U4)
IDIVI U3,60.
MOVEM U3,TM.MIN(U2)
MOVEM U4,TM.SEC(U2)
SETOM TM.DOW(U2) ; Punt DOW value for now, rarely use it.
RET
]
IFN OS%TNX,[
PUSHAE P,[1,2,3,4]
MOVE 2,U3
SETZ 4,
ODCNV
ERJMP [SETZB 2,3 ; 20X only (10X generates .ICILI)
SETZ 4,
JRST .+1]
HLRZM 2,TM.YR(U2) ; Store year #
ADDI 2,1
HRRZM 2,TM.MON(U2) ; Store month # (1 based)
HLRZM 3,TM.DAY(U2)
AOS TM.DAY(U2) ; Day # (1 based)
HRRZM 3,TM.DOW(U2) ; Store day-of-week (0=Monday)
MOVEI 1,(4)
IDIVI 1,60.*60.
IDIVI 2,60.
MOVEM 1,TM.HR(U2)
MOVEM 2,TM.MIN(U2)
MOVEM 3,TM.SEC(U2)
LDB 1,[.BP <IC%TMZ>,4] ; Get timezone
TLNE 4,(IC%ADS) ; If DST was applied
TLO 1,-1 ; then put -1 in LH
MOVEM 1,TM.ZON(U2)
POPAE P,[4,3,2,1]
RET
]
; All of the following output routines assume that UTMAC points
; to a timeblock structure.
; Date as MM/DD/YY
OXTMD: MOVE U3,TM.MON(UTMAC)
CALL OXTD2
STDOUT("/)
MOVE U3,TM.DAY(UTMAC)
CALL OXTD2
STDOUT("/)
OXTYR2: MOVE U3,TM.YR(UTMAC) ; Year as 2-digit number.
SUBI U3,1900.
CALRET OXTD2
; Date as YYMMDD
OXTYMD: MOVE U3,TM.YR(UTMAC) ; Year as 2-digit number.
SUBI U3,1900.
CALL OXTD2
MOVE U3,TM.MON(UTMAC) ; Month.
CALL OXTD2
MOVE U3,TM.DAY(UTMAC) ; Day.
CALRET OXTD2
; Date/time as DD-Mon-YY HH:MM:SS (TNX default format)
OXTTNX: CALL OXTDAY
STDOUT("-)
CALL OXTMON ; Output month
STDOUT("-)
CALL OXTYR2
STDOUT(40)
CALRET OXTMTS ; Then do time.
; Date/time as MM/DD/YY HH:MM:SS
OXTMDT: CALL OXTMD ; Date
STDOUT(40)
; Fall through for time
; Time as HH:MM:SS
OXTMTS: MOVE U3,TM.HR(UTMAC)
CALL OXTD2 ; Output hours
STDOUT(":)
MOVE U3,TM.MIN(UTMAC)
CALL OXTD2 ; Output minutes
STDOUT(":)
MOVE U3,TM.SEC(UTMAC)
CALRET OXTD2 ; Output secs and done.
; Date/time as " 7 AUG 1976 0831 EDT" (constant length)
OXTME: CALL OXTMFX
CALRET OXTMZB ; Print time-zone & return
OXTMF3: CALL OXTMFX
CALRET OXTMZD
OXTMFX: CALL OXTDAY ; Output day, 2 columns
STDOUT(40)
CALL OXTMN ; Output 3-letter month
STDOUT(40) ; Space out
CALL OXTYR ; Output 4-digit year
STDOUT(40)
MOVE U3,TM.HR(UTMAC)
CALL OXTD2 ; Output hrs
MOVE U3,TM.MIN(UTMAC)
CALRET OXTD2 ; Output mins
;;; RFC822 standard mail timestamps: RFC1 and RFC2.
OXTRF2: CALL OXTDW ; Output short day of week.
STDOUT(54)
STDOUT(40) ; Space out.
OXTRF1: CALL OXTDAY
STDOUT(40)
CALL OXTMON ; Output 3-letter month
STDOUT(40) ; Space out
MOVE U3,TM.YR(UTMAC) ; Year as 2-digit number.
SUBI U3,1900.
CALL OXTD2
STDOUT(40)
MOVE U3,TM.HR(UTMAC)
CALL OXTD2 ; Output hrs
STDOUT(":)
MOVE U3,TM.MIN(UTMAC)
CALL OXTD2 ; Output mins
STDOUT(":)
MOVE U3,TM.SEC(UTMAC)
CALL OXTD2 ; Output secs
CALRET OXTMZB ; Go do timezone
; Date/time as "7 August 1976 08:31 EDT"
OXTMX: CALL OXTDAV ; Output day, one or two columns
STDOUT(40)
CALL OXTLMN ; Output "long" month name
STDOUT(40)
CALL OXTYR ; Output 4-digit year
STDOUT(40)
MOVE U3,TM.HR(UTMAC)
CALL OXTD2 ; Output hrs
STDOUT(":)
MOVE U3,TM.MIN(UTMAC)
CALL OXTD2 ; Output mins
; Fall through to output timezone & return.
; Output local timezone (time-word val indicates whether DST)
OXTMZD: STDOUT("-) ; Entry pt for prefix dash
JRST OXTMZ
OXTMZB: STDOUT(40) ; Entry pt for prefix blank
OXTMZ: SKIPN U3,UTZLSS ; Get pointer to local timezone
JRST [ CALL UTZGET ; Not there yet? Set it up.
JRST .-1]
SKIPGE TM.ZON(UTMAC) ; Daylight savings on?
MOVE U3,UTZLDS ; Yes, use DST version instead.
CALRET OXZA ; Output ASCIZ.
; Day of the month in two columns.
OXTDAY: MOVE U3,TM.DAY(UTMAC) ; Get day
CAIL U3,10. ; If number will have two digits,
CALRET OXTD2 ; dispatch to routine for that.
STDOUT(40) ; Else output a space
STDOUT("0(U3)) ; and the digit.
RET
; Day of the month in one or two columns (Variable format).
OXTDAV: MOVE U3,TM.DAY(UTMAC) ; Get day
CAIL U3,10. ; If two digits,
CALRET OXTD2 ; dispatch to better routine.
STDOUT("0(U3))
RET
; For both versions of month output, use ASCIZ
; rather than ASCNT since former guarantees U2
; will be preserved.
OXTLMN: MOVE U3,TM.MON(UTMAC) ; Get month
MOVE U3,UTBMON(U3) ; Get ascnt ptr to string for it
CALRET OXZA ; Output ASCIZ string
OXTMN: MOVE U3,TM.MON(UTMAC) ; Get month
MOVE U3,UTBMO3(U3) ; Get ascnt ptr to string for it
CALRET OXZA ; Output asciz (only 3 chars)
; Output month as "Mon"
OXTMON: MOVE U3,TM.MON(UTMAC) ; Get month
MOVE U3,UTBMON(U3) ; Get ascnt ptr to long-form name
HRLI U3,440700 ; Set up BP then output 1st 3 chars.
REPEAT 3,ILDB U1,U3 ? STDOUT
RET
; Day-Of-Week output
OXTDW: SKIPA U1,[UTBDO3(U3)] ; Use short-form table.
OXTLDW: MOVE U1,[UTBDOW(U3)] ; Use long-form table.
SKIPGE U3,TM.DOW(UTMAC) ; All's well if have valid DOW value
CALL UTMGDW ; Sigh, must get it (into U3)
MOVE U3,@U1 ; Get appropriate string, table idx'd by U3
CALRET OXZA ; Output as asciz to avoid U4 clobberage.
OXTYR: MOVE U3,TM.YR(UTMAC) ; Get year
; Fall through to output 4 digits.
; Internal routines to output 4 or 2 digits of num in U3.
OXTD4:
IFE UTMAC-U4, PUSH P,U4
IDIVI U3,100. ; Output 4 digits
PUSH P,U4
CALL OXTD2
POP P,U3 ; Fall thru to OXTD2 again
IFE UTMAC-U4, CAIA
OXTD2:
IFE UTMAC-U4, PUSH P,U4
IDIVI U3,10. ; Output 2 digits
STDOUT("0(U3))
STDOUT("0(U4))
IFE UTMAC-U4, POP P,U4
RET
; Get system internal time in U3
UTMGTS:
IFN OS%ITS,[
PUSH P,A
CALL DATIME"TIMGET
CAMN A,[-1]
JSR AUTPSY
MOVE U3,A
POP P,A
]
IFN OS%TNX,[
PUSH P,1
GTAD
MOVE U3,1
POP P,1
]
RET
; UTMGDW - Given ptr to time-block in UTMAC, return
; DOW value in U3 (0=Monday). Clobbers U4 (unless == UTMAC)
UTMGDW:
IFN OS%TNX, MOVEI U3,7 ; TNX shouldn't ever have to ask
IFN OS%ITS,[
CALL UTCBDA ; Get absolute # days
IFE UTMAC-U4,PUSH P,U4
IDIVI U3,7
MOVEI U3,(U4)
IFE UTMAC-U4,POP P,U4
] ;OS%ITS
RET
; UTCBDA - Time Convert, Block to Day Absolute
; UTMAC/ ptr to time-block
; Returns
; U3/ absolute # days since Jan 1, 1900
; Clobbers U4 (unless == UTMAC)
IFN OS%ITS,[
UTCBDA: IFN UTMAC-U2,PUSH P,U2 ? MOVE U2,UTMAC ; Ensure ptr in U2
PUSH P,U1
MOVE U3,TM.DAY(U2) ; Get day #
MOVE U1,TM.MON(U2) ; Get month #
ADD U3,DATIME"TMONTB(U1); Add days thus far in year
MOVE U4,TM.YR(U2) ; Get year
SUBI U4,1900. ; Make simplifying assumption
TRNE U4,3 ; Specified year a leap year?
JRST .+3 ; No, can skip month check
CAIL U1,3 ; Leap year -- is it after Feb?
ADDI U3,1 ; Yes, add extra day
MOVEI U1,-1(U4) ; Adjust, and
LSH U1,-2 ; Get # of leapyears since 1900, excl this yr
IMULI U4,365. ; # years times 365
ADDI U4,(U1) ; plus # prior leapyears (extra days)
ADDI U3,-1(U4) ; plus days so far this yr (-1 because day #
POP P,U1 ; was 1-based)
IFE UTMAC-U4, MOVE UTMAC,U2 ? POP P,U2
RET
] ;IFN OS%ITS
; Time-zone hacks
; For all three params below, LH=-1 when set (thus 0 val means
; var isn't initialized). Actual var is in RH.
.SCALAR UTZLV ; Local timezone value
.SCALAR UTZLSS ; Local STD timezone string (addr of ASCIZ)
.SCALAR UTZLDS ; Local DST timezone string (addr of ASCIZ)
; UTZGET - Set up the above three parameters.
UTZGET: PUSH P,U1
IFN OS%ITS,MOVEI U1,5 ; All ITS systems are in EST
IFN OS%TNX,[
PUSHAE P,[2,3,4]
SETO 2,
SETZ 4,
ODCNV
LDB U1,[.BP IC%TMZ, 4]
POPAE P,[4,3,2]
]
HRROM U1,UTZLV ; Store local time-zone value
MOVE U1,UTBZON(U1) ; Get ASCIZ strings for zone
HLROM U1,UTZLSS ; Store STD string
HRROM U1,UTZLDS ; Store DST string
POP P,U1
RET
DEFINE TZONE STD,DST
[ASCIZ /STD/],,[ASCIZ /DST/]
TERMIN
UTBZON: TZONE GMT,GMT ; 0 How to ask for British Summer Time??
TZONE ; 1
TZONE ; 2
TZONE ; 3 (NST = Newfoundland is -0330)
TZONE AST,ADT ; 4 Atlantic
TZONE EST,EDT ; 5 Eastern
TZONE CST,CDT ; 6 Central
TZONE MST,MDT ; 7 Mountain
TZONE PST,PDT ; 8 Pacific
TZONE YST,YDT ; 9 Yukon
TZONE HST,HDT ; 10 Alaska-Hawaii
TZONE BST,BDT ; 11 Bering
REPEAT 24.-11.,TZONE ; 12-24 unspecified
; Various tables
; Table for printing month, indexed by 1-12.
UTBMON: 0
IRP M,,[January,February,March,April,May,June,July,August,September,October,November,December]
.LENGTH "M",,[ASCIZ "M"]
TERMIN
; Table for printing month, indexed by 1-12.
UTBMO3: 0
IRP M,,[JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC]
3,,[ASCIZ /M/] ; All strings length 3.
TERMIN
; Tables for printing day-of-week, indexed by 0-6.
; Note TNX internal convention has 0 = Monday.
; Note also that Jan 1, 1900 (abs day 0) = Monday.
; Fooday included so masking low 3 bits of DOW value will always win.
UTBDOW: IRP D,,[Monday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday,Fooday]
.LENGTH /D/,,[ASCIZ /D/]
TERMIN
UTBDO3: IRP D,,[Mon,Tue,Wed,Thu,Fri,Sat,Sun,Foo]
3,,[ASCIZ /D/] ; All strings of length 3.
TERMIN
] ;IFN $$OTIM
SUBTTL .END OUT - Additional comments
.QMTCH==QMTCH ; Now can restore user's parsing mode.
.END ; End the OUT symbols block.
.INEOF ; Stop parsing here.
COMMENT |
Table of OUT channel variables:
UCHTYP UCOPT USCOPT UCHCNT UCNTS UCHSTB UCHJFN UCHLIM
UC$UAR idpb u1,$arwpt uol.ar $archl - <arpt> - -
UC$XCT <arg> uo*.x <ucnts> count - - <orig lim>
UC$BPT idpb u1,uchstb uo*.bp <ucnts> count <BParg> - <orig lim>
UC$IOT .iot u1 / bout uo*.io <ucnts> count - <jfn> <orig lim>
UC$BUF idpb u1,uchstb uol.bf <ucnts> count <BP> <jfn> <buff>,,<size>
UC$TRN xct ucopt+x uos.tr <uchcnt+x><ch#> <copy> - -
UC$NUL nop uos.nl <ucnts> count - - <max lim>
Note: UO*.X corresponds to either UOL.X or UOS.X depending on whether the
channel was opened with a count limit (UOL) or not (UOS).
UCOPT ; XCT'd unit-mode instruction (always)
USCOPT ; Addr of string-mode routine (always)
UCHCNT ; Addr of char countdown (always)
UCNTS ; Char countdown (except UAR, TRN)
UCHLIM ; Original count (except UAR, TRN, BUF)
UCHTYP ; <flags>,,<chan type>
UCHJFN ; JFN for channel if any (only TNX IOT, BUF)
UCHSTB ; Byte ptr (UC$BPT) or ARPT (UC$UAR)
List of type-dependent OUT functions:
OPEN UOPENT(typ)
Unit Output UCOPT(ch)
String Output USCOPT(ch)
Overflow OVFTAB(typ)
CLS OXCLST(typ)
PTV UPTTAB(typ)
FRC OXFRCT(typ) Doesn't exist but should
RST OXRSTT(typ) "
PUSH,POP OXPOPT(typ) "
|
Reference in New Issue View Git Blame Copy Permalink