Trailing-Edge
-
PDP-10 Archives
-
decuslib20-04
-
decus/20-0135/06/vtisng.mac
There are 2 other files named vtisng.mac in the archive. Click here to see a list.
00100 COMMENT * vtisng, SIMULA specification;
00200 OPTIONS(/E:QUICK,vtisng);
00300 PROCEDURE vtisng(param);
00400 NAME param; INTEGER param;
00500 COMMENT synchronizes the cursor in the cursor to the screen position
00600 identified by xhoriz,xvertic;
00700
00800
00900 !*;! MACRO-10 code !*;!
01000
01100 TITLE vtisng
01200 ENTRY vtisng ;! When called from SIMULA
01300 ENTRY maisng ;! When called from MACRO
01400 SUBTTL VIDED subroutine, Jacob Palme 1978
01500
01600 ;!*** Copyright 1978 by the Swedish Defence Research Institute. ***
01700
01800 sall
01900 search simmac,simmcr,simrpa
02000 search vtmvda
02100 macinit
02200 extern masynk
02300 if2,<ifdef VT$BPT,<intern VT$BPT>
02400 ifndef VT$BPT,<extern VT$BPT>>
02500
02600 COMMENT* REGISTER USAGE IN THIS PROCEDURE
02700 X0 Temporary use
02800 X1 Destroyed by outchr, vtmcur, vtsynk, used for trmop
02900 X2 ==XTAC when calling function procedures, used for trmop
03000 X3 ==XWAC1 = first parameter used to load XBASE,
03100 = reference to sysout used by IONB via OUTCHR and vtmcur
03200 X4 Used by vtmcur
03300 X5 ==xhoriz, parameter to vtmcur and vtsynk
03400 X6 ==xvertic, parameter to vtmcur and vtsynk
03500 X7 ==XBH = used by OUTCHR and VTMCUR, buffer header pointer
03600 X10 free
03700 X11 ==xgotch internal version of q_gotchar
03800 X12 Destroyed by vtmcur, vtsynk
03900 X13 xtyp == terminal type
04000 X14 ==XBASE = base of mvistax SIMULA data block
04100 X15 ==XCB current block pointer, used by RTS
04200 X16 ==XLOW points to static area in RTS, used by RTS
04300 X17 ==XPDP push down list pointer
04400 *;!
04500
04600 bup==OFFSET(ZBHBUP)
04700 cnt==OFFSET(ZBHCNT)
04800
04900 ;! OUTCHR assumes XWAC1 = file ref for Sysout, XBH pointer to
05000 ;! buffer header. XWAC1==AC3, XBH==AC7.
05100 ;! OUTCHR moves the character in AC0 to the SYSOUT output
05200 ;! file buffer. IF a parameter is given, the contents of
05300 ;! the word with the given offset from xbase is loaded into
05400 ;! AC0 first. xbase refers to the mvistax class block instance.
05500
05600 DEFINE outchr(c)<
05700 IFNB <c>,<L c(xbase)>
05800 SOSGE cnt(XBH)
05900 XEC IONB
06000 IDPB bup(XBH)
06100 >
06200
06300 ;! local definitions
06400 xhoriz==XWAC1+2 ;! AC5
06500 xvertic==xhoriz+1 ;! AC6
06600
06700 xgotch==x11 ;! character which just has been input
06800 xbase==X14 ;! base of mvistax class instance block
06900 xtyp== X13 ;! terminal type number
07000
07100 vtisng: PROC ;! entry point when called from SIMULA
07200 ;! Set up environment variables
07300 LF xbase,ZFLZBI(,XWAC1) ;! Base of MVISTAX block (vtmvda offsets)
07400 LOWADR ;! XLOW points to static area
07500 L XWAC1,YSYSOUT(XLOW) ;! XWAC1==AC3:- Sysout for OUTCHR!
07600 LF XBH,ZFIOBH(XWAC1) ;! XBH==AC7:- buffer header
07700 SUBI XBH,1 ;! Compute buffer header reference
07800 L xtyp,trmtyp(xbase) ;! terminaltype to ac xtyp
07900
08000 maisng: ;! entry point when called from MACRO
00100 ;! CLASS insingle;!
00200 ;! BEGIN
00300 ;! mainloop: detach;!
00400 ;! z_t(7);! forceout(terminalout);!
00500
00600 ofile==xwac1
00700 LF XBH,ZFIOBH(ofile)
00800 SUBI XBH,1
00900 LF X1,ZBHZBU(XBH)
01000 HRRZ X2,OFFSET(ZBHBUP)(XBH)
01100 IF ;! Nothing written
01200 CAIG X2,2(X1)
01300 SKIPE 2(X1)
01400 GOTO FALSE
01500 THEN
01600 GOTO forced ;! IONB returns here!
01700 FI
01800 XEC IONB
01900 forced:
02000
02100 ;! call(p_q_insingle);!
02200 XEC qinsing
02300
02400 ;! controlchar:= IF q_gotchar < ' ' THEN TRUE ELSE
02500 ;! IF q_gotchar = fill THEN TRUE ELSE FALSE;!
02600 SETZM controlchar(xbase)
02700 CAIL xgotch," "
02800 CAIN xgotch,qdel
02900 SETOM controlchar(xbase)
03500
03600 ;! IF addaltmode THEN
03700 IF
03800 SKIPN addaltmode(xbase)
03900 GOTO FALSE
04000 THEN
04100 ;! BEGIN IF q_gotchar = altmode THEN
04300 CAIN xgotch,qesc
04700 ;! call(p_q_insingle);!
04800 XEC qinsingle
05300 ;! END;!
05400 FI
05500 ;! IF NOT controlchar THEN
05600 IF
05700 SKIPE controlchar(xbase)
05800 GOTO FALSE
05900 ;! BEGIN COMMENT to be stored in screen;!
06000 THEN
06100 ;! depchar(screen[q_verticalpos],q_horizontalpos+1,
06200 ;! q_gotchar);!
06300 q==6 ;! Offset of first array element (one dimension)
06400 L X1,qverticalpos(xbase) ;! Index into screen array
06500 ADDI X1,(X1) ;! * 2 for text
06600 ADD X1,screen(xbase) ;! + address of array object
06700 LF X0,ZTVZTE(X1,q) ;! Address of text object
06800 L X1,qhoriz(xbase) ;! horizontal pos
06900 IDIVI X1,5 ;! Split into word/byte offset
07000 HLL X0, VT$BPT+1(X2) ;! Get the right byte pointer
07100 ADDI X0,2(X1) ;! Text object offset + additional words
07200 DPB xgotch, X0 ;! Store the character
07300
07400 ;! q_horizontalpos:= q_horizontalpos+1;!
07500 AOS xhoriz, qhoriz(xbase)
07600 ;! IF q_horizontalpos >= width THEN
07700 IF
07800 CAMGE xhoriz, width(xbase)
08000 GOTO FALSE
08100 ;! BEGIN ! wrap cursor around at screen borders;!
08200 THEN
08300 ;! IF q_verticalpos < heightm1 THEN
08500 L xvertic, qvertic(xbase)
08550 IF
08600 CAML xvertic, heim1(xbase)
08700 GOTO FALSE
08800 THEN
08900 ;! synchronize(0,q_verticalpos+1) ELSE
09000 LI xhoriz,0 ;! horiz parameter
09200 ADDI xvertic,1
09300 XEC masynk ;! call synchronize
09400 ELSE
09500 ;! BEGIN outchr(terminalout,linefeed,1);!
09600 LI X0,qlf
09700 outchr
09800 ;! synchronize(0,heightm1);! badscreen:= TRUE;!
09900 LI xhoriz,0
10000 L xvertic,heim1(xbase)
10100 XEC masynk ;! call synchronize
10200 SETOM badscreen(xbase)
10300 ;! COMMENT unwanted scrolling of screen has occurred;!
10400 ;! END
10500 FI
10600 ;! END;!
10700 FI
10800 ;! END ELSE
10900 ELSE
11000 ;! BEGIN COMMENT not to be stored on the screen;!
11100 ;! COMMENT not printable AND echo;!
11200 ;! unknownchar:= FALSE;!
11300 SETZM unknownchar(xbase)
11400 ;! IF q_gotchar = linefeed THEN
11500 IF
11600 CAIE xgotch,qlf
11700 GOTO FALSE
11800 ;! BEGIN
11900 THEN
12000 ;! IF q_verticalpos < heightm1 THEN
12100 IF
12200 L X0,heim1(xbase)
12300 CAMG X0,qvertic(xbase)
12400 GOTO FALSE
12500 ;! BEGIN IF allow_cr THEN
12600 THEN
12700 IF
12800 SKIPN allowcr(xbase)
12900 GOTO FALSE
13000 ;! BEGIN q_verticalpos:= q_verticalpos+1;!
13100 THEN
13200 AOS qvertic(xbase)
13300 ;! IF q_echoenabled THEN
13400 IF
13500 SKIPN qechoenabled(xbase)
13600 GOTO FALSE
13700 ;! BEGIN
13800 THEN
13900 ;! IF terminaltype = tandberg THEN
14000 IF
14100 CAME xtyp,tandberg(xbase)
14200 GOTO FALSE
14300 ;! BEGIN
14400 THEN
14500 ;! screen(q_verticalpos).sub(q_horizontalpos+1,
14600 ;! width-q_horizontalpos):= NOTEXT;!
14700 XEC blatxt
14800 ;! END;!
14900 FI
15000 ;! END;!
15100 FI
15200 ELSE
15300 ;! END ELSE
15400 ;! synchronize(q_horizontalpos,q_verticalpos+1);!
15500 L xhoriz,qhoriz(xbase)
15600 L xvertic,qvertic(xbase)
15700 ADDI xvertic,1
15800 XEC masynk
15900 FI
16000 ;! END
16100 FI
16200 ;! END ELSE
16300 ELSE
16400 ;! IF q_gotchar = carriagereturn THEN
16500 IF
16600 CAIE xgotch,qcr
16700 GOTO FALSE
16800 ;! q_horizontalpos:= 0 ELSE
16900 THEN
17000 SETZM qhoriz(xbase)
17100 ELSE
17200 ;! IF q_gotchar = up THEN
17300 IF
17400 CAME xgotch,up(xbase)
17500 GOTO FALSE
17600 ;! BEGIN IF q_verticalpos = 0 THEN
17700 THEN
17800 IF
17900 SKIPE qvertic(xbase)
18000 GOTO FALSE
18100 ;! synchronize(q_horizontalpos,heightm1)
18200 THEN
18300 L xhoriz,qhoriz(xbase)
18400 L xvertic,heim1(xbase)
18500 XEC masynk
18600 ;! ELSE
18700 ;! BEGIN
18800 ELSE
18900 ;! IF terminaltype = tandberg THEN
19000 IF
19100 CAME xtyp,tandberg(xbase)
19200 GOTO FALSE
19300 ;! BEGIN IF q_verticalpos = heightm1 THEN synka:= TRUE;!
19400 THEN
19600 L X0,heim1
19700 CAMN X0,qvertic(xbase)
20000 SETOM synka(xbase)
20200 ;! END;!
20300 FI
20400 ;! q_verticalpos:= q_verticalpos-1;!
20500 SOS qvertic(xbase)
20600 ;! END;!
20700 FI
20800 ;! END ELSE
20900 ELSE
21000 ;! IF q_gotchar = down THEN
21100 IF
21200 CAME xgotch,down(xbase)
21300 GOTO FALSE
21400 ;! BEGIN IF q_verticalpos >= heightm1 THEN
21500 THEN
21600 IF
21700 L X0,qvertic(xbase)
21800 CAMGE X0,heim1(xbase)
21900 GOTO FALSE
22000 ;! synchronize(q_horizontalpos,0) ELSE
22100 THEN
22200 L xhoriz,qhoriz(xbase)
22300 LI xvertic,0
22400 XEC masynk
22500 ELSE
22600 ;! q_verticalpos:= q_verticalpos+1;!
22700 AOS qvertic(xbase)
22800 FI
22900 ;! END ELSE
23000 ELSE
23100 ;! IF q_gotchar = left THEN
23200 IF
23300 CAME xgotch,left(xbase)
23400 GOTO FALSE
23500 ;! BEGIN IF q_horizontalpos = 0 THEN
23600 THEN
23700 IF
23800 SKIPE qhoriz(xbase)
23900 GOTO FALSE
24000 THEN
24100 ;! synchronize(widthm1,q_verticalpos) ELSE
24200 L xhoriz,widm1(xbase)
24300 L xvertic,qvertic(xbase)
24400 XEC masynk
24500 ELSE
24600 ;! q_horizontalpos:= q_horizontalpos-1;!
24700 SOS qhoriz(xbase)
24800 FI
24900 ;! END ELSE
25000 ELSE
25100 ;! IF q_gotchar = right THEN
25200 IF
25300 CAME xgotch,right(xbase)
25400 GOTO FALSE
25500 THEN
25600 ;! BEGIN IF q_horizontalpos >= widthm1 THEN
25700 IF
25800 L X0,widm1(xbase)
25900 CAMLE X0,qhoriz(xbase)
26000 GOTO FALSE
26100 THEN
26200 ;! synchronize(0,q_verticalpos) ELSE
26300 LI xhoriz,0
26400 L xvertic,qvertic(xbase)
26500 XEC masynk
26600 ELSE
26700 ;! q_horizontalpos:= q_horizontalpos+1;!
26800 AOS qhoriz(xbase)
26900 FI
27000 ;! END ELSE
27100 ELSE
27200 ;! IF q_gotchar = home THEN
27300 IF
27400 CAME xgotch,home(xbase)
27500 GOTO FALSE
27600 ;! BEGIN q_horizontalpos:= 0;!
27700 THEN
27800 SETZM qhoriz(xbase)
27900 ;! IF terminaltype = cdc71310s THEN q_verticalpos:= heightm1
27950 ;! ELSE q_verticalpos:= 0;!
28000 SETZ X0,
28100 CAMN xtyp,cdc73s(xbase)
28400 L X0,heim1(xbase)
28500 ST X0,qvertic(xbase)
29000 ;! END ELSE
29100 ELSE
29200 ;! IF q_gotchar = eraseline THEN
29300 IF
29400 CAME xgotch,eraseline(xbase)
29500 GOTO FALSE
29600 THEN
29700 ;! BEGIN IF line_erasable THEN
29800 IF
29900 SKIPN lineerasable(xbase)
30000 GOTO FALSE
30100 THEN
30200 ;! screen[q_verticalpos].
30300 ;! sub(q_horizontalpos+1, width-q_horizontalpos):= NOTEXT;!
30400 xec blatxt
30500 ;! END ELSE unknownchar:= TRUE;!
30600 FI
30700 ELSE
30800 SETOM unknownchar(xbase)
30900 FI
31000
31100 FI FI FI FI FI FI FI
31200
31300 ;! IF synka THEN
31400 IF
31500 SKIPN synka(xbase)
31600 GOTO FALSE
31700 ;! BEGIN
31800 THEN
31900 ;! IF (IF q_echoenabled THEN NOT trmop(8R0001,sysout,1) = 1
32000 ;! type ahead from the terminal has occurred;!
32100 ;! ELSE TRUE) THEN
32200 IF
32300 SKIPN qechoenabled(xbase)
32400 GOTO FALSE
32600 L X2,ioindex(xbase) ;! Get universal i/o index
32800 LI X1,.TOSIP ;! Skip if rem. inp. buf. not empty
32900 LI X1 ;! Address of arg. blk. (X1,X2)
33000 TRMOP.
33100 GOTO TRUE ;! Not empty
33200 GOTO FALSE ;! Empty
33300 ;! BEGIN synka:= FALSE;!
33400 THEN
33500 SETZM synka(xbase)
33600 ;! IF q_echoenabled THEN
33700 IF
33800 SKIPN qechoenabled(xbase)
33900 GOTO FALSE
34000 THEN
34100 ;! synchronize(q_horizontalpos, q_verticalpos) ELSE
34200 L xhoriz,qhoriz(xbase)
34300 L xvertic,qvertic(xbase)
34400 XEC masynk
34500 ELSE
34600 ;! restore_the_whole_screen;!
34700 SETZM xgotch ;! an unknown char will cause
34800 SETOM unknownchar(xbase) ;! edit to restore the screen
34900 FI
35000 ;! END;!
35100 FI
35200 ;! END;!
35300 FI
35400 ;! END not printable, but echo;!;!
35500 FI
35600 ;! END;!
35700 ;! z_t(-7);!
35800 ;! GOTO mainloop;!
35900 ST xgotch,qgotchar(xbase) ;! return character which has been input
36000 RETURN
36100 EPROC
00100 subttl qinsingle
00200 ;! CLASS q_insingle
00300 qinsingle: PROC
00400 ;!
00500 ;! COMMENT: Will input one character from the terminal without
00600 ;! waiting for a carriage return. Can also input "left"=^Z,
00700 ;! which cannot be input with inimage;!
00800 ;! BEGIN
00900 ;! loop: detach;!
01000 ;! q_gotchar:= getch;!
01100 INCHRW xgotch
01200 ;! IF q_gotchar = fill THEN
01300 IF
01400 CAIE xgotch,qdel
01500 GOTO FALSE
01600 THEN
01700 ;! BEGIN
01800 ;! IF q_horizontalpos > 0 THEN
01900 IF
02000 SKIPG qhoriz(xbase)
02100 GOTO FALSE
02200 THEN
02300 ;! BEGIN
02400 ;! IF addaltmode and NOT leftsingle THEN
02500 IF
02600 SKIPE addaltmode(xbase)
02700 SKIPE leftsingle(xbase)
02800 GOTO FALSE
02900 THEN
03000 ;! outchr(sysout,altmode,1);!
03100 LI qesc
03200 outchr
03300 FI
03400 ;! outchr(sysout,left,1);!
03500 outchr(left)
03600 ;! outchr(sysout,' ',1);!
03700 LI X0," "
03800 outchr
03900 ;! IF addaltmode and NOT leftsingle THEN
04000 IF
04100 SKIPE addaltmode(xbase)
04200 SKIPE leftsingle(xbase)
04300 GOTO FALSE
04400 THEN
04500 ;! outchr(sysout,altmode,1);!
04600 LI qesc
04700 outchr
04800 FI
04900 ;! outchr(sysout,left,1);!
05000 outchr(left)
05100 ;! depchar(screen[q_verticalpos],q_horizontalpos,' ');!
05200 q==6 ;! Offset of first array element (one dimension)
05300 L X1,qverticalpos(xbase) ;! Index into screen array
05400 ADDI X1,(X1) ;! * 2 for text
05500 ADD X1,screen(xbase) ;! + address of array object
05600 LF X0,ZTVZTE(X1,q);! Address of text object
05700 L X1,qhoriz(xbase);! horizontal pos
05800 SUBI X1, 1
05900 IDIVI X1,5 ;! Split into word/byte offset
06000 HLL X0,VT$BPT+1(X2) ;! Get the right byte pointer
06100 ADDI X0,2(X1) ;! Text object offset + additional words
06200 LI X1," " ;! Byte to store
06300 DPB X1,X0 ;! Store it
06400
06500 ;! q_horizontalpos:= q_horizontalpos-1;!
06600 SOS ,qhoriz(xbase)
06700 ;! END;!
06800 FI
06900 ;! END;!
07000 FI
07100 ;! IF NOT q_echoenabled THEN
07200 IF
07300 SKIPE qechoenabled(xbase)
07400 GOTO FALSE
07500 THEN
07600 ;! BEGIN IF q_gotchar = tab THEN q_gotchar:= ' ';!
07800 CAIN xgotch,qht
08100 LI xgotch," "
08300 ;! IF terminaltype NE tandberg THEN
08400 IF
08500 CAMN xtyp,tandberg(xbase)
08600 GOTO FALSE
08700 THEN
08800 ;! outchr(terminalout,q_gotchar,1) ELSE
08900 L X0,xgotch
09000 outchr
09100 ELSE
09200 ;! outchr(terminalout,
09300 ;! IF q_gotchar = linefeed AND q_horizontalpos < heightm1 THEN
09400 ;! down ELSE q_gotchar,1);!
09500 L xhoriz, qhoriz(xbase)
09550 L X0, down(xbase)
09700 CAIN xgotch,qlf
09800 CAML xhoriz, heim1(xbase)
10300 L X0,xgotch
10500 outchr
10600 FI
10700 ;! END;!
10800 FI
10900 ;! GOTO loop;!
11000 ;! END;!
11100 RET
11200 EPROC
00100 subttl blatxt = blanks part of screen text line
00200 blatxt: PROC
00300 ;! screen[q_verticalpos].Sub(q_horizontalpos+1,
00400 ;! width-q_horizontalpos) := NOTEXT
00500 SAVE XBH
00550 q==6 ;! Offset of first array element (one dimension)
00600 L X1,qverticalpos(xbase) ;! Index into screen lines
00700 ADDI X1,(X1) ;! * 2 for text
00800 ADD X1,screen(xbase) ;! + array address
00900 LD XWAC2,q(X1) ;! Get screen[q_horizontalpos] to XWAC2-3
01000 L XWAC4,qhorizontalpos(xbase) ;! 1st Sub param
01200 L XWAC5,width(xbase) ;! 2nd Sub param
01300 SUBI XWAC5, (XWAC4)
01350 ADDI XWAC4,1
01400 LI XTAC,XWAC2 ;! XWAC2-3 have text ref
01500 XEC TXSU ;! Call Sub standard proc
01600 SETZB XWAC4,XWAC5 ;! Result now in XWAC2-3, set RHS = NOTEXT
01700 LI XTAC,XWAC2 ;! Same top ac as before
01800 XEC TXVA ;! Perform assignment
01900 RETURN
02000 EPROC
02100
02200 ;! Byte pointer table
02300
02400 VT$BPT::POINT 7,0,-1
02500 POINT 7,0,6
02600 POINT 7,0,13
02700 POINT 7,0,20
02800 POINT 7,0,27
02900 POINT 7,0,34
03000 LIT
03100 END;