Google
 

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;