kolibrios/programs/develop/SPForth/devel/~mak/listing3.f

162 lines
3.6 KiB
FortranFixed
Raw Normal View History

REQUIRE PLACE ~mak/place.f
REQUIRE [IF] ~mak/CompIF.f
REQUIRE DISASSEMBLER lib/ext/disasm.f
C" STREAM-FILE" FIND NIP
[IF]
: FROM_SOURCE-ID SOURCE-ID STREAM-FILE ;
: TO_SOURCE-ID FILE>RSTREAM TO SOURCE-ID ;
[ELSE]
: FROM_SOURCE-ID SOURCE-ID ;
: TO_SOURCE-ID TO SOURCE-ID ;
[THEN]
: INST [ ALSO DISASSEMBLER ] INST
[ PREVIOUS ] ;
C" -CELL" FIND NIP 0=
[IF] -1 CELLS CONSTANT -CELL
[THEN]
CREATE FILE_NAME_L 120 ALLOT
CREATE HERE-TAB 5000 CELLS ALLOT
HERE CELL- CONSTANT HERE-TAB-MAX
VARIABLE HERE-TAB-CUR
HERE-TAB HERE-TAB-CUR !
VARIABLE S_STATE
: HERE-TAB-CUR+
HERE-TAB-CUR @ CELL+ HERE-TAB-MAX UMIN
HERE-TAB-CUR
!
\ [ .( XXXX) DIS-OPT KEY DROP ]
;
: HERE-TO-TAB DP @ HERE-TAB-CUR @ ! HERE-TAB-CUR+ ;
CREATE SHERE-TAB 800 CELLS ALLOT
HERE CELL- CONSTANT SHERE-TAB-MAX
VARIABLE SHERE-TAB-CUR
SHERE-TAB SHERE-TAB-CUR !
: SHERE-TAB-CUR+
SHERE-TAB-CUR @ CELL+ SHERE-TAB-MAX UMIN
SHERE-TAB-CUR ! ;
: SHERE-TO-TAB DP @ SHERE-TAB-CUR @ ! SHERE-TAB-CUR+ ;
80 VALUE DUMP_MAX
: MDUMP ( addr u -- )
DUP 0= IF 2DROP EXIT THEN
BASE @ >R HEX
BEGIN
CR OVER BASE-ADDR - 4 .0 SPACE
2DUP 0x10 MIN
2DUP 0 DO I 4 MOD 0= IF SPACE THEN
DUP C@ 2 .0 SPACE 1+
LOOP DROP
DUP >R PTYPE
R@ - SWAP R> + SWAP DUP 0=
UNTIL 2DROP
R> BASE ! CR
;
: .LIST ( ADDR ADDR1 -- ADDR1' )
S_STATE @
IF
SWAP
BEGIN 2DUP U>
WHILE INST CR
REPEAT NIP
ELSE
TUCK
OVER - DUP
IF DUP DUMP_MAX U>
IF >R DUMP_MAX DUMP
CR DUP U. R> DUMP_MAX - U. ." bytes"
ELSE MDUMP
THEN CR
ELSE 2DROP
THEN
THEN
;
VECT INCLUDED$
' INCLUDED TO INCLUDED$
: INCLUDED_L
['] <PRE> >BODY @ >R
['] HERE-TO-TAB TO <PRE>
HERE-TAB HERE-TAB-CUR !
SHERE-TAB SHERE-TAB-CUR !
2DUP 2>R INCLUDED$ 2R> R> TO <PRE>
-1 SHERE-TAB-CUR @ ! SHERE-TAB-CUR+
HERE-TO-TAB
HERE-TO-TAB -CELL HERE-TAB-CUR +!
HERE-TAB-CUR @ @ -CELL HERE-TAB-CUR +!
BEGIN HERE-TAB-CUR @ HERE-TAB <>
WHILE HERE-TAB-CUR @ @ UMIN DUP HERE-TAB-CUR @ !
-CELL HERE-TAB-CUR +!
REPEAT DROP
S_STATE 0!
SHERE-TAB SHERE-TAB-CUR !
2DUP FILE_NAME_L PLACE
S" _L" FILE_NAME_L +PLACE
R/O OPEN-FILE THROW
FILE_NAME_L COUNT 2DUP + 0!
W/O CREATE-FILE THROW
TIB >R >IN @ >R #TIB @ >R SOURCE-ID >R BLK @ >R CURSTR @ >R
H-STDOUT >R BASE @ >R HEX
C/L 2 + ALLOCATE THROW TO TIB BLK 0!
TO H-STDOUT
." ZZ=" DUP .
TO_SOURCE-ID
CURSTR 0! HERE-TAB-CUR @ @
BEGIN REFILL
WHILE
SOURCE TYPE CR
BEGIN SHERE-TAB-CUR @ @ HERE-TAB-CUR @ CELL+ @ U<
WHILE SHERE-TAB-CUR @ @ .LIST SHERE-TAB-CUR+
S_STATE @ INVERT S_STATE !
REPEAT HERE-TAB-CUR+ HERE-TAB-CUR @ @ .LIST
REPEAT DROP
TIB FREE THROW
FROM_SOURCE-ID
." ZZ=" DUP .
CLOSE-FILE THROW ( <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> )
H-STDOUT CLOSE-FILE THROW ( <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> )
R> BASE ! R> TO H-STDOUT
R> CURSTR ! R> BLK ! R> TO SOURCE-ID R> #TIB ! R> >IN ! R> TO TIB
;
: REQUIRED_L ( waddr wu laddr lu -- )
2SWAP SFIND
IF DROP 2DROP EXIT
ELSE 2DROP INCLUDED_L THEN
;
[UNDEFINED] PSKIP [IF]
: PSKIP SKIP ;
[THEN]
: REQUIRE_L ( "word" "libpath" -- )
BL PSKIP BL PARSE
BL PSKIP BL PARSE 2DUP + 0 SWAP C!
REQUIRED_L
;
: : : SHERE-TO-TAB ;
: ; POSTPONE ; SHERE-TO-TAB ; IMMEDIATE
: SSSS
HERE-TAB HERE-TAB-CUR !
SHERE-TAB SHERE-TAB-CUR !
;