% *********************************************************
% * *
% * PISTOL-Portably Implemented Stack Oriented Language *
% * Version 1.3 *
% * (C) 1982 by Ernest E. Bergmann *
% * Physics, Building #16 *
% * Lehigh Univerisity *
% * Bethlehem, Pa. 18015 *
% * *
% * Permission is hereby granted for all reproduction and *
% * distribution of this material provided this notice is *
% * is included. *
% * *
% *********************************************************
% BASIC DEFINITIONS IN PISTOL FOR PISTOL- "PBASE"
% FEBRUARY 6, 1982, RECURSE DEF. FIXED
% DECIMAL mode initially
-6 W * USER + W@ W@ % used for 'LAST-PRIMITIVE
'W* W 1 - IF : W * ;
ELSE $: ;$
THEN
'USER+ USER IF $: USER + ;$
ELSE $: ;$
THEN
'TRANS $: W* USER+ ;$ % TRANSLATES LOGICAL ADDRESSES TO ACTUAL
% RAM ADDR.
% TRANS MUST USE "$:" FOR THE 'DIS PACKAGE
'TRANS@ : TRANS W@ ;
'ARGPATCH : -6 TRANS@ W@ W + W! ; % for 'CONSTANT 'VARIABLE,
% and 'ARRAY
'CONSTANT : : 0 ; ARGPATCH ;
'LAST-PRIMITIVE CONSTANT
-1 'TRUE CONSTANT
0 'FALSE CONSTANT
-57 TRANS@ 'MAXLINNO CONSTANT
-56 TRANS@ 'CHKLMT CONSTANT
-55 TRANS@ 'RAMMIN CONSTANT
-54 TRANS@ 'STRINGSMIN CONSTANT
% -53 TRANS NOT CURRENTLY BEING USED
-52 TRANS 'ABORT-PATCH CONSTANT
-51 TRANS 'CONVERT-PATCH CONSTANT
-50 TRANS 'PROMPT-PATCH CONSTANT
-49 TRANS@ 'STRINGSMAX CONSTANT
-48 TRANS@ 'VBASE CONSTANT
-47 TRANS@ 'VSIZE CONSTANT
VBASE VSIZE W* + 'VMAX CONSTANT
-46 TRANS@ 'CSIZE CONSTANT
-45 TRANS@ 'LSIZE CONSTANT
-44 TRANS@ 'RSIZE CONSTANT
-43 TRANS@ 'SSIZE CONSTANT
-42 TRANS@ 'LINEBUF CONSTANT
LINEBUF 200 + 'EDITBUF CONSTANT
-41 TRANS@ 'COMPBUF CONSTANT
-40 TRANS@ 'RAMMAX CONSTANT
-39 TRANS@ 'MAXORD CONSTANT
-38 TRANS@ 'MAXINT CONSTANT
% -37 TRANS NOT CURRENTLY BEING USED
-36 TRANS@ 'VERSION CONSTANT
'ON : TRUE SWAP W! ;
'OFF : FALSE SWAP W! ;
'INFILE : -11 TRANS@ ;
'BYE : -35 TRANS ON ;
-34 TRANS '(PISTOL<) CONSTANT
-32 TRANS '.V CONSTANT
-29 TRANS 'LOADFILE-STATUS CONSTANT
-28 TRANS '#GET-ADDR CONSTANT % FOR PATCHING #GETLINE
-27 TRANS 'TAB-SIZE CONSTANT
-26 TRANS 'TRACE-ADDR CONSTANT
-25 TRANS 'ENDCASE-PATCH CONSTANT
-24 TRANS 'COLUMN CONSTANT
-23 TRANS 'TERMINAL-WIDTH CONSTANT
-22 TRANS '#LINES CONSTANT
-21 TRANS 'TERMINAL-PAGE CONSTANT
-20 TRANS 'COMPILE-END-PATCH CONSTANT
-19 TRANS 'TRACE-LEVEL CONSTANT % USED AS BOOLEAN AND LEVEL
% INDICATOR
-17 TRANS 'RAISE CONSTANT
-15 TRANS 'NEXTCH^ CONSTANT
-14 TRANS 'CONSOLE CONSTANT
-13 TRANS 'ECHO CONSTANT
-12 TRANS 'LIST CONSTANT
-6 TRANS 'CURRENT CONSTANT
-5 TRANS 'OLD-EOSTRINGS CONSTANT % END OF PERMANENT STRINGS
% VARIABLE
-4 TRANS 'CURRENT-EOSTRINGS CONSTANT
-3 TRANS '.D CONSTANT
-2 TRANS '.C CONSTANT
-1 TRANS 'RADIX CONSTANT
STRINGSMIN 'RADIX-INDICATOR CONSTANT
STRINGSMIN 1 + 'SYNTAXBASE CONSTANT
'NOP : ;
'DUP : 0 S@ ;
'1+ : 1 + ;
'1- : 1 - ;
'W+ : W + ;
'W- : W - ;
'W<- : SWAP W! ;
'1+W! : DUP W@ 1+ W<- ;
'W+W! : DUP W@ W+ W<- ;
'CR : 13 TYO ;
'SPACE : 32 TYO ;
'SPACES : 0 DO SPACE LOOP ;
'DDUP : 1 S@ 1 S@ ;
'OVER : 1 S@ ;
'2OVER : 2 S@ ;
'3OVER : 3 S@ ; % USED BY DIS PACKAGE(DON'T CHANGE!)
'UNDER : SWAP DROP ;
'TYPE : 0 DO DUP C@ TYO 1+ LOOP DROP ;
'LT : SWAP GT ;
'LINE-SPACE? : COLUMN W@ + TERMINAL-WIDTH W@ LT
IF ELSE CR THEN ;
'MSG : DUP C@ LINE-SPACE?
DUP 1+ SWAP C@ TYPE ;
'IFCR : COLUMN W@ 0 GT IF CR THEN ;
'ERR : IFCR ABORT ;
'MERR : CONSOLE ON MSG ERR ;
'INDENT : DUP TERMINAL-WIDTH W@ LT IF
COLUMN W@ - SPACES
ELSE IFCR DROP
THEN ;
'TAB : 9 TYO ;
'TABS : 0 DO TAB LOOP ;
'ALLOT : W* .D W@ + .D W! ; % advances dictionary pointer
% by the amount given by top of stack
'W, : % PLACES TOS AT END OF DICTIONARY
.D W@ W! 1 ALLOT
;
'VARIABLE : : 3 ; % create definition
.D W@ ARGPATCH % point it at end of dictionary
W, % initialize variable
; % finish with allocating space
'ARRAY : : 3 ; % create definition
.D W@ ARGPATCH % point it at end of dictionary
ALLOT ; % allocate requested space and ;
% VOCABULARY RELATED DEFINITIONS:
'> : .V W@ DUP VBASE GT % "POPS" VOCABULARY STACK
IF W- .V W!
ELSE "*** VSTACK UNDERFLOW***" MERR
THEN
;
'<V : % TRANSFERS TOS TO TOP OF VSTACK
.V W@ DUP VMAX LT
IF W+ DUP .V W! W!
ELSE "*** VSTACK OVERFLOW***" MERR
THEN
;
'PISTOL< : (PISTOL<) <V ;
(PISTOL<) 'BRANCH-LIST VARIABLE
'BRANCH : % CREATES AN ARRAY OF TWO ELEMENTS
% AND A PROCEDURE THAT PUSHES A ^
% TO THE FIRST ELEMENT OF THE ARRAY
% THIS FIRST ELEMENT CONTAINS A ^
% TO THE CURRENT HEAD OF THE VOCABULARY
% BRANCH AND THE SECOND ELEMENT IS A
% BACKWARD LINK TO THE PREVIOUS HEAD.
% BRANCH-LIST CONTAINS THE ^ TO THE
% THREADED LIST OF BRANCHES THAT HAVE
% BEEN DEFINED; THE BACKWARD LINK FOR
% (PISTOL<) IS "NIL"
: 3 <V ; .D W@ ARGPATCH
0 .D W@ W!
BRANCH-LIST W@ .D W@ W+
W!
.D W@ BRANCH-LIST
W!
2 ALLOT
;
'SYSTEM< BRANCH % CAN BE USED FOR RARELY USED, OBSCURE,
% OR DANGEROUS WORDS
'BLIST : % LISTS THE NAMES OF ALL DEFINED BRANCHES
BRANCH-LIST W@
BEGIN
DUP W+ W@ DUP % GET LINK
IF
SWAP 6 W* -
W@ MSG CR
REPEAT
DROP DROP
IFCR
'PISTOL< MSG
;
% DO LOOP INDICES:
'I : 0 L@ ;
'J : 3 L@ ;
'K : 6 L@ ;
'I' : 2 L@ 1 L@ + 1- 0 L@ - ;
'J' : 5 L@ 4 L@ + 1- 3 L@ - ;
'K' : 8 L@ 7 L@ + 1- 6 L@ - ;
% SOME LOGICAL OPERATORS:
'LOR : IF DROP TRUE THEN ; % LOGICAL OR
'LAND : IF ELSE DROP FALSE THEN ; % LOGICAL AND
'NOT : IF FALSE ELSE TRUE THEN ;
% NUMBER OUTPUT ROUTINE:
% ASCII <-- DIGIT
'ASCII : DUP 9 GT IF 55
ELSE 48
THEN + ;
'MINUS : 0 SWAP - ;
'<U#> : -1 SWAP BEGIN RADIX W@ /MOD SWAP DUP NOT END DROP ;
'#TYPE : BEGIN DUP -1 GT IF ASCII TYO REPEAT DROP ;
'= : DUP 0 LT IF 45 TYO MINUS THEN
<U#> #TYPE ;
'? : W@ = ;
% BELOW ARE WORDS THAT CONTROL DISPLAY OF CODE PRODUCED
% BY THE COMPILER; CAN BE USEFUL FOR DEBUGGING AND EDUCATION
'CODESHOW : IFCR "COMPILE BUFFER CONTAINS:" MSG CR
COMPBUF BEGIN DUP ? TAB W+
.C W@ OVER GT NOT
END
DROP IFCR
;
'SHOWCODE : 'CODESHOW FIND COMPILE-END-PATCH W! ;
% SHOWCODE SHOULD NOT BE CHANGED WITHOUT CHECKING 'DIS PACKAGE
'NOSHOWCODE : COMPILE-END-PATCH OFF ;
'PROMPT : % DUPLICATES PRIMITIVE PROMPT
IFCR % FUNCTION
SP IF SP = THEN % EXCEPT STACK SIZE SHOWN
RADIX-INDICATOR C@ TYO
SYNTAXBASE MSG
"> " MSG
;
'PROMPT FIND PROMPT-PATCH W! % PATCHING IT
0 'FENCE VARIABLE
'ADDRESS : DUP FIND DUP IF UNDER
ELSE IFCR
39 TYO DROP MSG
" NOT FOUND" MERR
THEN ;
'FORGET : ADDRESS DUP FENCE W@
GT IF % ADDRESS OK, SO TRUNCATE EVERYTHING:
DUP W- W- W@ DUP OLD-EOSTRINGS W!
CURRENT-EOSTRINGS W!
W- W- W- DUP W@ CURRENT W@ W! W- .D W!
ELSE % ADDRESS BELOW FENCE
"BELOW FENCE" MERR THEN ;
% PROTECT 'FORGET WITH THE FENCE:
'FORGET FIND FENCE W!
'/ : /MOD DROP ;
'MOD : /MOD UNDER ;
% CHANGING NUMBER BASES:
'HEX : 72 RADIX-INDICATOR C! 16 RADIX W! ;
'DECIMAL : 88 RADIX-INDICATOR C! 10 RADIX W! ;
'OCTAL : 81 RADIX-INDICATOR C! 8 RADIX W! ;
'BINARY : 66 RADIX-INDICATOR C! 2 RADIX W! ;
'LTZ : 0 LT ;
'GTZ : 0 GT ;
'EQZ : NOT ;
'ABS : DUP LTZ IF MINUS THEN ;
'EQ : - NOT ;
'MIN : DDUP GT IF SWAP THEN DROP ;
'MAX : DDUP LT IF SWAP THEN DROP ;
% RANGE TEST:
'.. : 2OVER LT SWAP 2OVER GT LOR NOT UNDER ;
%
'STACK : IFCR 40 TYO SP = 41 TYO % (STACKSIZE)
SP SP 12 MIN 1- 0 DO 2 SPACES DUP S@ = 1- LOOP
DROP ;
%
'RSTACK : IFCR 'R( MSG RP 1- = 41 TYO % RSTACK SIZE
RP 1- DUP 12 MIN 0 DO 2 SPACES DUP R@ = 1-
LOOP DROP ;
% RECURSE ALOWS ROUTINE OR COMPBUF TO CALL ITSELF
'RECURSE : 1 R@ W- % FIND ADDRESS OF WORD RECURSE IS IN
0 R@ W- % FIND WHERE RECURSE IS USED
W! % "PATCH"
R> W- <R % BACK UP INSTRUCTION POINTER
;
%
'TELL : W- W- W@ DUP STRINGSMIN STRINGSMAX .. IF MSG
ELSE "NOT VALID WORD ADDRESS" MERR THEN
;
'NEXT-LINK : W- W- W- W@ ;
%
% THIS BOMBS WHEN > NUMINSTRUCTIONS
'PNAME : DUP IF
LAST-PRIMITIVE
BEGIN DUP
IF DDUP W@ EQ
IF TELL TRUE
ELSE NEXT-LINK FALSE
THEN
ELSE '(NO_NAME) MSG NOT
THEN
END
DROP
ELSE '; MSG DROP
THEN
;
%
'NAME : DUP KERNEL? IF
PNAME
ELSE TELL
THEN ;
% LLIST ADDRESS AND NAME:
'LNAME : DUP = 3 SPACES NAME CR ;
%
% LIST LAST TEN WORDS:
'NEXT10 : IFCR 10 0 DO DUP NOT IF ERR THEN
DUP LNAME NEXT-LINK LOOP ;
'TOP10 : % OF VOCBULARY TO WHICH DEFINITIONS ARE
% CURRENTLY BEING ADDED
CURRENT W@ W@ NEXT10 ;
'VLIST : % TOP TEN WORDS IN FIRST VOCABULARY TO BE SEARCHED
.V W@ W@ W@ NEXT10 ;
% CASE INDICES:
'ICASE : 0 CASE@ ;
'JCASE : 2 CASE@ ;
'CASE-ADDR : 1 CASE@ ;
'(ENDCASE) : IFCR "ENDCASE ENCOUNTERED WITH VALUE = " MSG
ICASE = " AT " MSG CASE-ADDR = ERR ;
'(ENDCASE) ADDRESS ENDCASE-PATCH W! % PATCH ENDCASE
'(ENDCASE) ADDRESS FENCE W! % RAISE FENCE
% SPECIAL STRING ROUTINES:
% PACK puts TOS onto the end of the strings area.
'PACK : CURRENT-EOSTRINGS W@ C!
CURRENT-EOSTRINGS 1+W! ;
'=PACK : CURRENT-EOSTRINGS W@ <R
CURRENT-EOSTRINGS 1+W!
DUP LTZ IF 45 PACK MINUS THEN
<U#> BEGIN DUP -1 GT IF ASCII PACK REPEAT
DROP R> CURRENT-EOSTRINGS W@ OVER -
1- OVER C! ;
% =PACK IS USED TO CREATE A NUMBER STRING. IT
% TAKES THE TOP SIGNED NUMBER ON STACK AND CONVERTS IT
% TO A STRING THAT COULD BE OUTPUT BY MSG
% THE NEXT TWO ROUTINES TAKE AS INPUT
% A BUNCH OF STRING POINTERS
% AND THEIR NUMBER FROM THE TOP OF STACK.
'MSGS-COUNT : SP 1- OVER LT IF "NOT ENOUGH STRINGS"
MERR THEN
0 SWAP 1+ 1 DO I S@ C@ + LOOP ;
'MSGS : DUP <R DUP <R MSGS-COUNT LINE-SPACE?
R> 0 DO I' S@ MSG LOOP R> 0 DO DROP LOOP
;
% In the above, MSGS will output a bunch of strings
% that were left on stack IN THE ORDER they were placed
% on stack, trying to place them all on the same line;
% failing that, it will try and not split the individual
% strings across lines. It will be used to improve the
% DISASSEMBLER PACKAGE
'DIS-TRIAL : % CONTAINS ALL REL-OPS IN THE KERNEL
DO +LOOP
DO LOOP
IF ELSE
THEN
OFCASE C: ;C ENDCASE
: ;
$: ;$
;
'NEXT-TRIAL : % CONVENIENCE TO STEP THROUGH DIS-TRIAL
W+ W+ DUP W@
;
'OP-TYPE : % USED TO DEFINE WORDS FOR TESTING KERNEL OPS
DUP :
3 EQ IF "" TRUE ELSE FALSE THEN
;
CURRENT W@ W@ 6 W* + W! % GET THE NAME OF
% DEFINITION
ARGPATCH % RECORD THE VALUE OF OPCODE
;
'3OVER FIND % IT STARTS WITH A LITERAL CONSTANT
W@ 'LITERAL CONSTANT
'SHOWCODE FIND % IT STARTS WITH A STRING LITERAL
W@ 'STRING-LIT CONSTANT
'TRANS FIND % IT IS A "$:" WORD
W- W@ '[$:] OP-TYPE
'DIS-TRIAL FIND
DUP W- W@ '[:] OP-TYPE
NEXT-TRIAL '(+LOOP) OP-TYPE
NEXT-TRIAL '(DO) OP-TYPE
NEXT-TRIAL '(LOOP) OP-TYPE
NEXT-TRIAL '(IF) OP-TYPE
NEXT-TRIAL '(ELSE) OP-TYPE
NEXT-TRIAL '(OFCASE) OP-TYPE
NEXT-TRIAL '(C:) OP-TYPE
W+ W+
NEXT-TRIAL '(:) OP-TYPE
NEXT-TRIAL '(;) OP-TYPE
W-
NEXT-TRIAL '($:) OP-TYPE
DROP
'REL-OP :
SWAP W+ W@ =PACK
" [" SWAP ']
4 MSGS W W+
;
'DIS-TOKEN :
DUP W@ OFCASE
(;) C: MSG DROP W ;C
LITERAL EQ C: W+ W@ =PACK MSG W W+ ;C
STRING-LIT EQ C: W+ W@ '" SWAP OVER
3 MSGS W W+ ;C
(DO) C: REL-OP ;C
(LOOP) C: REL-OP ;C
(+LOOP) C: REL-OP ;C
(IF) C: REL-OP ;C
(ELSE) C: REL-OP ;C
(OFCASE) C: REL-OP ;C
(C:) C: REL-OP ;C
(:) C: REL-OP ;C
($:) C: REL-OP ;C
TRUE C: NAME DROP W ;C
ENDCASE
;
'WORD-ID : IFCR 39 TYO DUP MSG SPACE ADDRESS ;
'DIS : WORD-ID
DUP W- DUP W@ DUP
[:] IF MSG DROP
ELSE [$:] IF MSG
ELSE "NON-STANDARD IMMEDIATE WORD"
MERR
THEN
THEN
W- W- W- W@ % GET ^ TO END OF CODE
SWAP DO
TAB I DIS-TOKEN
+LOOP
TAB '; MSG
;
% TRACE PACKAGE:
% ROUTINE THAT DISPLAYS THE STATE OF THE MACHINE
% AT EACH TRACE AND TERMINATES TRACE AT END OF
% ROUTINE BEING TRACED.
'(TRACE) : STACK 48 INDENT 0 R@ W@ DUP
(;) IF MSG DROP 0 TRACE-LEVEL W!
ELSE NAME 2 SPACES
THEN
;
% PERFORM PATCH:
'(TRACE) ADDRESS TRACE-ADDR W!
'TRACE : WORD-ID "BEING TRACED:" MSG
RP 3 + TRACE-LEVEL W!
EXEC IFCR "TRACE COMPLETED" MSG
CR
;
% EDIT PACKAGE:
-31 TRANS 'OUTFILE-STATUS CONSTANT
-30 TRANS 'INPUTFILE-STATUS CONSTANT
STRINGSMAX 200 -
'SAFE-END CONSTANT
1 'OLDLINE# VARIABLE
EDITBUF 'OLDLINE^ VARIABLE
EDITBUF 'EOT VARIABLE
'NEWF : 1 OLDLINE# W!
EDITBUF OLDLINE^ W!
0 EDITBUF C!
EDITBUF EOT W!
;
NEWF % INITIALIZE EDITBUFFER
'NEXTLINE : DUP C@ DUP IF + 1+
ELSE "***NO SUCH LINE***" MERR
THEN ;
'LISTALL : 1 EDITBUF
BEGIN DUP C@
IF OVER = ": " MSG DUP MSG NEXTLINE
SWAP 1+ SWAP REPEAT DROP DROP ;
'ILLEGLIN : "***ILLEGAL LINE #***" MERR ;
'LFIND : DUP OLDLINE# LT IF DUP 1 LT
IF ILLEGLIN THEN
DUP MAXLINNO GT IF ILLEGLIN THEN
EDITBUF OVER 1 DO
NEXTLINE LOOP
ELSE DUP OLDLINE# % CALCULATE # OF
- OLDLINE^ W@ % LINES NEEDED TO
SWAP 0 DO
NEXTLINE LOOP % ADVANCE
THEN
SWAP OLDLINE# W!
DUP OLDLINE^ W!
;
'LDIR : % CHARACTER BLOCK MOVE, INCREASING
% ON ENTRY: SOURCE, DESTINATION, #
% ON EXIT: SOURCE+#, DESTINATION+#
0 DO OVER C@ OVER C!
1+ SWAP 1+ SWAP
LOOP
;
'LDDR : % CHARACTER BLOCK MOVE, DECREASING
% ON ENTRY: SOURCE, DESTINATION, #
% ON EXIT: SOURCE-#, DESTINATION-#
0 DO
OVER C@ OVER C!
1- SWAP 1- SWAP
LOOP
;
'#GETLINE : % TAKES THE LINE NUMBERED BY THE
% TOP OF THE STACK AND TRANSFERS
% IT INTO LINEBUF
LFIND
LINEBUF 1+ NEXTCH^ W! % SYSTEM ^S
LINEBUF
OVER C@ 1+
LDIR
DROP DROP
ECHO W@ IF LINEBUF MSG THEN % ECHO IF
% APPROPRIATE
;
'#GETLINE FIND #GET-ADDR W! % DO THE PATCH
'MTUP : % ON ENTRY: ^ TO BAS OF BLOCK BOUNDED BY EOT
% ON EXIT: ^ TO BASE OF MOVED BLOCK AT STRINGSMAX
EOT W@ 1+ SWAP - % # BYTES
EOT W@ SWAP % SOURCE
STRINGSMAX SWAP % DESTINATION
LDDR
UNDER 1+
;
'OVERWRITE : % TAKES THE ^BOTTOM OF TEXT TO BE MOVED DOWN
% ^TEXT TO BE OVERWRITTEN
% AND ^LAST CHAR OF TEXT TO BE MOVED DOWN
% ON EXIT LEAVES NO ARGS BUT HAS ADJUSTED EOT
1+ 2OVER -
LDIR
1-
EOT W!
DROP
;
'MTDN : % ON ENTRY: ^ TO BASE OF BLOCK AT STRINGSMAX
% AND ^ TO BASE OF DESTINATION
STRINGSMAX
OVERWRITE
;
'LENTER : % TAKES ADDRESS ON TOP OF STACK AND MOVES INPUT
% LINE THERE; LEAVES A POINTER TO NEXT AVAILABLE
% LOCATION.
LINEBUF NEXTLINE LINEBUF
DO
I C@ OVER C! 1+
LOOP
;
'1POSARG? : % TESTS STACK TO SEE IF THERE IS EXACTLY
% ONE ARGUMENT; IT MUST BE POSITIVE.
% ON EXIT IT LEAVES THAT ARGUEMENT.
SP 1 EQ OVER -1 GT LAND
NOT
IF "NOT SINGLE, POSITIVE ARGUEMENT" MERR
THEN
;
'ARG#ERR : "WRONG NUMBER OF ARGUMENTS" MERR ;
'LI : SP OFCASE
EQZ C: LISTALL ;C
1 EQ C: LFIND MSG ;C
2 EQ C: DDUP GT IF OVER + 1- THEN
1+ SWAP DO I = ": " MSG
I LFIND MSG LOOP ;C
TRUE C: ARG#ERR ;C
ENDCASE
;
'INPUT :
1POSARG?
DUP
LFIND
MTUP
SWAP DUP LFIND
BEGIN
SWAP DUP
= ": " MSG
1+ SWAP
GETLINE
LINEBUF C@ 1 GT
IF
LENTER
REPEAT
UNDER
MTDN
;
'(DELETE) : LFIND
DUP NEXTLINE
SWAP
EOT W@
OVERWRITE
;
'DELETE : 1POSARG?
(DELETE)
;
'REPLACE : 1POSARG?
DUP
(DELETE)
INPUT
;
'DELETES : SP 2 EQ
IF
DDUP LT IF OVER - 1+ THEN % IF ARG1<ARG2
% THEN INTERPRET
% AS RANGE !
0 DO DUP (DELETE) LOOP
DROP
ELSE
ARG#ERR
THEN
;
'1READ : % NO ERROR CHECKING
% TAKES A LINE FROM THE INPUT FILE AND
% APPENDS IT TO THE END OF THE
% TEXT IN THE EDIT BUFFER.
READLINE
0 EOT W@
LENTER
DUP
EOT W! % UPDATE EOT
C! % EMPLACE NEW EMPTY LINE
;
'READ : % TAKES A SINGLE ARGUMENT FROM STACK AS THE
% NUMBER OF LINES TO BE READ FROM THE INPUT
% FILE AND APPEND THEM TO THE END OF THE EDIT
% BUFFER.
1POSARG?
BEGIN
EOT W@ SAFE-END LT
OVER LAND
IF
1READ
1- % DECREASE COUNT
REPEAT
IF
"PREMATURE EOF ENCOUNTERED" MSG
THEN
;
'WRITE : % TAKES A SINGLE ARGUMENT FROM STACK AS
% THE NUMBER OF LINES TO BE TRANSFERRED
% FROM THE BEGINNING OF THE EDIT BUFFER
% TO THE OUTPUT FILE.
1POSARG?
1 LFIND % ADJUSTS POINTERS
BEGIN % IF NOT EOT, STILL MORE LINES TO SEND
DUP C@ 2OVER LAND
IF
DUP WRITELINE
NEXTLINE
SWAP 1- SWAP
REPEAT
% AT THIS POINT HAVE POINTER TO TEXT
% THAT IS NOT YET SENT AND NUMBER OF LINES
% YET T
O BE SENT AFTER EOT
EDITBUF % DESTINATION
EOT W@
OVERWRITE
IF IFCR "PREMATURE EOT ENCOUNTERED" MSG THEN
;
'FINISH : % USED AT END OF EDIT SESSION TO TRANSFER
% CONTENTS OF EDIT BUFFER AND ANY ADDITIONAL
% REMAINING TEXT IN THE INPUT FILE TO THE
% OUTPUT FILE.
EDITBUF
BEGIN % EMPTY EDIT BUFFER
DUP C@
IF
DUP
WRITELINE
NEXTLINE
REPEAT
DROP
NEWF
BEGIN % TRANSFER REMAINDER OF INPUT FILE
INPUTFILE-STATUS
W@ -1 GT
IF
READLINE
LINEBUF WRITELINE
REPEAT
% SUMARIZE:
IFCR
"SUMARIZING: " MSG
INPUTFILE-STATUS W@ MINUS =
" LINES READ AND " MSG
OUTFILE-STATUS W@ MINUS =
" LINES WRITTEN." MSG
% CLOSING STATUS OF OUTPUT FILE:
+1 OUTFILE-STATUS W!
;
% TEST INPUT:
1 INPUT
THIS IS THE FIRST LINE
THIS IS THE SECOND LINE
THIS IS THE THIRD LINE
THIS IS THE FOURTH LINE
THIS IS THE LAST LINE
;F
