home *** CD-ROM | disk | FTP | other *** search
- ( PC/FORTH 2.0 Screen File 11/14/83 ) ;S Copyright (c) 1983 Ray Duncan Laboratory Microsystems 4147 Beethoven Street Los Angeles, CA 90066 this file created 29 Jan 1982 modified October 1983 for PC/FORTH 2.0 ( Change video modes 05/16/82 ) HEX ( color interface, 80 x 25 text mode ) : TEXTC 3 MODE B/W ; ( monochrome interface 80 x 25 text mode ) : TEXTM 7 MODE B/W ; ( 320 x 200 color graphics ) : LRGC 4 MODE 1 PALETTE 3 FOREGROUND ; ( 320 x 200 b/w graphics ) : LRGBW 5 MODE 0 PALETTE B/W ; ( 640 x 200 b/w graphics ) : HRGBW 6 MODE B/W ; DECIMAL ( Reallocate system memory under PCDOS 11/14/83 ) FORTH DEFINITIONS DECIMAL 2048 CONSTANT RET-STACK ( declare max size return stk) 128 CONSTANT USER-SIZE ( max storage for user variables) 80 CONSTANT TIB-SIZE ( length of terminal input buffer ) ( 22 LOAD compile #IN word if it is not already in system ) : REALLOCATE DECIMAL CR ." Size of FORTH area (kbytes) : " #IN 63 MIN 1024 * CR ." Enter # of screens to buffer: " #IN 10 MIN VOC-LINK @ 23 ORIGIN+ ! ( update init value VOC-LINK) 2 MAX ['] #BUFF >BODY ! ( set # buffers ) ['] LIMIT >BODY ! ( end of mem and disk buffers ) --> ( Reallocate system memory under PCDOS 11/16/83 ) LIMIT 1028 #BUFF * - ['] FIRST >BODY ! ( start of disk buffers ) FIRST PREV ! FIRST USE ! ( current and previous buffer ) FIRST USER-SIZE - DUP DUP 17 ORIGIN+ ! ( initializing value for R0 ) 7 ORIGIN+ ! ( initial UP ) 8 ORIGIN+ ! ( current UP ) FIRST RET-STACK - TIB-SIZE - USER-SIZE - DUP DUP 16 ORIGIN+ ! ( init S0) 18 ORIGIN+ ! ( init TIB ) R0 @ RP! ( move active return stack) SP! ( move active data stack ) COLD ; ( initialize user variables and restart system) ( System messages ) empty stack dictionary full has incorrect address mode is redefined is undefined disk address out of range stack overflow disk error BASE must be DECIMAL missing decimal point PC/FORTH 2.0 Laboratory Microsystems( System messages ) compilation only, use in definition execution only conditionals not paired definition not finished in protected dictionary use only when loading off current editing screen declare vocabulary illegal dimension in array definition negative array index array index too large ( 8086 Assembler messages ) 16 bit register not allowed 8 bit register not allowed address out of range immediate data value not allowed missing source register missing destination register illegal operation illegal operand instruction not implemented illegal destination register illegal source register illegal condition code register mismatch destination address missing ( Integer square root by Newton's method 04/08/82 ) ( this is only a demo and not mathematically elegant ) 20 CONSTANT SQRT-#-ITER ( n --- square-root ) : SQRT DUP 0< IF ." Illegal argument" 0 ERROR THEN DUP IF DUP 2/ SQRT-#-ITER 0 DO 2DUP / + 2/ LOOP SWAP DROP THEN ; ( chop screen file to desired length MSDOS 1.X ONLY 01/25/83 ) ( requires assembler to be loaded first ) BASE @ >R FORTH DEFINITIONS HEX CODE (CHOP) ( fcb_addr --- status ) DX POP CX, CX XOR AH, # 28 MOV 21 INT AH, AH XOR AX PUSH NEXT, END-CODE : CHOP ( #_of_screens --- ) SCREEN-FCB 21 + ! SCREEN-FCB (CHOP) IF CR ." Chop function unsuccessful" CR ELSE 10 SCREEN-FCB FDOS 2DROP ( close file ) SCREEN-FCB 0C + 18 ERASE ( clear out fcb) 0F SCREEN-FCB FDOS DROP 0FF AND 0FF = IF CR ." File could not be reopened." CR 0 0 FDOS THEN 400 SCREEN-FCB 0E + ! THEN ; R> BASE ! ;S ( Transfer from other system over serial interface HDN ) HEX : I1200 ( baud ) 80 3FB PC! 60 3F8 PC! 0 3F9 PC! 7 3FB PC! ; : I9600 ( baud ) 80 3FB PC! 0C 3F8 PC! 0 3F9 PC! 7 3FB PC! ; : ?TERM ?TERMINAL IF ABORT THEN 0 ; : WAITOUT BEGIN 3FD PC@ 20 AND ?TERM + UNTIL ; : WAITIN BEGIN 3FD PC@ 1 AND ?TERM + UNTIL ; : XIN WAITIN 3F8 PC@ ; ( wait and get a char ) : XOUT WAITOUT 3F8 PC! ; ( wait and send a char ) : TRADE XIN DUP XOUT ; ( leaves rec'd byte ) : CLEAR 3FD PC@ 1 AND IF 3F8 PC@ DROP THEN ; : CEMIT DUP 20 < OVER 7E > OR IF DROP 2E THEN EMIT ; : SGET ( SCR# -- ) BLOCK DUP 400 + SWAP DO TRADE DUP CEMIT I C! LOOP UPDATE FLUSH ; : RGET ( START# COUNT -- ) SWAP DUP ROT + 1+ SWAP DO CR CR ." screen # " I DUP . SGET LOOP ; ( Memory dump, byte format, intrasegment 02/26/82 ) FORTH DEFINITIONS DECIMAL : DUMP ( addr n --- ) BASE @ >R HEX CR CR 5 SPACES 16 0 DO I 3 .R LOOP 2 SPACES 16 0 DO I 0 <# # #> TYPE LOOP CR OVER + SWAP DUP 15 AND XOR DO CR I 0 4 D.R SPACE I 16 + I 2DUP DO I C@ SPACE 0 <# # # #> TYPE LOOP 2 SPACES DO I C@ DUP 32 < OVER 126 > OR IF DROP 46 THEN EMIT LOOP 16 +LOOP CR R> BASE ! ; ;S ( Memory dump, byte format, intersegment 02/26/82 ) FORTH DEFINITIONS DECIMAL : DUMP ( segment offset length --- ) DEPTH 3 < 1 ?ERROR BASE @ >R HEX CR CR 10 SPACES 16 0 DO I 3 .R LOOP 2 SPACES 16 0 DO I 0 <# # #> TYPE LOOP CR OVER + SWAP DUP 15 AND XOR DO CR DUP 0 <# # # # # #> TYPE 58 EMIT ( segment ) I 0 <# # # # # #> TYPE SPACE ( offset ) I 16 + I DO DUP I C@L 0 <# # # #> SPACE TYPE LOOP 2 SPACES I 16 + I DO DUP I C@L DUP 32 < OVER 126 > OR IF DROP 46 THEN EMIT LOOP 16 +LOOP DROP CR R> BASE ! ; ;S ( Memory dump, word format, intrasegment 02/26/82 ) FORTH DEFINITIONS DECIMAL : DUMP ( addr n --- ) BASE @ >R HEX CR CR 7 SPACES 16 0 DO I 1+ . I . SPACE 2 +LOOP 16 0 DO I 0 <# # #> TYPE LOOP CR OVER + SWAP DUP 15 AND XOR DO CR I 0 4 D.R SPACE I 16 + I 2DUP DO I @ SPACE 0 <# # # # # #> TYPE 2 +LOOP 2 SPACES DO I C@ DUP 32 < OVER 126 > OR IF DROP 46 THEN EMIT LOOP 16 +LOOP CR R> BASE ! ; ;S ( Memory dump, word format, intersegment 02/26/82 ) FORTH DEFINITIONS DECIMAL : DUMP ( segment offset length --- ) DEPTH 3 < 1 ?ERROR BASE @ >R HEX CR CR 12 SPACES 16 0 DO I 1+ . I . SPACE 2 +LOOP 16 0 DO I 0 <# # #> TYPE LOOP CR OVER + SWAP DUP 15 AND XOR DO CR DUP 0 <# # # # # #> TYPE 58 EMIT ( segment ) I 0 <# # # # # #> TYPE SPACE ( offset ) I 16 + I DO DUP I @L SPACE 0 <# # # # # #> TYPE 2 +LOOP 2 SPACES I 16 + I DO DUP I @L 255 AND DUP 32 < OVER 126 > OR IF DROP 46 THEN EMIT LOOP 16 +LOOP DROP CR R> BASE ! ; ;S ( ANSI Cursor Control Functions 02/06/84 ) FORTH DEFINITIONS DECIMAL 27 CONSTANT Esc ( --- ) : CLEARSCREEN Esc EMIT ASCII [ EMIT ASCII 2 EMIT ASCII J EMIT ; ( x y --- ) : GOTOXY Esc EMIT ASCII [ EMIT 1+ . ASCII ; EMIT 1+ . ASCII H EMIT ; ( --- ) : CLREOL Esc EMIT ASCII [ EMIT ASCII K EMIT ; ;S ( Random number generator, by J E Rickenbacker 08/23/82 ) FORTH DEFINITIONS DECIMAL VARIABLE SEED : (RAND) SEED @ 259 * 3 + 32767 AND DUP SEED ! ; : RANDOM (RAND) 32767 */ ; ( Mini Screen Editor 11/14/83 ) CR CR .( Wait ... loading mini screen editor) CR CR FORTH DEFINITIONS HEX : TASK ; VARIABLE CUR 1B CONSTANT EXITFLAG 47 CONSTANT HOMEKEY 0D CONSTANT NEWLINE 09 CONSTANT HORIZTAB 50 CONSTANT DOWNARROW 48 CONSTANT UPARROW 4D CONSTANT RIGHTARROW 4B CONSTANT LEFTARROW 49 CONSTANT PGUP 51 CONSTANT PGDN 43 CONSTANT F9 44 CONSTANT F10 : .CUR CUR @ 40 /MOD 1 + SWAP 4 + SWAP GOTOXY ; : !CUR 0 MAX 3FF MIN CUR ! ; : +CUR CUR @ + !CUR ; : +.CUR +CUR .CUR ; : +LIN CUR @ 40 / + 40 * !CUR ; : HOM 0 CUR ! .CUR ; : !BLK SCR @ BLOCK CUR @ + C! UPDATE 1 +.CUR ; --> ( Mini Screen Editor, continued 11/14/83 ) : S.ERASE CLEARSCREEN SCR @ BLOCK 400 BLANK UPDATE SCR @ LIST HOM .CUR ; : CLHC CLEARSCREEN LIST HOM .CUR ; : FXNKEY CASE F9 OF S.ERASE ENDOF F10 OF EMPTY-BUFFERS SCR @ LIST HOM ENDOF DOWNARROW OF 40 +.CUR ENDOF LEFTARROW OF -1 +.CUR ENDOF UPARROW OF -40 +.CUR ENDOF RIGHTARROW OF 1 +.CUR ENDOF PGUP OF SCR @ 1- CLHC ENDOF PGDN OF SCR @ 1+ CLHC ENDOF HOMEKEY OF HOM .CUR ENDOF 7 EMIT ENDCASE ; : CONTROL BL WORD 1+ C@ 1F AND STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE --> ( Mini Screen Editor, continued 11/14/83 ) : EDIT DEPTH 1 < 1 ?ERROR LIST HOM BEGIN PCKEY CASE 0 OF FXNKEY ENDOF EXITFLAG OF 0 13 GOTOXY FLUSH QUIT ENDOF CONTROL X OF 40 +.CUR ENDOF 08 OF -1 +.CUR 20 DUP EMIT !BLK -1 +.CUR ENDOF CONTROL S OF -1 +.CUR ENDOF NEWLINE OF 1 +LIN .CUR ENDOF CONTROL E OF -40 +.CUR ENDOF CONTROL D OF 1 +.CUR ENDOF HORIZTAB OF CUR @ 8 / 8 * 8 + !CUR .CUR ENDOF DUP 20 < IF 7 EMIT ELSE DUP DUP EMIT !BLK THEN ENDCASE AGAIN ; DECIMAL CR .( Compilation of mini screen editor complete.) CR ;S ( Stack Utilities by Gerry Mueller 10/17/82 ) FORTH DEFINITIONS DECIMAL : .CS .STACK S0 @ SP! ; ( display and clear stack) : PSWAP ( nx ny --- interchange pair of stack numbers ) 2DUP >R >R >R >R SP@ 2- DUP 2DUP R> 2* + @ SWAP R> 2* + @ ROT R> 2* + ! SWAP R> 2* + ! ; VARIABLE PFLAG : PERK ( sort stack, lowest number on top ) BEGIN 0 PFLAG ! DEPTH 0 DO SP@ I 2* + @ SP@ I 2* 4 + + @ > DUP PFLAG @ + PFLAG ! IF I 1+ I 2+ PSWAP THEN LOOP PFLAG @ 0= UNTIL ; ;S ( Eratosthenes sieve benchmark program ) FORTH DEFINITIONS DECIMAL 8190 CONSTANT SIZE VARIABLE FLAGS SIZE ALLOT : DO-PRIME FLAGS SIZE 1 FILL 0 SIZE 0 DO FLAGS I + C@ IF I DUP + 3 + DUP I + BEGIN DUP SIZE < WHILE 0 OVER FLAGS + C! OVER + REPEAT DROP DROP 1+ THEN LOOP . ." Primes" ; ( Interface Age benchmark program ) ( See FORTH DIMENSIONS, Vol. II No. 4 page 112 ) : BENCH DUP 2 / 1+ SWAP CLEARSCREEN ." Starting " CR 0 0 !TIME 1 DO DUP I 1 ROT 2 DO DROP DUP I /MOD DUP 0= IF DROP DROP 1 LEAVE ELSE 1 = IF DROP 1 ELSE DUP 0 > IF DROP 1 ELSE 0= IF 0 LEAVE THEN THEN THEN THEN LOOP IF 4 .R ELSE DROP THEN LOOP DROP 7 EMIT CR .T ." Finished. " ; ( Input number from console and leave on stack ) FORTH DEFINITIONS DECIMAL : #IN ( --- n ) 0 BEGIN KEY DUP 13 = IF DROP EXIT THEN DUP 8 = IF EMIT 32 EMIT 8 EMIT 10 / ELSE DUP 48 < OVER 57 > OR IF DROP 7 EMIT ELSE DUP EMIT 48 - SWAP 10 * + THEN THEN AGAIN ; ;S ( Console string input ) ( first-byte-address max-length --- char-count ) : IN$ OVER >R ( save copy of fba ) 2DUP BLANK 0 ( clear input area ) DO KEY DUP 32 < ( loop on max char count ) IF DROP LEAVE ( if control code all done ) ELSE DUP EMIT ( else echo it ) OVER C! 1+ ( store into buffer ) THEN LOOP ( loop until buffer full ) R> - ; ( calculate length of input ) ( FORTH Decompiler, by Ray Duncan 11/01/83 ) CR .( Wait ... loading Decompiler ) CR FORTH DEFINITIONS DECIMAL : TASK ; VARIABLE QUIT.FLAG VARIABLE WORD.PTR VARIABLE NFA.PTR : N. DUP DECIMAL . SPACE HEX 0 ." (" D. ." h) " DECIMAL ; : TAB-OR-RETURN OUT @ IF OUT @ 39 > IF CR ELSE OUT @ 20 / 1+ 20 * OUT @ - SPACES THEN THEN ; --> ( FORTH Decompiler, continued 11/01/83 ) ( find addresses of all special runtime routines ) ' (LOOP) CONSTANT LOOP.ADR ' LIT CONSTANT LIT.ADR ' BLIT CONSTANT BLIT.ADR ' DLIT CONSTANT DLIT.ADR ' : @ CONSTANT DOCOL.ADR ' 0BRANCH CONSTANT 0BRANCH.ADR ' BRANCH CONSTANT BRANCH.ADR ' (+LOOP) CONSTANT PLOOP.ADR ' (.") CONSTANT PDOTQ.ADR ' (ABORT") CONSTANT PABORTQ.ADR ' (LIT") CONSTANT PLITQ.ADR --> ( FORTH Decompiler, continued 11/01/83 ) ( find addresses of all special runtime routines ) ' (DO) CONSTANT DO.ADR ' (?DO) CONSTANT ?DO.ADR ' C/L @ CONSTANT CONST.ADR ' BASE @ CONSTANT USERV.ADR ' USE @ CONSTANT VAR.ADR ' (;CODE) CONSTANT PSCODE.ADR --> ( FORTH Decompiler, continued 11/01/83 ) : PDOTQ.DSP WORD.PTR @ 2+ DUP >R DUP C@ + 1- WORD.PTR ! R> COUNT TYPE ; : WORD.DSP >NAME DUP 1+ C@ 59 = IF 1 QUIT.FLAG ! THEN .NAME ; : BRANCH.DSP WORD.PTR @ 2+ DUP WORD.PTR ! DUP @ + HEX U. DECIMAL ; : USERV.DSP ." User variable, current value = " WORD.PTR @ 2+ C@ 8 ORIGIN+ @ + @ N. 1 QUIT.FLAG ! ; : VAR.DSP ." Variable, current value = " WORD.PTR @ 2+ @ N. 1 QUIT.FLAG ! ; : CONST.DSP ." Constant, value = " WORD.PTR @ 2+ @ N. 1 QUIT.FLAG ! ; --> ( FORTH Decompiler, continued 11/01/83 ) : DIS BL WORD FIND 0= IF DROP 3 SPACES ." ? not in glossary " CR QUIT THEN ( CFA ) DUP 2+ OVER @ = IF 3 SPACES ." <primitive>" CR DROP QUIT THEN 0 QUIT.FLAG ! DUP WORD.PTR ! >NAME NFA.PTR ! 2 SPACES BEGIN WORD.PTR @ DUP HEX U. SPACE DECIMAL @ CASE DOCOL.ADR OF CLEARSCREEN NFA.PTR @ REVERSE SPACE .NAME REVERSE-OFF ." contains: " CR ENDOF 0BRANCH.ADR OF ." Jz " BRANCH.DSP ENDOF BRANCH.ADR OF ." Jmp " BRANCH.DSP ENDOF LOOP.ADR OF ." Loop " BRANCH.DSP ENDOF PLOOP.ADR OF ." +Loop " BRANCH.DSP ENDOF --> ( FORTH Decompiler, continued 11/01/83 ) LIT.ADR OF WORD.PTR @ 2+ DUP WORD.PTR ! @ N. ENDOF BLIT.ADR OF WORD.PTR @ DUP 1+ WORD.PTR ! 2+ C@ N. ENDOF DLIT.ADR OF WORD.PTR @ 2+ DUP 2+ WORD.PTR ! 2@ SWAP D. ENDOF PDOTQ.ADR OF ." Print: " PDOTQ.DSP ENDOF PABORTQ.ADR OF ." Abort: " PDOTQ.DSP ENDOF PLITQ.ADR OF ." String: " PDOTQ.DSP ENDOF USERV.ADR OF USERV.DSP ENDOF VAR.ADR OF VAR.DSP ENDOF CONST.ADR OF CONST.DSP ENDOF PSCODE.ADR OF WORD.PTR @ @ WORD.DSP 1 QUIT.FLAG ! ENDOF DO.ADR OF WORD.PTR @ @ WORD.DSP 2 WORD.PTR +! ENDOF ?DO.ADR OF WORD.PTR @ @ WORD.DSP 2 WORD.PTR +! ENDOF --> ( FORTH Decompiler, continued 02/06/84 ) ( default case ) DUP WORD.DSP ENDCASE TAB-OR-RETURN 2 WORD.PTR +! QUIT.FLAG @ ?TERMINAL OR UNTIL CR ; CR CR .( Decompiler loaded. ) SP@ DP @ - U. .( bytes left.) CR .( To decompile word xxx type: DIS xxx <return> ) CR ( Memory allocation map 11/06/83 ) FORTH DEFINITIONS HEX : H. 0 4 D.R ." H" ; : MAP HEX CR CR ." Address of NEXT = " NEXT-LINK H. CR ." Top of dictionary = " DP @ H. CR ." Available room in dictionary = " SP@ DP @ - DECIMAL U. ." bytes" HEX CR ." Base of data stack = " S0 @ H. CR ." Start of terminal input buffer = " TIB H. DECIMAL CR ." Size of terminal buffer = " C/L . ." bytes" HEX CR ." Base of return stack = " R0 @ H. DECIMAL CR ." Size of return stack = " R0 @ TIB 50 + - . ." bytes" HEX --> ( Memory allocation, continued ) CR ." Start of user variables = " R0 @ H. CR ." Start of disk buffer area = " FIRST H. CR ." End of disk buffer area = " LIMIT H. DECIMAL CR ." Disk buffers available = " #BUFF . CR ." Disk buffer size = " B/BUF . ." bytes" CR CR ; DECIMAL ;S ( window support 11/06/83 ) FORTH DEFINITIONS HEX ( create wpb compilation: xul yul xlr ylr --- ) ( execution: --- wpb-addr ) : WINDOW CREATE 100 * + , 100 * + , 700 , DOES> ; ( fetch parameters for VIDEO-IO call: wpb --- dx cx bx ) : WPAR@ DUP @ SWAP 2+ DUP @ SWAP 2+ @ ; ( change initializing attribute: attrib wpb --- ) : W-ATTRIB SWAP 100 * SWAP 4 + ! ; ( execute window function: dx cx bx ax --- ) : W-EXEC video-io 2DROP 2DROP ; --> ( window support, continued 07/12/82 ) ( initialize window: wpb --- ) : W-CLEAR WPAR@ 0600 W-EXEC ; ( scroll window up: wpb --- ) : W-UP WPAR@ 0601 W-EXEC ; ( scroll window down: wpb --- ) : W-DOWN WPAR@ 0701 W-EXEC ; ( cursor addressing within window: x y wpb --- ) : W-GOTOXY 2+ @ DUP 0FF AND SWAP 100 / D+ GOTOXY ; ( move cursor to window home position: wpb --- ) : W-HOME 2+ @ DUP 0FF AND SWAP 100 / GOTOXY ; --> ( window support, continued 11/06/83 ) ( move cursor to window lower left corner: wpb --- ) : W-LLC DUP 2+ @ 0FF AND SWAP @ 100 / GOTOXY ; ( draw border around window: wpb --- ) : W-BORDER DUP >R 2+ @ DUP 0FF AND SWAP 0 100 UM/MOD SWAP DROP R> @ DUP 0FF AND SWAP 0 100 UM/MOD SWAP DROP ( top ) 1 PICK 1+ 4 PICK DO I 3 PICK 1- GOTOXY C4 EMIT LOOP ( bottom) 1 PICK 1+ 4 PICK DO I 1 PICK 1+ GOTOXY C4 EMIT LOOP ( right ) DUP 1+ 3 PICK DO 1 PICK 1+ I GOTOXY B3 EMIT LOOP ( left ) DUP 1+ 3 PICK DO 3 PICK 1- I GOTOXY B3 EMIT LOOP ( ur ) 1 PICK 1+ 3 PICK 1- GOTOXY 0BF EMIT ( ll ) 3 PICK 1- 1 PICK 1+ GOTOXY 0C0 EMIT ( lr ) 1+ SWAP 1+ SWAP GOTOXY 0D9 EMIT ( ul ) 1- SWAP 1- SWAP GOTOXY DA EMIT ; DECIMAL ( window examples 07/12/82 ) 5 5 30 10 WINDOW W1 40 7 70 15 WINDOW W2 10 21 70 23 WINDOW W3 : DEMO CLEARSCREEN W1 W-BORDER W2 W-BORDER W3 W-BORDER W1 W-CLEAR W2 W-CLEAR W3 W-CLEAR W3 W-HOME ." We will scroll the left window up" 0 1 W3 W-GOTOXY ." and the right window down" 100 0 DO W1 W-UP W1 W-LLC ." Line # " I . W2 W-DOWN W2 W-HOME ." Line # " I . LOOP W3 W-CLEAR W3 W-HOME ." Demonstration is finished." 0 0 GOTOXY ; ( Multitasking demo 12/01/82 ) ( type: DECIMAL 37 LOAD START CLOCK ) FORTH DEFINITIONS HEX : CLOCK @TIME SWAP DROP 0FF AND 0A < IF 3D 0 GOTOXY .DATE SPACE @TIME 0 100 UM/MOD SWAP DROP 0 <# # # 3A HOLD 2DROP 0 100 UM/MOD SWAP 0 # # 3A HOLD 2DROP 0 # # #> TYPE THEN ; DECIMAL ;S ( Interrupt handler compiling word 11/06/83 ) ( int_number ON-INT name --- ) : ON-INT ' ( get CFA of handler) SWAP 4 * >R ( calc vector addr ) ?cs: 0 R@ 2+ !L ( store segment ) HERE 0 R> !L ( store offset ) ASSEMBLER ( now compile machine) BP PUSH SI PUSH ( language handler ) BX PUSH BX, # ( dummy) MOV [BX] JMP FORTH ; ( simulate EXECUTE) BUILD INT-RETURN ASSEMBLER BX POP SI POP BP POP IRET FORTH ( demo for interrupt handler 07/12/83 ) DECIMAL ( this is the high level FORTH interrupt ( handler for interrupt level 240. ) : INT-MESSAGE CR CR BLINK .T ." Interrupt received! " 7 EMIT BLINK-OFF CR CR INT-RETURN ; 240 ON-INT INT-MESSAGE ( this code tests the low and high level handlers by ) ( forcing a software interrupt ) CODE PERFORM-INT 240 INT NEXT, END-CODE : INTERRUPT-TESTER CLEARSCREEN ." Now executing interrupt at " .T PERFORM-INT ." Now back from interrupt" CR CR ;
