Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP Posting-Version: version B 2.10 5/3/83; site aplvax.UUCP Path: utzoo!watmath!clyde!burl!hou3c!hocda!houxm!houxz!vax135!floyd!cmcl2!seismo!rlgvax!cal-unix!umcp-cs!aplvax!lwt1 From: lwt1@aplvax Newsgroups: net.sources Subject: UNIX FORTH for the PDP11 (part 6 of 7) Message-ID: <647@aplvax.UUCP> Date: Fri, 8-Jun-84 15:57:01 EDT Article-I.D.: aplvax.647 Posted: Fri Jun 8 15:57:01 1984 Date-Received: Sun, 10-Jun-84 00:13:42 EDT Organization: JHU/Applied Physics Lab, Laurel, MD Lines: 759 Here is part 6 of the source for FORTH for the PDP-11. Delete everything thru the "-- cut here --" line, and extract with 'sh': sh part1 part2 ... part7 where 'part?' are whatever you've named the files. Note the copyright notice at the end of README. Please let us know how things go. While we can't support this software, we'll be posting bug fixes/upgrades to net.sources as time permits. VAX-FORTH should be 'forth'-coming {yuk-yuk} within a couple of weeks. Have fun! -Lloyd W. Taylor ... seismo!umcp-cs!aplvax!lwt1 ---I will have had been there before, soon--- ---------------------------------- cut here ---------------------------------- echo x - auto cat >auto <<'+E+O+F' ( automated meta-compilation file ) " META1" FLOAD " METAASM" FLOAD " newforth" -1 CREAT CLOSE " newforth" 2 OPEN DUP . FORTH FILED ! ( object file ) 0 WRN ! HOST 0 RAM HEADS METAMAP METAWARN " SYS:ASM" FLOAD " META2" FLOAD " SYS:SRC" FLOAD DECIMAL 20000 CLEANUP ( allot 20000 byte dictionary ) +E+O+F echo x - SYS:ASM cat >SYS:ASM <<'+E+O+F' ( Copyright 1984 by The Johns Hopkins University/Applied Physics Lab. ) ( Free non-commercial distribution is *encouraged*, provided that: ) ( ) ( 1. This copyright notice is included in any distribution, and ) ( 2. You let us know that you're using it. ) ( ) ( Please notify: ) ( ) ( Lloyd W. Taylor ) ( JHU/Applied Physics Lab ) ( Johns Hopkins Road ) ( Laurel, MD 20707 ) ( [301] 953-5000 ) ( ) ( Usenet: ... seismo!umcp-cs!aplvax!lwt1 ) ( ) ( ) ( Unix-FORTH was developed under NASA contract NAS5-27000 for the ) ( Hopkins Ultraviolet Telescope, a March 1986 Space Shuttle mission. ) ( {We hope to take a peek at Halley's comet!} ) ( ) ( Written entirely by Wizard-In-Residence John R. Hayes. ) ( ) ( * Unix is a trademark of Bell Labs. ) ( FORTH ASSEMBLY LANGUAGE SOUCE CODE ) OCTAL ( THIS IS SOURCE CODE TO BE RUN THROUGH THE METACOMPILER - METAASSEMBLER. ) ( THEREFORE, THERE ARE DIFFERENCES BETWEEN THIS SOURCE CODE AND SOURCE ) ( CODE TO BE ASSEMBLED IN THE ORDINARY WAY. IN PARTICULAR, THERE IS NO ) ( IMPLICIT OR EXPLICIT SMUDGING. ) JMP 0 *$ ( JUMP TO STARTUP; WILL BE BACKPATCHED ) LABEL vector MOV 0 $ IAR REG ( MOVE ABORT TO IAR; WILL BE BACKPATCHED ) 60 TRAP 2 , vector , NEXT ( VARIABLES AND DATA BUFFERS ) LABEL rsp0 0 , ( INITIAL VALUE OF RETURN STACK POINTER ) LABEL in 0 , ( >IN: INPUT PARSER ) LABEL initvocab 0 , ( INITIAL FORTH VOCABULARY ) LABEL dp 0 , ( END OF DICTIONARY POINTER ) 400 RAMALLOT ( 256 BYTE PARAMETER STACK ) LABEL inbuf DECIMAL 120 RAMALLOT ( 120 BYTES OF INPUT BUFFER ) OCTAL ( INNER INTERPRETER AND LOW-LEVEL RUN TIME WORDS ) CODE (:) ( CODE FOR NEXT ) JMP IAR *)+ ( THE CODE FOR CALL IS COMPILED IN-LINE FOR COLON DEFINITIONS. ) ( ) ( JSR IAR,*$NEXT ( ) CODE (;) MOV SP )+ IAR REG NEXT ( THIS IS TRICKY CODE. ALL WORDS DEFINED BY VARIABLE, CONSTANT, OR ) (WORDS WILL HAVE SIMILAR CODE FIELDS. THEREFORE, THE ) ( CODE FOR [VARIABLE], [CONSTANT], AND [DOES>] IS SHOW BELOW. ) ( EXAMPLE: CODE COMPILED FOR VARIABLE WILL BE: ) ( JSR IAR,*$[VARIABLE] ) CODE (VARIABLE) MOV IAR REG PSP -( MOV SP )+ IAR REG NEXT CODE (CONSTANT) MOV IAR ) PSP -( MOV SP )+ IAR REG NEXT CODE (DOES>) MOV IAR )+ 0 REG MOV IAR REG PSP -( MOV 0 REG IAR REG NEXT ( BRANCHING PRIMITIVES ) CODE (LITERAL) MOV IAR )+ PSP -( NEXT CODE BRANCH MOV IAR ) IAR REG NEXT CODE ?BRANCH MOV PSP )+ 0 REG BNE 1 FWD MOV IAR ) IAR REG JMP IAR *)+ ( NEXT ) 1 L: ADD 2 $ IAR REG NEXT CODE EXECUTE JMP PSP *)+ ( FORTH-83 DO LOOPS ) CODE (DO) MOV PSP )+ 1 REG MOV PSP )+ 0 REG ADD 100000 $ 0 REG ( LIMIT' := LIMIT + 8000 ) MOV 0 REG SP -( SUB 0 REG 1 REG ( IINIT' := INIT - LIMIT' ) MOV 1 REG SP -( NEXT CODE (LOOP) INC SP ) BVS 1 FWD MOV IAR ) IAR REG ( LOOP BACK ) JMP IAR *)+ ( NEXT ) 1 L: ADD 4 $ SP REG ( POP RETURN STACK ) ADD 2 $ IAR REG ( SKIP LOOP ADDRESS ) NEXT CODE (+LOOP) ADD PSP )+ SP ) BVS 1 FWD MOV IAR ) IAR REG ( LOOP BACK ) JMP IAR *)+ ( NEXT ) 1 L: ADD 4 $ SP REG ( POP RETURN STACK ) ADD 2 $ IAR REG ( SKIP LOOP ADDRESS ) NEXT CODE I MOV SP ) 0 REG ADD 2 SP X( 0 REG ( I := I' + LIMIT' ) MOV 0 REG PSP -( NEXT CODE J MOV 4 SP X( 0 REG ADD 6 SP X( 0 REG ( J := J' + LIMIT' ) MOV 0 REG PSP -( NEXT CODE (LEAVE) ADD 4 $ SP REG ( POP RETURN STACK ) MOV IAR ) IAR REG ( BRANCH PAST LOOP ) NEXT ( BASIC UNIX SYSTEM INTERFACE ROUTINES ) ( BUFFER FOR HOLDING INDIRECT SYSTEM CALLS ) LABEL SYSBUF 0 , ( TRAP INSTRUCTION ) 0 , ( ARGUMENT 1 ) 0 , ( ARGUMENT 2 ) 0 , ( ARGUMENT 3 ) ( DATA AND CODE FOR SPAWNING OFF SUBPROCESSES ) HEX LABEL STATUS 0 , ( WORD FOR RECEIVING RETURN STATUS OF CHILD ) LABEL NAME 622F , 6E69 , 732F , 68 , ( "/bin/sh" ) LABEL 0ARG 6873 , 0 , ( "sh" ) LABEL 1ARG 632D , 0 , ( "-c" ) LABEL ARGV 0ARG , 1ARG , 0 , 0 , ( ARGUMENT LIST ) OCTAL CODE SHELL ( --- ) ( SPAWN OFF INTERACTIVE SUB-SHELL ) CLR ARGV 2+ *$ ( sh WITH NO ARGUMENTS ) 0 L: ( SPAWN SUB-PROCESS. SYSTEM BELOW SHARES THIS CODE ) 2 TRAP ( FORK SYSTEM CALL ) BR 2 FWD ( BRANCH TO CHILD PROCESS CODE ) 60 TRAP 2 , 1 , ( IGNORE INTERRUPTS ) MOV 0 REG 2 REG ( SAVE OLD VECTOR ) 7 TRAP ( WAIT SYSTEM CALL ) ROR 2 REG BCS 1 FWD ( SKIP IF INTERRUPTS WERE IGNORED ) 60 TRAP 2 , vector , ( ELSE, CATCH INTERRUPTS ) 1 L: NEXT ( DONE ) 2 L: ( CHILD ) ( CHILD PROCESS CODE ) MOV 104473 $ SYSBUF *$ ( EXECE TRAP INSTRUCTION ) MOV NAME $ SYSBUF 2+ *$ ( MOVE NAME POINTER ) MOV ARGV $ SYSBUF 4 + *$ ( MOVE ARGUMENT POINTER ) MOV rsp0 *$ SYSBUF 6 + *$ ( MOVE ENVIRONMENT POINTER ) 0 TRAP SYSBUF , ( INDIRECT EXECE SYSTEM CALL ) 1 TRAP ( RETURN TO PARENT ) CODE SYSTEM ( ADDR[STRING] --- ) MOV 1ARG $ ARGV 2+ *$ ( MOVE POINTER TO "-c" TO ARGUMENT LIST ) MOV PSP )+ ARGV 4 + *$ ( MOVE POINTER TO COMMAND STRING TO LIST ) BR 0 BACK ( BRANCH TO CODE TO SPAWN SUB-SHELL ) ( I/O BUFFER AND CONTROL VARIABLES LABEL BLOCK 1000 RAMALLOT ( 512 BYTE DISK BUFFER ) LABEL SIZE 0 , ( SIZE IN BYTES ) LABEL INDEX 0 , ( CURRENT OFFSET INTO BLOCK ) LABEL FILED 0 , ( FILE DESCRIPTOR OF FILE THAT OWNS BLOCK ) ( FILE POSITION TABLE: EACH SLOT HAS A 32 BIT FILE OFFSET. FILE ) ( DESCRIPTOR IS OFFSET INTO TABLE. THERE ARE 15 SLOTS. ) LABEL FILEPOS 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ( SUBROUTINE GETC: HANDLES ALL INPUT AND DOES BUFFERING ) ( INPUT: FILE DESCRIPTOR IN R0 ) ( OUTPUT: CHARACTER OF EOF IN R0 ) ( SIDE EFFECTS: R0 AND R1 DESTROYED ) LABEL GETC CMP 0 REG FILED *$ ( IS THIS FILE CURRENTLY BUFFERED? ) BEQ 0 FWD ( IS SO, DO NOT NEED TO TO SEEK ) MOV 0 REG FILED *$ ( SAVE NEW FD IN BUFFER DESCRIPTOR ) MOV SIZE *$ INDEX *$ ( INDICATE THAT BUFFER IS EMPTY ) MOV 104423 $ SYSBUF *$ ( MOVE LSEEK TRAP INSTRUCTION TO SYSBUF ) ASL 0 REG ASL 0 REG ( MULTIPLY BY 4 TO INDEX INTO POSITION TABLE ) MOV FILEPOS 0 X( SYSBUF 2+ *$ ( HIGH OFFSET WORD ) MOV FILEPOS 2+ 0 X( SYSBUF 4 + *$ ( LOW OFFSET WORD ) CLR SYSBUF 6 + *$ ( OFFSET FROM BEGINNING OF FILE ) MOV FILED *$ 0 REG ( FILE DESCRIPTOR IN R0 ) 0 TRAP SYSBUF , ( LSEEK SYSTEM CALL ) MOV FILED *$ 0 REG ( RESTORE FD SINCE CALL DESTROYED R0, R1 ) 0 L: MOV 2 REG SP -( ( SAVE R2 ) MOV INDEX *$ 2 REG ( R2 IS INDEX ) CMP 2 REG SIZE *$ BLT 1 FWD ( IF THERE IS STILL DATA IN BUFFER, USE IT ) 3 TRAP BLOCK , 1000 , ( READ UP TO 512 BYTES ) BCS 2 FWD ( BRANCH IF ERROR ) MOV 0 REG SIZE *$ ( SAVE SIZE OF BLOCK ) BEQ 3 FWD ( BRANCH IF EOF ) CLR 2 REG ( RESET INDEX ) 1 L: MOV BLOCK 2 X( 0 REG BYTE ( GET NEXT CHARACTER ) BIC 17400 $ 0 REG ( MASK OFF HIGH BYTE ) INC 2 REG MOV 2 REG INDEX *$ ( UPDATE INDEX ) MOV FILED *$ 2 REG ( REUSE R2 TO HOLD FILE DESCRIPTOR ) ASL 2 REG ASL 2 REG ( MULTIPLY BY 4 TO INDEX INTO POSITION TABLE ) ADD 1 $ FILEPOS 2+ 2 X( ( ADD ONE TO CURRENT FILE POSITION ) ADC FILEPOS 2 X( BR 4 FWD 2 L: 3 L: MOV -1 $ 0 REG ( RETURN EOF ON ERROR ) 4 L: MOV SP )+ 2 REG ( RESTORE R2 ) RTS PC REG-ONLY CODE OPEN ( ADDR[STRING] MODE --- FD ) MOV 104405 $ SYSBUF *$ ( MOVE TRAP 5 INSTRUCTION TO INDIR AREA ) MOV PSP )+ SYSBUF 4 + *$ ( MOVE MODE ) MOV PSP ) SYSBUF 2+ *$ ( MOVE ADDR[STRING] ) 0 TRAP SYSBUF , ( OPEN SYSTEM CALL ) BCC 1 FWD MOV -1 $ PSP ) ( ERROR, NEGATIVE FILE DESCRIPTOR RETURNED ) BR 2 FWD 1 L: MOV 0 REG PSP ) ( RETURN FILE DESCRIPTOR ) ASL 0 REG ASL 0 REG ( MULTIPLY BY 4 IN INDEX INTO POSITION TABLE ) CLR FILEPOS 0 X( ( INITIALIZE FILE POSITION TO ZERO ) CLR FILEPOS 2+ 0 X( 2 L: NEXT CODE CREAT ( ADDR[STRING] PMODE --- FD ) MOV 104410 $ SYSBUF *$ ( MOVE TRAP 8 INSTRUCTION TO INDIR AREA ) MOV PSP )+ SYSBUF 4 + *$ ( MOVE PMODE ) MOV PSP ) SYSBUF 2+ *$ ( MOVE ADDRESS OF FILE NAME ) 0 TRAP SYSBUF , ( CREAT SYSTEM CALL ) BCC 1 FWD MOV -1 $ PSP ) ( ERROR, NEGATIVE FILE DESCRIPTOR RETURNED ) BR 2 FWD 1 L: MOV 0 REG PSP ) ( RETURN FILE DESCRIPTOR ) ASL 0 REG ASL 0 REG ( MULTIPLY BY 4 TO INDEX INTO POSITION TABLE ) CLR FILEPOS 0 X( ( INITIALIZE FILE POSITION TO ZERO ) CLR FILEPOS 2+ 0 X( 2 L: NEXT CODE CLOSE ( FD --- ) MOV 104406 $ SYSBUF *$ ( MOVE TRAP 6 INSTRUCTION TO INDIR AREA ) MOV PSP )+ 0 REG ( FILE DESCRIPTOR ) 0 TRAP SYSBUF , ( CLOSE SYSTEM CALL ) NEXT CODE FEXPECT ( FD ADDR COUNT --- ACTCOUNT ) MOV 2 PSP X( 2 REG ( BUFFER ADDRESS ) MOV PSP )+ 3 REG ( COUNT ) BEQ 3 FWD ( DO NOTHING IF COUNT IS ZERO ) 1 L: MOV 2 PSP X( 0 REG ( FILE DESCRIPTOR ) JSR PC REG-ONLY GETC *$ ( GET NEXT CHARACTER ) CMP 0 REG -1 $ ( EOF? ) BEQ 4 FWD ( LEAVE LOOP ON EOF ) CMP 0 REG 011 $ BYTE ( TAB ? ) BNE 2 FWD MOV 040 $ 0 REG BYTE ( CHANGE TABS TO BLANKS ) 2 L: MOV 0 REG 2 )+ BYTE ( SAVE CHARACTER ) CMP 0 REG 012 $ BYTE ( NEWLINE? ) BEQ 5 FWD 1 3 SOB ( DECREMENT COUNT AND CONTINUE IF NON-ZERO ) 3 L: 4 L: 5 L: SUB PSP )+ 2 REG ( COMPUTE ACTUAL NUMBER OF CHARACTERS READ ) MOV 2 REG PSP ) ( RETURN ACTUAL NUMBER ) NEXT CODE READ ( FD ADDR COUNT --- ACTCOUNT ) MOV 2 PSP X( 2 REG ( BUFFER ADDRESS ) MOV PSP )+ 3 REG ( COUNT ) BEQ 2 FWD ( DO NOTHING IF COUNT IS ZERO ) 1 L: MOV 2 PSP X( 0 REG ( FILE DESCRIPTOR ) JSR PC REG-ONLY GETC *$ ( GET NEXT CHARACTER ) CMP 0 REG -1 $ ( EOF? ) BEQ 3 FWD ( LEAVE LOOP ON EOF ) MOV 0 REG 2 )+ BYTE ( SAVE CHARACTER ) 1 3 SOB ( DECREMENT COUNT AND CONTINUE IF NON-ZERO ) 2 L: 3 L: SUB PSP )+ 2 REG ( COMPUTE ACTUAL NUMBER OF CHARACTERS READ ) MOV 2 REG PSP ) ( RETURN ACTUAL NUMBER ) NEXT CODE WRITE ( ADDR COUNT FD --- ACTCOUNT ) MOV 104404 $ SYSBUF *$ ( MOVE TRAP INSTRUCTION TO INDIR AREA ) MOV PSP )+ 0 REG ( FILE DESCRIPTOR ) MOV PSP )+ SYSBUF 4 + *$ ( COUNT ) MOV PSP ) SYSBUF 2+ *$ ( ADDRESS ) 0 TRAP SYSBUF , ( WRITE SYSTEM CALL ) BCC 1 FWD MOV -1 $ 0 REG ( ERROR FLAG ) 1 L: MOV 0 REG PSP ) ( RETURN ACTUAL COUNT ) NEXT CODE SEEK ( FD OFFSETL OFFSETH --- ) MOV 4 PSP X( 0 REG ( FILE DESCRIPTOR ) CMP 0 REG FILED *$ ( IF SEEK ON CURRENTLY BUFFERED FILE ) BNE 1 FWD MOV -1 $ FILED *$ ( FLAG BUFFER AS INVALID ) 1 L: ASL 0 REG ASL 0 REG ( MULTIPLY BY 4 TO INDEX INTO POSITION TABLE ) MOV PSP ) FILEPOS 0 X( ( HIGH OFFSET INTO FILE POSITION TABLE ) MOV 2 PSP X( FILEPOS 2+ 0 X( ( LOW OFFSET INTO FILE POSITION TABLE ) MOV 104423 $ SYSBUF *$ ( MOVE SEEK TRAP INSTRUCTION TO SYSBUF ) MOV PSP )+ SYSBUF 2+ *$ ( MOVE HIGH OFFSET ) MOV PSP )+ SYSBUF 4 + *$ ( MOVE LOW OFFSET ) CLR SYSBUF 6 + *$ ( OFFSET FROM BEGINNING OF FILE ) MOV PSP )+ 0 REG ( FILE DESCRIPTOR IN R0 ) 0 TRAP SYSBUF , ( SEEK SYSTEM CALL ) NEXT CODE TERMINATE ( --- ) CLR 0 REG ( RETURN GOOD STATUS ) 1 TRAP ( EXIT SYSTEM CALL ) ( SHOULD NOT EXECUTE BEYOND TRAP ) CODE (FIND) ( ADDR[NAME] ADDR[VOCAB] --- 0 NFA ) MOV PSP )+ 0 REG BEQ 3 FWD ( EMPTY VOCABULARY? ) MOV PSP ) 3 REG ( POINTER TO NAME ) MOV 3 )+ 2 REG ( NAME LS ) MOV 3 ) 3 REG ( NAME MS ) 1 L: MOV 0 ) 1 REG BIC 200 $ 1 REG ( CLEAR IMMEDIATE BIT ) CMP 1 REG 2 REG ( COMPARE LS ) BNE 2 FWD CMP 2 0 X( 3 REG ( COMPARE MS ) BEQ 4 FWD 2 L: MOV 4 0 X( 0 REG ( NEXT LINK ) BNE 1 BACK ( ZERO LINK? ) 3 L: 4 L: MOV 0 REG PSP ) NEXT CODE WORD ( DEL --- ADDR ) MOV PSP ) 0 REG ( DELIMITER ) MOV in *$ 1 REG ( >IN ) ADD inbuf $ 1 REG ( R1 HAS ADDRESS OF NEXT BYTE IN STREAM ) MOV dp *$ 2 REG ( HERE ) MOV 2 REG PSP ) ( RETURN HERE, ADDRESS OF STRING ) 1 L: CMP 0 REG 1 )+ BYTE ( SKIP DELIMITERS ) BEQ 1 BACK DEC 1 REG ( BACK UP ONE ) MOV 1 REG 3 REG 2 L: CMP 0 REG 3 ) BYTE ( DELIMITER? ) BEQ 3 FWD CMP 012 $ 3 ) BYTE ( NEWLINE? ) BEQ 4 FWD INC 3 REG ( SKIP UNTIL END OF WORD ) BR 2 BACK 3 L: 4 L: SUB 1 REG 3 REG ( R3 HAS LENGTH ) MOV 3 REG 2 )+ BYTE ( SAVE COUNT ) BEQ 6 FWD ( SKIP IF EOL, I.E. ZERO LENGTH ) 5 L: MOV 1 )+ 2 )+ BYTE ( MOVE CHARACTERS TO HERE ) 5 3 SOB 6 L: CMP 012 $ 1 ) BYTE ( IF NOT NEWLINE ) BEQ 7 FWD INC 1 REG ( SKIP DELIMITER ) 7 L: SUB inbuf $ 1 REG ( >IN IS OFFSET FROM START OF TIB ) MOV 1 REG in *$ ( UPDATE >IN SCANNER ) MOV 040 $ 2 )+ BYTE ( ADD BLANK TO END OF WORD NEXT ( STACK PRIMITIVES ) CODE ! ( DATA ADDR --- ) MOV PSP )+ 0 REG MOV PSP )+ 0 ) NEXT CODE !SP ( ADDR --- ) ( SET ADDRESS OF STACK TOP. ) MOV PSP ) PSP REG NEXT CODE + ( N1 N2 --- N1+N2 ) ADD PSP )+ PSP ) NEXT CODE +! ( DATA ADDR --- ) MOV PSP )+ 0 REG ADD PSP )+ 0 ) NEXT CODE - ( N1 N2 --- N1-N2 ) SUB PSP )+ PSP ) NEXT CODE -1 ( --- -1 ) MOV -1 $ PSP -( NEXT CODE 0 ( --- 0 ) CLR PSP -( NEXT CODE 0< ( N --- T/F ) CLR 0 REG TST PSP ) BPL 1 FWD MOV -1 $ 0 REG 1 L: MOV 0 REG PSP ) NEXT CODE 0= ( N --- T/F ) CLR 0 REG TST PSP ) BNE 1 FWD MOV -1 $ 0 REG 1 L: MOV 0 REG PSP ) NEXT CODE 1 ( --- 1 ) MOV 1 $ PSP -( NEXT CODE 1+ ( N --- N+1 ) INC PSP ) NEXT CODE 1- ( N --- N-1 ) DEC PSP ) NEXT CODE 2 ( --- 2 ) MOV 2 $ PSP -( NEXT CODE 2+ ( N --- N+2 ) ADD 2 $ PSP ) NEXT CODE 2- ( N --- N-2 ) SUB 2 $ PSP ) NEXT CODE 2* ( N --- 2*N ) ASL PSP ) NEXT CODE 2/ ( N --- N/2 ) ASR PSP ) NEXT CODE < ( N1 N2 --- T/F ) CLR 0 REG CMP PSP )+ PSP ) BLE 1 FWD MOV -1 $ 0 REG 1 L: MOV 0 REG PSP ) NEXT CODE = ( N1 N2 --- T/F ) CLR 0 REG CMP PSP )+ PSP ) BNE 1 FWD MOV -1 $ 0 REG 1 L: MOV 0 REG PSP ) NEXT CODE > ( N1 N2 --- T/F ) CLR 0 REG CMP PSP )+ PSP ) BGE 1 FWD MOV -1 $ 0 REG 1 L: MOV 0 REG PSP ) NEXT CODE >R ( N1 --- ) MOV PSP )+ SP -( NEXT CODE @ ( ADDR --- DATA ) MOV 0 PSP *X( PSP ) NEXT CODE @SP ( --- ADDR ) ( RETURN STACK POINTER ) MOV PSP REG 0 REG MOV 0 REG PSP -( NEXT CODE AND ( N1 N2 --- N1 & N2 ) MOV PSP )+ 0 REG COM 0 REG BIC 0 REG PSP ) NEXT CODE C! ( BYTE ADDR --- ) MOV PSP )+ 0 REG MOV PSP )+ 1 REG MOV 1 REG 0 ) BYTE NEXT CODE C@ ( ADDR --- BYTE ) MOV 0 PSP *X( 0 REG BYTE BIC 177400 $ 0 REG MOV 0 REG PSP ) NEXT CODE CMOVE ( SRC DEST UCOUNT --- ) MOV PSP )+ 2 REG BEQ 2 FWD ( DO NOTHING IF LENGTH ZERO ) MOV PSP )+ 0 REG ( DESTINATION ) MOV PSP )+ 1 REG ( SOURCE ) 1 L: MOV 1 )+ 0 )+ BYTE ( MOVE BYTE ) 1 2 SOB BR 3 FWD 2 L: ADD 4 $ PSP REG ( POP TWO STACK ARGS ) 3 L: NEXT CODE D+ ( D1L D1H D2L D2H --- [D1+D2]L [D1+D2]H ) MOV PSP )+ 0 REG ADD PSP )+ 2 PSP X( ADC PSP ) ADD 0 REG PSP ) NEXT CODE D< ( D1L D1H D2L D2H --- T/F ) CLR 0 REG CMP PSP )+ 2 PSP X( BLT 2 FWD BNE 1 FWD CMP PSP ) 4 PSP X( BLE 3 FWD 1 L: MOV -1 $ 0 REG 2 L: 3 L: ADD 4 $ PSP REG MOV 0 REG PSP ) NEXT CODE DNEGATE ( D1L D1H --- [-D1]L [-D1]H ) COM PSP ) COM 2 PSP X( ADD 1 $ 2 PSP X( ADC PSP ) NEXT CODE DROP ( N --- ) ADD 2 $ PSP REG NEXT CODE DUP ( N --- N N ) MOV PSP ) PSP -( NEXT CODE M* ( S1 S2 --- [S1*S2]L [S1*S2]H ) MOV PSP ) 0 REG MUL 0 REG-ONLY 2 PSP X( MOV 1 REG 2 PSP X( ( LOW RESULT ) MOV 0 REG PSP ) ( HIGH RESULT ) NEXT CODE M/ ( SDL SDH DIVISOR --- SREM SQUOT ) MOV PSP )+ 2 REG ( R2 HAS DIVISOR ) MOV PSP ) 0 REG ( R0 HAS HIGH DIVIDEND ) MOV 2 PSP X( 1 REG ( R1 HAS LOW DIVIDEND ) MOV 2 REG 3 REG EXOR 0 REG-ONLY 3 REG ( R3 HAS SIGN ) DIV 0 REG-ONLY 2 REG ( DIVIDE BY R2 ) TST 3 REG BPL 1 FWD ( BRANCH IF SIGN IS NOT NEGATIVE ) TST 1 REG BEQ 2 FWD ( BRANCH IF REMAINDER IS ZERO ) DEC 0 REG ( SUBTRACT ONE FROM QUOTIENT ) ADD