UNIX FORTH for the PDP11 (part 6 of 7)
lwt1 at aplvax
lwt1 at aplvax
Sat Jun 9 05:57:01 AEST 1984
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 )
( <BUILDS .. DOES> 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 <OR> 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
More information about the Comp.sources.unix
mailing list