SCR # 1 0 ( LOAD SCREEN) 1 DECIMAL 2 1 WARNING ! ( GET ERR MSGS, NOT #S) 3 4 CR ." LOADING EDITOR... " 6 LOAD 7 LOAD 8 LOAD 9 LOAD 5 CR ." LOADING ASSEMBLER... " 10 LOAD 11 LOAD 12 LOAD 13 LOAD 6 14 LOAD 15 LOAD 7 CR ." LOADING STRING PACKAGE... " 19 LOAD 20 LOAD 21 LOAD 8 22 LOAD 9 CR 10 : BYE FLUSH CR ." LEAVING FORTH. HAVE A GOOD DAY." CR BYE ; 11 CR 12 13 14 15 SCR # 2 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 3 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 4 0 ( ERROR, WARNING, AND OTHER MESSAGES - SCREENS 4 AND 5 ) 1 EMPTY STACK 2 STACK OR DICTIONARY FULL 3 HAS INCORRECT ADDRESS MODE 4 ISN'T UNIQUE 5 6 DISC RANGE 7 8 9 10 11 12 13 14 15 FORTH INTEREST GROUP MAY 1979 SCR # 5 0 ( ERROR MESSAGES, CONTINUED ) 1 COMPILATION ONLY, USE IN DEFINITION 2 EXECUTION ONLY 3 CONDITIONALS NOT PAIRED 4 DEFINITION NOT FINISHED 5 IN PROTECTED DICTIONARY 6 USE ONLY WHEN LOADING 7 8 DECLARE VOCABULARY 9 10 11 12 13 14 15 SCR # 6 0 ( EDITOR - SET-UP) 1 VOCABULARY EDITOR IMMEDIATE 0 VARIABLE ESCR DECIMAL 2 0 VARIABLE CURSOR 0 VARIABLE STACKPTR : STK SP@ STACKPTR ! ; 3 : #ARGS ( ->N ) SP@ STACKPTR @ SWAP - 2 / 0 MAX ; 4 : E ESCR @ BLOCK DROP [COMPILE] EDITOR STK ; 5 : EDIT -DUP IF ESCR ! 0 CURSOR ! E ELSE ." ERR 0 ARG" ENDIF ; 6 EDITOR DEFINITIONS 7 : EX FLUSH [COMPILE] FORTH ; 8 ( THE FOLLOWING ARE UTILITY ROUTINES FOR LATER DEFINITIONS.) 9 : GETWORD ( -> ) 1 WORD HERE 1+ C@ 0= IF 0 HERE C! ENDIF ; 10 : GETPAD ( -> ) GETWORD HERE PAD 65 CMOVE ; 11 : RANGE ( -> ) CURSOR @ 0 MAX 1023 MIN CURSOR ! ; 12 : CURSADDR ( -> ADDR ) ESCR @ BLOCK UPDATE CURSOR @ + ; 13 : CLINE ( -> POSITION ) CURSOR @ 64 MOD ; 14 : LINEADDR ( -> ADDR ) CURSADDR CLINE - ; 15 : NLINE ( -> LINE# ) CURSOR @ 64 / ; SCR # 7 0 ( EDITOR - OPERATIONS) 1 : LDEFAULT ( N? -> N ) #ARGS IF 64 * CURSOR ! RANGE ENDIF ; 2 : 1DEFAULT ( N? -> N ) #ARGS 0= IF 1 ENDIF ; 3 : NEW LDEFAULT 16 NLINE DO CR QUERY GETPAD PAD 1+ C@ 32 < 4 IF LEAVE ELSE LINEADDR 64 BLANKS PAD 1+ LINEADDR PAD C@ 5 64 MIN CMOVE 64 CURSOR +! RANGE ENDIF LOOP STK ; 6 : T LDEFAULT CR LINEADDR PAD 64 CMOVE CURSADDR PAD CLINE + 1+ 7 64 CLINE - CMOVE 95 PAD CLINE + C! NLINE 3 .R SPACE 8 PAD 65 TYPE STK ; 9 : R LDEFAULT GETPAD PAD 1+ CURSADDR PAD C@ 10 64 MIN CMOVE PAD C@ CURSOR +! RANGE T STK ; 11 : L ESCR @ FORTH LIST EDITOR CR T STK ; 12 : M 1DEFAULT CURSOR +! RANGE T STK ; 13 : TRADE ( M,N---) 2 0 DO 64 * CURSOR ! RANGE LINEADDR SWAP LOOP 14 DUP PAD 64 CMOVE OVER SWAP 64 CMOVE PAD SWAP 64 CMOVE STK ; 15 SCR # 8 0 ( EDITOR, SCREEN 3) 1 : D-+ONLY DUP CURSADDR + CURSADDR 64 CLINE - CMOVE 2 LINEADDR 64 + OVER - SWAP BLANKS T ; 3 : D ( ADJUST ARG IF NEG, DEFAULT, OUT OF LINE) 1DEFAULT DUP 0< 4 IF ( NEGATIVE ARG) CLINE MINUS MAX DUP CURSOR +! ABS 5 ELSE 64 CLINE - MIN ENDIF -DUP IF D-+ONLY ENDIF STK ; 6 : I LDEFAULT CURSADDR PAD 64 CMOVE GETWORD HERE 1+ CURSADDR 7 HERE C@ CMOVE PAD CURSADDR HERE C@ + LINEADDR 64 + OVER - 8 0 MAX CMOVE HERE C@ CURSOR +! RANGE T STK ; 9 : COMP ( ADDR ADDR LEN -> BOOL. TEST FOR STRINGS EQUAL) 10 OVER + SWAP DO DUP C@ FORTH I C@ - 11 IF ( UNEQUAL) DROP 0 LEAVE ELSE 1+ ENDIF LOOP ; 12 : SEARCH ( ADDR LEN -> ADDR-OR-0 ) HERE C@ - 1 MAX 13 OVER + SWAP 0 ROT ROT DO FORTH I HERE 1+ HERE C@ COMP 14 IF DROP FORTH I LEAVE ENDIF LOOP ; 15 SCR # 9 0 ( EDITOR, SCREEN 4) 1 0 VARIABLE SAVESTRING 64 ALLOT ( TO STORE SEARCH STRING) 2 : SAVEARG ( ->. SAVE OR RESTORE SEARCH STRING ARGUMENT) 3 HERE 1+ C@ IF ( NOT NULL) HERE SAVESTRING HERE C@ 1+ CMOVE 4 ELSE ( NULL) SAVESTRING HERE SAVESTRING C@ 1+ CMOVE ENDIF ; 5 : S ( -> ) LDEFAULT 1 WORD SAVEARG CURSADDR 1024 CURSOR @ 6 - SEARCH -DUP IF CURSADDR - HERE C@ + CURSOR +! RANGE ENDIF 7 T STK ; 8 : -R SAVESTRING C@ MINUS D I ; 9 : SCRATCH EMPTY-BUFFERS EX ; 10 : SPREAD ( N -> ) LDEFAULT NLINE DUP 14 > IF ." CAN'T SPREAD" 11 CR ELSE 0 MAX DUP 1 - 14 DO FORTH I EDITOR DUP 1+ TRADE 12 -1 +LOOP 64 * ESCR @ BLOCK + 64 BLANKS ENDIF ; 13 FORTH DEFINITIONS 14 : SCREENMOVE ( FROM TO -> ) FLUSH SWAP BLOCK SWAP 15 BLOCK UPDATE 1024 CMOVE ; SCR # 10 0 ( ASSEMBLER) OCTAL 1 VOCABULARY ASSEMBLER IMMEDIATE 0 VARIABLE OLDBASE 2 : ENTERCODE [COMPILE] ASSEMBLER BASE @ OLDBASE ! OCTAL SP@ ; 3 : CODE CREATE ENTERCODE ; 4 ASSEMBLER DEFINITIONS 5 ' ENTERCODE 2 - ' ;CODE 10 + ! ( PATCH ';CODE') 6 : FIXMODE ( COMPLETE THE MODE PACKET) 7 DUP -1 = IF DROP ELSE DUP 10 SWAP U< IF 67 ENDIF ENDIF ; 8 : OP @ , ; 9 : ORMODE ( MODE ADDR -> . SET MODE INTO INSTR.) 10 SWAP OVER @ OR SWAP ! ; 11 : ,OPERAND ( ?OPERAND MODE -> ) DUP 67 = OVER 77 = OR IF ( PC) 12 SWAP HERE 2 + - SWAP ENDIF DUP 27 = OVER 37 = OR ( LITERAL) 13 SWAP 177760 AND 60 = OR ( RELATIVE) IF , ENDIF ; 14 : 1OP @ , FIXMODE DUP HERE 2 - 15 ORMODE ,OPERAND ; DECIMAL SCR # 11 0 ( ASSEMBLER, CONT.) OCTAL 1 : SWAPOP ( -> . EXCHANGE OPERANDS OF 3-WORD INSTR, ADJ. PC-REL) 2 HERE 2 - @ HERE 6 - @ 6700 AND 6700 = IF ( PC-REL) 2 + ENDIF 3 HERE 4 - @ HERE 6 - @ 67 AND 67 = IF ( PC-REL) 2 - ENDIF 4 HERE 2 - ! HERE 4 - ! ; 5 : 2OP @ , 6 FIXMODE DUP HERE 2 - DUP >R ORMODE ,OPERAND 7 FIXMODE DUP 100 * R ORMODE ,OPERAND HERE R> - 6 = 8 IF SWAPOP ENDIF ; 9 : ROP @ , FIXMODE DUP HERE 2 - DUP >R ORMODE 10 ,OPERAND DUP 7 SWAP U< IF ." ERR-REG-B " ENDIF 11 100 * R> ORMODE ; 12 : BOP @ , HERE - DUP 376 > 13 IF ." ERR-BR+ " . ENDIF DUP -400 < IF ." ERR-BR- " . 14 ENDIF 2 / 377 AND HERE 2 - ORMODE ; 15 DECIMAL SCR # 12 0 ( ASSEMBLER - INSTRUCTION TABLE) OCTAL 1 010000 2OP MOV, 110000 2OP MOVB, 020000 2OP CMP, 2 120000 2OP CMPB, 060000 2OP ADD, 160000 2OP SUB, 3 030000 2OP BIT, 130000 2OP BITB, 050000 2OP BIS, 4 150000 2OP BISB, 040000 2OP BIC, 140000 2OP BICB, 5 005000 1OP CLR, 105000 1OP CLRB, 005100 1OP COM, 6 105100 1OP COMB, 005200 1OP INC, 105200 1OP INCB, 7 005300 1OP DEC, 105300 1OP DECB, 005400 1OP NEG, 8 105400 1OP NEGB, 005700 1OP TST, 105700 1OP TSTB, 9 006200 1OP ASR, 106200 1OP ASRB, 006300 1OP ASL, 10 106300 1OP ASLB, 006000 1OP ROR, 106000 1OP RORB, 11 006100 1OP ROL, 106100 1OP ROLB, 000300 1OP SWAB, 12 005500 1OP ADC, 105500 1OP ADCB, 005600 1OP SBC, 13 105600 1OP SBCB, 006700 1OP SXT, 000100 1OP JMP, 14 074000 ROP XOR, 004000 ROP JSR, 15 : RTS, 200 OR , ; DECIMAL SCR # 13 0 ( ASSEMBLER - CONT.) OCTAL 1 000400 BOP BR, 001000 BOP BNE, 001400 BOP BEQ, 2 100000 BOP BPL, 100400 BOP BMI, 102000 BOP BVC, 3 102400 BOP BVS, 103000 BOP BCC, 103400 BOP BCS, 4 002000 BOP BGE, 002400 BOP BLT, 003400 BOP BLE, 5 101000 BOP BHI, 101400 BOP BLOS, 103000 BOP BHIS, 6 103400 BOP BLO, 003000 BOP BGT, 000003 OP BPT, 7 000004 OP IOT, 000002 OP RTI, 000006 OP RTT, 8 000000 OP HALT, 000001 OP WAIT, 000005 OP RESET, 9 000241 OP CLC, 000242 OP CLV, 000244 OP CLZ, 10 000250 OP CLN, 000261 OP SEC, 000262 OP SEV, 11 000264 OP SEZ, 000270 OP SEN, 000277 OP SCC, 12 000257 OP CCC, 000240 OP NOP, 006400 OP MARK, 13 : EMT, 104000 + , ; 14 15 DECIMAL SCR # 14 0 ( ASSEMBLER - REGISTERS, MODES, AND CONDITIONS) OCTAL 1 : C CONSTANT ; 0 C R0 1 C R1 2 C R2 3 C R3 4 C R4 2 5 C R5 6 C SP 7 C PC 2 C W 3 C U 4 C IP 5 C S 6 C RP 3 : RTST ( R MODE -> MODE) OVER DUP 7 > SWAP 0 < OR 4 IF ." NOT A REGISTER: " OVER . ENDIF + -1 ; 5 : )+ 20 RTST ; : -) 40 RTST ; : I) 60 RTST ; 6 : @)+ 30 RTST ; : @-) 50 RTST ; : @I) 70 RTST ; 7 : # 27 -1 ; : @# 37 -1 ; 8 : () DUP 10 U< IF ( REGISTER DEFERRED) 10 + -1 9 ELSE ( RELATIVE DEFERRED) 77 -1 ENDIF ; 10 ( NOTE - THE FOLLOWING CONDITIONALS REVERSED FOR 'IF,', ETC. ) 11 001000 C EQ 001400 C NE 100000 C MI 100400 C PL 12 102000 C VS 102400 C VC 103000 C CS 103400 C CC 13 002000 C LT 002400 C GE 003000 C LE 003400 C GT 14 101000 C LOS 101400 C HI 103000 C LO 103400 C HIS 15 DECIMAL SCR # 15 0 ( ASSEMBLER - STRUCTURED CONDITIONALS) OCTAL 1 2 : IF, ( CONDITION -> ADDR ) HERE SWAP , ; 3 : IPATCH ( ADDR ADDR -> . ) OVER - 2 / 1 - 377 AND 4 SWAP DUP @ ROT OR SWAP ! ; 5 : ENDIF, ( ADDR -> ) HERE IPATCH ; : THEN, ENDIF, ; 6 : ELSE, ( ADDR -> ADDR ) 00400 , HERE IPATCH HERE 2 - ; 7 : BEGIN, ( -> ADDR ) HERE ; 8 : WHILE, ( CONDITION -> ADDR ) HERE SWAP , ; 9 : REPEAT, ( ADDR ADDR -> ) HERE 400 , ROT IPATCH HERE IPATCH ; 10 : UNTIL, ( ADDR CONDITION -> ) , HERE 2 - SWAP IPATCH ; 11 : C; CURRENT @ CONTEXT ! OLDBASE @ BASE ! SP@ 2+ = 12 IF SMUDGE ELSE ." CODE ERROR, STACK DEPTH CHANGED " ENDIF ; 13 14 : NEXT, IP )+ W MOV, W @)+ JMP, ; 15 FORTH DEFINITIONS DECIMAL SCR # 16 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 17 0 ( ASSEMBLER - EXAMPLES) 1 CODE TEST1 33006 # 33000 MOV, NEXT, C; 2 CODE TEST2 555 # 33000 () MOV, NEXT, C; 3 CODE TESTDUP S () S -) MOV, NEXT, C; 4 CODE TEST0 R0 S -) MOV, NEXT, C; 5 CODE TESTBYTE 33006 R1 MOVB, R1 S -) MOV, NEXT, C; 6 CODE TEST3 33000 # R1 MOV, 444 # 20 R1 I) MOV, NEXT, C; 7 CODE TEST-DUP S () TST, NE IF, S () S -) MOV, ENDIF, NEXT, C; 8 CODE TESTLP1 15 # R1 MOV, BEGIN, R1 DEC, GT WHILE, R1 S -) MOV, 9 REPEAT, NEXT, C; 10 CODE TESTLP2 15 # R1 MOV, BEGIN, R1 S -) MOV, R1 DEC, 11 EQ UNTIL, NEXT, C; 12 : TESTVARIABLE CONSTANT ;CODE W S -) MOV, NEXT, C; 13 14 15 SCR # 18 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 19 0 ( STRING ROUTINES) DECIMAL 1 ( NOTE: STRING-STACK PTR, $SP, IS 300 BYTES FROM STACK ORIGIN) 2 300 VARIABLE STACKSIZE S0 @ STACKSIZE @ - VARIABLE $SP 3 : $CLEAR ( -> ) S0 @ STACKSIZE @ - $SP ! ; $CLEAR 4 : $LEN ( -> LENGTH . LENGTH OF TOP OF $STACK) $SP @ DUP S0 @ 5 STACKSIZE @ - < 0= IF ." $STACK EMPTY" QUIT ELSE @ ENDIF ; 6 : $DROP ( ->. DROP FROM $STACK) $LEN 2+ =CELLS $SP +! ; 7 : $COUNT ( ADDR -> ADDR LENGTH) DUP 2+ SWAP @ ; 8 : $. ( ->. PRINT STRING) $SP @ $COUNT -TRAILING TYPE $DROP ; 9 : $?OVER ( N-> . ) HERE 256 + + $SP @ < 0= 10 IF ." WOULD CAUSE $OVERFLOW" QUIT ENDIF ; 11 : $@TEXT ( ADDR CNT ->. MOVE TEXT INTO $STACK) DUP 2+ =CELLS 12 DUP $?OVER MINUS $SP +! $SP @ ! $SP @ $COUNT CMOVE ; 13 : $@ ( FROM-ADDR -> . STRING INTO $STACK) $COUNT $@TEXT ; 14 : (") R COUNT DUP 1+ =CELLS R> + >R $@TEXT ; 15 SCR # 20 0 ( STRINGS - CONTINUED) 1 : $NULL ( CREATE NULL STRING) -2 $SP +! 0 $SP @ ! ; 2 : " ( ->. STRING TO $STACK - COMPILE OR EXECUTE) STATE @ 3 IF COMPILE (") 34 WORD HERE C@ 1+ =CELLS ALLOT 4 ELSE 34 WORD HERE COUNT $@TEXT ENDIF ; IMMEDIATE 5 : $! ( TO-ADDR -> . MOVE STRING FROM $STACK TO MEMORY.) 6 $SP @ SWAP $LEN 2+ CMOVE $DROP ; 7 : $DIM ( LEN -> . CREATES STRING VARIABLE OF GIVEN LENGTH.) 8 0 CONSTANT HERE HERE 2 - ! 2+ =CELLS ALLOT ; 9 : $VARIABLE ( -> . CREATES $VAR FROM $STACK TOP.) $LEN $DIM 10 $SP @ HERE $LEN 2+ =CELLS - $LEN 2+ CMOVE $DROP ; 11 : $DUP ( -> ) $SP @ $@ ; 12 : $SEG ( BEGIN END -> ) OVER - 1+ SWAP 1 - 13 $SP @ 2+ + SWAP $@TEXT ; 14 : $STR ( N -> ) S->D SWAP OVER DABS <# #S SIGN #> $@TEXT ; 15 SCR # 21 0 ( STRINGS - CONTINUED) 1 : $VAL ( -> N . POSITIVE ONLY) HERE 33 32 FILL 2 $SP @ 2+ HERE $LEN CMOVE 0 S->D HERE 1 - (NUMBER) 3 DROP $DROP DROP ; 4 : $SECOND $LEN =CELLS 2+ $SP @ + DUP S0 @ STACKSIZE @ - < 0= 5 IF ." ERROR, NO SECOND STRING" QUIT ENDIF ; 6 : $OVER $SECOND $@ ; 7 : MOVEW ( FROM TO NBYTES -> . LIKE 'CMOVE' BUT FROM HIGH END) 8 2 - -2 SWAP DO OVER I + @ OVER I + ! -2 +LOOP DROP DROP ; 9 : $SWAP ( -> ) $OVER $SP @ ( FROM) DUP $LEN =CELLS 2+ + 10 ( TO) $LEN =CELLS 2+ $SECOND @ =CELLS 2+ + ( # OF BYTES) 11 MOVEW $LEN =CELLS 2+ $SP +! ; 12 13 14 15 SCR # 22 0 ( STRINGS - CONTINUED ) 1 0 VARIABLE TEMP 2 : $COMP ( -> NEG OR 0 OR POS. COMPARE STRINGS) 0 TEMP ! 3 $SECOND 2+ $SP @ 2+ ( STRING TEXT ADDRESSES) 4 $LEN $SECOND @ MIN ( # CHARACTERS TO COMPARE) 5 0 DO OVER I + C@ OVER I + C@ - -DUP IF LEAVE TEMP ! ENDIF 6 LOOP DROP DROP TEMP @ $DROP $DROP ; 7 : $< ( -> BOOL ) $COMP 0< ; 8 : $= ( -> BOOL ) $COMP 0= ; 9 : $> ( -> BOOL ) $COMP 0 > ; 10 : $+-EVEN ( -> ) $LEN $SWAP $SP @ ( FROM) DUP 2+ 11 $LEN =CELLS 2+ ( #) MOVEW 2 $SP +! $LEN + $SP @ ! ; 12 : $+ ( -> . CONCATENATE ) $LEN $SECOND @ ( SAVE LENGTHS) 13 $+-EVEN DUP 1 AND IF $SP @ 2+ + OVER SWAP DUP 1+ SWAP ROT 14 CMOVE 1 AND IF $SP @ DUP 2+ $LEN 2+ MOVEW 2 $SP +! ENDIF 15 ELSE DROP DROP ENDIF ; SCR # 23 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 24 0 ( TRIG LOOKUP ROUTINES - WITH SINE *10000 TABLE) 1 : TABLE SWAP 2 * + @ ; 2 10000 9998 9994 9986 9976 9962 9945 9925 9903 9877 3 9848 9816 9781 9744 9703 9659 9613 9563 9511 9455 4 9397 9336 9272 9205 9135 9063 8988 8910 8829 8746 5 8660 8572 8480 8387 8290 8192 8090 7986 7880 7771 6 7660 7547 7431 7314 7193 7071 6947 6820 6691 6561 7 6428 6293 6157 6018 5878 5736 5592 5446 5299 5150 8 5000 4848 4695 4540 4384 4226 4067 3907 3746 3584 9 3420 3256 3090 2924 2756 2588 2419 2250 2079 1908 10 1736 1564 1392 1219 1045 0872 0698 0523 0349 0175 11 0000 91 TABLE SINTABLE 12 : S180 DUP 90 > IF 180 SWAP - ENDIF SINTABLE ; 13 : SIN ( N -> SIN) 360 MOD DUP 0< IF 360 + ENDIF DUP 180 > 14 IF 180 - S180 MINUS ELSE S180 ENDIF ; 15 : COS ( N -> COS) 90 + SIN ; SCR # 25 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 26 0 ( FORTRAN LINKAGE, RSX) 1 CODE ACALL ( ARGS... N ADDR -> . CALL FORTRAN, ETC.) 2 S )+ R2 MOV, ( SAVE ENTRY ADDRESS IN REGISTER) 3 R3 RP -) MOV, R4 RP -) MOV, R5 RP -) MOV, ( SAVE R3,R4,R5) 4 S R5 MOV, ( THE STACK WILL BE THE ARG. LIST) 5 PC R2 () JSR, ( LINK THROUGH R2) 6 RP )+ R5 MOV, RP )+ R4 MOV, RP )+ R3 MOV, ( RESTR R3,R4,R5) 7 S )+ R2 MOV, R2 R2 ADD, R2 S ADD, ( DROP THE ARGS) 8 NEXT, C; 9 10 ( THIS IS AN EXAMPLE - WRITE LINES ON AN RSX FILE) 11 0 VARIABLE NFORT 12 : FILECALL 2 VLINK @ ACALL ; 13 : OPEN 1 NFORT ! 0 NFORT FILECALL ; 14 : CLOSE 3 NFORT ! 0 NFORT FILECALL ; 15 : WRITE ( ADDR ->. WRITE A LINE) 2 NFORT ! NFORT FILECALL ; SCR # 27 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 28 0 ( RT-11 SYSTEM-CALL EXAMPLE - DATE) 1 CODE DATE 12 400 * # R0 MOV, 374 EMT, R0 S -) MOV, NEXT, C; 2 : YEAR ( -> N ) DATE 31 AND 72 + ; 3 : DAY ( -> N ) DATE 32 / 31 AND ; 4 : MONTH ( -> N) DATE 1024 / 15 AND ; 5 6 7 8 9 10 11 12 13 14 15 SCR # 29 0 ( RSX-11M SYSTEM-CALL EXAMPLE - DATE) 1 DECIMAL 2 0 VARIABLE TBUFF 14 ALLOT 3 CODE TIME TBUFF # SP -) MOV, 2 400 * 75 + # SP -) MOV, 4 377 EMT, NEXT, C; 5 : YEAR ( -> N ) TIME TBUFF @ ; 6 : MONTH ( -> N ) TIME TBUFF 2+ @ ; 7 : DAY ( -> N ) TIME TBUFF 4 + @ ; 8 : HOUR ( -> N ) TIME TBUFF 6 + @ ; 9 : MINUTE ( -> N ) TIME TBUFF 8 + @ ; 10 : SECOND ( -> N ) TIME TBUFF 10 + @ ; 11 : TICK ( -> N ) TIME TBUFF 12 + @ ; 12 : TICKS/SECOND ( -> N ) TIME TBUFF 14 + @ ; 13 14 15 SCR # 30 0 ( RSX-11M SYSTEM-CALL EXAMPLE - TERMINAL I/O) 1 2 : PUSH ASSEMBLER SP -) MOV, FORTH ; 3 0 VARIABLE INBUF 78 ALLOT 4 0 VARIABLE IOSTAT 2 ALLOT 5 CODE INPUT 0 # PUSH 0 # PUSH 0 # PUSH 0 # PUSH 6 120 # PUSH INBUF # PUSH 0 # PUSH IOSTAT # PUSH 7 4 # PUSH 4 # PUSH 10400 # PUSH 6003 # PUSH 8 377 EMT, NEXT, C; 9 10 11 12 13 14 15 SCR # 31 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 32 0 ( EXAMPLES - RANDOM #S, VIRTUAL ARRAY, RECURSIVE CALL) 1 ( RANDOM NUMBER GENERATOR. CAUTION - EVERY 128TH RELATED.) 2 1001 VARIABLE RSEED 3 : URAND ( -> N, UNSIGNED 0-65K) 4 RSEED @ 2725 U* 13947 S->D D+ DROP DUP RSEED ! ; 5 : RAND ( N -> M, 0 TO N-1) 6 URAND U* SWAP DROP ; 7 ( 'VARRAY' CREATES A VIRTUAL ARRAY ON DISK SCREENS.) 8 : VARRAY ( LRECL #RECS STARTSCREEN -> ) 9 >R DUP R 2 + @ < 0= OVER 0< OR 12 IF ." ERROR, V-ARRAY RANGE " . R> DROP 13 ELSE R 6 + @ /MOD R @ + BLOCK SWAP R> 4 + @ * + THEN ; 14 15 : MYSELF ( RECURSIVE CALL) LATEST PFA CFA , ; IMMEDIATE SCR # 33 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 34 0 ( CREATE BOOTABLE IMAGE ON SCREENS 40-47. FOR STAND-ALONE.) 1 ( NOTE - THIS DOES NOT WRITE THE BOOT BLOCK OR THE OTHER FORTH) 2 ( SCREENS. IF YOU START WITH A BLANK DISK, FIRST USE THE COPY) 3 ( PROGRAM ON SCREEN 38, AND MOVE THE COPY TO DX0. THEN EXECUTE) 4 ( 'DECIMAL 34 LOAD'. THE BOOT LOADER WILL ONLY HANDLE) 5 ( IMAGES UP TO 7.9K BYTES. THIS LEAVES SEVERAL HUNDRED) 6 ( BYTES FOR NEW OPERATIONS, AND THESE COULD LOAD MORE.) 7 DECIMAL : SIZETEST 1024 8 * 256 - HERE U< IF ." TOO BIG" 8 QUIT THEN ; SIZETEST FORGET SIZETEST 9 OCTAL ( NEXT LINE RESETS THE START-UP TABLE.) 10 LATEST 14 +ORIGIN ! HERE 36 +ORIGIN ! HERE 34 +ORIGIN ! 11 DECIMAL 35 LOAD CREATE-BINARY-IMAGE ( WRITE SYSTEM) 12 10 LOAD 11 LOAD 12 LOAD 13 LOAD 14 LOAD 15 LOAD ( ASSEMBLER) 13 36 LOAD ( WRITES BOOT LOADER AT END OF SCREEN 47) 14 COLD ( COLD START OF NEW SYSTEM - GET RID OF ASSEMBLER ETC.) 15 SCR # 35 0 ( CREATE A BINARY IMAGE ON SCREENS 40 - 47 ) 1 ( START AT ZERO) 2 : CREATE-BINARY-IMAGE 48 40 DO 3 I 40 - 1024 * ( ADDRESS TO MOVE FROM) 4 I BLOCK ( ADDRESS TO MOVE TO) 5 1024 CMOVE UPDATE LOOP FLUSH ; 6 7 8 9 10 11 12 13 14 15 SCR # 36 0 ( CREATE BOOT LOADER. NOTE - DOES NOT WRITE BOOT BLOCK) 1 ASSEMBLER DEFINITIONS OCTAL 2 : INIT, 1000 # R0 MOV, 00000 # R1 MOV, 3 177170 # R4 MOV, 200 # R3 MOV, ; 4 : ?TERM, R1 () TSTB, LE IF, 1000 @# JMP, ENDIF, ; 5 : WAITT, BEGIN, R3 R4 () BIT, NE UNTIL, ; 6 : WAITD, BEGIN, 40 # R4 () BIT, NE UNTIL, ; 7 : ?ERR, R4 () TST, LE IF, HALT, ENDIF, ; 8 : BLOOP, R3 R2 MOV, 9 BEGIN, WAITT, 2 R4 I) R0 )+ MOVB, R2 DEC, EQ UNTIL, ; 10 : NEXTTAB, 1 R1 I) R5 MOVB, R5 INC, R5 INC, 11 R5 32 # CMP, GT IF, 32 # R5 SUB, THEN, 12 R5 1 R1 I) MOVB, 1 R1 I) 2 R1 I) CMPB, 13 EQ IF, 3 # R1 ADD, ENDIF, ; 14 15 DECIMAL 37 LOAD SCR # 37 0 ( CREATE BOOT LOADER, CONT.) OCTAL 1 : TRACK, R1 () R5 MOVB, R5 2 R4 I) MOV, ; 2 : SECTOR, 1 R1 I) R5 MOVB, R5 2 R4 I) MOV, ; 3 : MAINL, BEGIN, ?TERM, 7 # R4 () MOV, WAITT, SECTOR, WAITT, 4 TRACK, WAITD, ?ERR, 3 # R4 () MOV, BLOOP, NEXTTAB, 5 400 UNTIL, ; 6 : 2, 400 * + , ; 7 : TABLE, 17 27 2, 7 17 2, 10 10 2, 8 20 15 2, 15 20 2, 16 16 2, 9 21 23 2, 23 21 2, 24 26 2, 0 0 2, ; 10 11 CODE BOOT 35000 JMP, C; 12 : TASK ; 13 35000 DP ! HERE 6 + INIT, WAITD, MAINL, HERE SWAP ! TABLE, 14 FORGET TASK 15 17572 35006 ! 35000 21 26 WTS 35200 21 30 WTS SCR # 38 0 ( DISK COPY FROM SYSTEM DISK TO DX1) 1 DECIMAL 20000 CONSTANT C 2 : GET 26 0 DO C I 128 * + OVER I 3 * 26 MOD 1+ RTS 3 LOOP ; 4 : PUT 26 0 DO C I 128 * + OVER 77 + I 3 * 26 MOD 1+ WTS 5 LOOP ; 6 : COPY 77 0 DO I GET DROP I PUT DROP LOOP ; 7 8 9 10 11 12 13 14 15 SCR # 39 0 ( ** CAUTION ** BINARY IMAGE IN SCREENS 40-47) 1 ( SCREENS 40 - 47 CONTAIN THE BOOTABLE STAND-ALONE SYSTEM.) 2 ( THE LAST 256 BYTES OF THIS SYSTEM IMAGE CONTAIN A LOADER.) 3 ( ADVISE RESERVING SCREENS 48 - 59 FOR BINARY PROGRAM OVERLAYS.) 4 ( FOR NOW, 50-56 CONTAIN AN EXAMPLE OF FORTH PROGRAMMING FOR) 5 ( A FLOPPY DRIVER. THESE SCREENS ARE NO LONGER USED BY THE) 6 ( SYSTEM. THEY ARE FOR ILLUSTRATION ONLY, AND MAY BE) 7 ( DELETED.) 8 9 10 11 12 13 14 15 SCR # 40 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 41 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 42 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 43 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 44 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 45 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 46 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 47 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 48 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 49 0 ( NOTE CONCERNING SCREENS 50 - 56 ) 1 SCREENS 50 - 56 ARE NOT USED IN THE CURRENT SYSTEM. THEY 2 ARE LEFT OVER FROM DEVELOPMENT OF THE STAND-ALONE VERSION'S 3 DISKETTE HANDLER. THOUGH NOT PRODUCTIZED OR FULLY DOCUMENTED, 4 THEY WERE LEFT ON THE DISKETTE FOR POSSIBLE STUDY BY ADVANCED 5 USERS. OF COURSE THEY CAN BE ERASED, AND THE SPACE RE-USED. 6 7 8 9 10 11 12 13 14 15 SCR # 50 0 ( FLOPPY DRIVER - MACROS) 1 ASSEMBLER DEFINITIONS OCTAL ( SET UP MACROS) 2 : WAITT, ( ->. MACRO - WAIT FOR 'TRANSFER' FLAG) 3 BEGIN, RXCS 200 # BIT, NE UNTIL, ; 4 : WAITD, ( ->. MACRO - WAIT FOR 'DONE' FLAG) 5 BEGIN, RXCS 40 # BIT, NE UNTIL, ; 6 : EMPTY, ( ADDR ->. USES R0. EMPTY CONTROLLER'S BUFFER) 7 S )+ R0 MOV, ( ADDRESS) 200 # S -) MOV, ( COUNT) 8 BEGIN, WAITT, RXDB R0 )+ MOVB, ( MOVE 1 BYTE) 9 S () DEC, EQ UNTIL, S )+ TST, ( POP) ; 10 : FILL, ( ADDR ->. USES R0. FILL CONTROLLER'S BUFFER) 11 S )+ R0 MOV, ( ADDRESS) 200 # S -) MOV, ( COUNT) 12 BEGIN, WAITT, R0 )+ RXDB MOVB, ( MOVE 1 BYTE) 13 S () DEC, EQ UNTIL, S )+ TST, ( POP) ; 14 FORTH DEFINITIONS DECIMAL 15 55 LOAD 51 LOAD 52 LOAD 53 LOAD 54 LOAD SCR # 51 0 ( FLOPPY DRIVER, NRTS) 1 CODE NRTS ( ADDRN TRN SECN ... ADDR1 TR1 SEC1 N -> FLAG.) 2 ( USES R0, R1. READ N SECTORS.) 3 S )+ R1 MOV, ( # OF SECTORS TO READ) 4 BEGIN, 7 # R0 MOV, PC ' DRIVE2? JSR, ( ADJUST ) 5 R0 RXCS MOV, WAITT, ( 'READ' COMMAND) 6 S )+ RXDB MOV, WAITT, ( MOVE SECTOR #) 7 S )+ RXDB MOV, WAITD, ( MOVE TRACK #) ERRTST, 8 3 # RXCS MOV, ( 'EMPTY' COMMAND) 9 EMPTY, ERRTST, 10 R1 DEC, EQ UNTIL, 11 S -) CLR, ( FLAG, 0=GOOD READ) NEXT, C; 12 13 : RTS ( ADDR TR SEC -> FLAG) 14 1 NRTS IF ." DISK READ ERROR IN RTS" QUIT THEN ; 15 SCR # 52 0 ( FLOPPY DRIVER - NWTS) 1 CODE NWTS ( ADDRN TRN SECN ... ADDR1 TR1 SEC1 N -> FLAG.) 2 ( USES R0, R1. WRITE N SECTORS) 3 S )+ R1 MOV, ( # OF SECTORS TO BE WRITTEN) 4 BEGIN, 5 1 # RXCS MOV, WAITT, ( 'FILL' COMMAND) 6 4 S I) S -) MOV, ( PUSH COPY OF ADDRESS) 7 FILL, ERRTST, 5 # R0 MOV, PC ' DRIVE2? JSR, ( ADJUST) 8 R0 RXCS MOV, WAITT, ( 'WRITE' COMMAND) 9 S )+ RXDB MOV, WAITT, ( MOVE SECTOR #) 10 S )+ RXDB MOV, WAITD, ( MOVE TRACK #) ERRTST, 11 S )+ TST, ( POP ADDRESS) 12 R1 DEC, EQ UNTIL, 13 S -) CLR, ( FLAG, 0 = GOOD WRITE) NEXT, C; 14 : WTS ( ADDR TR SEC -> FLAG) 15 1 NWTS IF ." DISK WRITE ERROR IN WTS" QUIT THEN ; SCR # 53 0 ( FLOPPY DRIVER - SKEW, NSETUP) 1 OCTAL 2 ( NOTE - THE 'SEQUENCE #' IS 0-ORIGIN SECTOR SEQUENCE, SKEWED) 3 : SKEW1 ( SEQUENCE# -> TRACK SECTOR) 4 ( TR=S/32+1; SEC=<6+2S+/15>MOD 32 + 1 ) 5 DUP 32 / SWAP 6 OVER 6 * OVER 2 * + SWAP 32 MOD 15 / + 32 MOD 1+ 7 SWAP 1+ SWAP ; DECIMAL 56 LOAD 8 : NSETUP ( ADDR SEQ# N -> ADDRN TRN SECN ... ADDR1 TR1 SEC1) 9 OVER 1975 > IF SWAP 56 + SWAP THEN ( 1920 VS 2002 PER DISK) 10 ROT OVER 128 * + ROT ROT ( INCREMENT ADDRESS TO PAST AREA) 11 OVER + 1 - SWAP 1 - SWAP ( SET UP FOR +LOOP ON SEQ#) 12 DO 128 - ( ADJUST THE ADDRESS) 13 DUP ( COPY ADDRESS) I SKEW ( COMPUTE TRACK & SECTOR) 14 ROT ( BRING COPY OF ADDRESS TO STACK TOP) 15 -1 +LOOP DROP ( EXTRA ADDRESS) ; SCR # 54 0 ( FLOPPY - TR/W) 1 : ?READERR ( FLAG ->) 2 IF ." DISK READ ERROR" QUIT ENDIF ; 3 : ?WRITERR ( FLAG ->) 4 IF ." DISK WRITE ERROR" QUIT ENDIF ; 5 : TR/W ( ADDR BLOCK# R=1,W=0 ->) 6 >R 6 + 8 * R> ( CHANGE SCREEN # TO FIRST SEQ #) 7 IF 8 NSETUP 8 NRTS ?READERR 8 ELSE 8 NSETUP 8 NWTS ?WRITERR THEN ; 9 ' TR/W 2 - ' BUFFER 44 + ! 10 ' TR/W 2 - ' BLOCK 50 + ! 11 ' TR/W 2 - ' FLUSH 36 + ! 12 13 14 15 SCR # 55 0 ( FLOPPY - ERROR TEST. LOAD AFTER 50.) 1 ASSEMBLER DEFINITIONS OCTAL 2 : ERRTST, ( MACRO - IF ERROR, -> -1 AND EXIT) 3 RXCS TST, LT IF, -1 # S -) MOV, NEXT, THEN, ; 4 FORTH DEFINITIONS DECIMAL 5 6 CODE DRIVE2? ( ->. SUBROUTINE - ADJUST R0, TRACK IF SECOND DR) 7 2 S I) 114 # CMP, ( TRACK > 76 ? ) 8 HI IF, 115 # 2 S I) SUB, ( SUBTRACT 77) 9 20 # R0 BIS, ( SET UNIT-SELECT BIT) 10 THEN, PC RTS, C; 11 12 13 14 15 SCR # 56 0 ( FLOPPY - APPENDAGE OF 53) 1 : SKEW ( LIKE BEFORE, ONLY HANDLE 2ND DRIVE) 2 DUP 1975 > IF 1976 - SKEW1 SWAP 77 + SWAP 3 ELSE SKEW1 THEN ; 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 57 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 58 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 59 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 60 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 61 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 62 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 63 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 64 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 65 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 66 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 67 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 68 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 69 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 SCR # 70 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15