-
Notifications
You must be signed in to change notification settings - Fork 0
/
ans.f83
146 lines (120 loc) · 3.84 KB
/
ans.f83
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
\ -*- mode: forth -*-
\ vim: ft=forth
ONLY FORTH DOS ALSO
FORTH DEFINITIONS
: ALIGNED NOOP ; IMMEDIATE
: CHARS NOOP ; IMMEDIATE
: CHAR+ 1+ ;
2 CONSTANT CELL
: CELL+ CELL + ;
: CELLS CELL * ;
: INVERT NOT ;
: S" [COMPILE] " ; IMMEDIATE
: ACCEPT EXPECT SPAN @ ;
: 2LITERAL [COMPILE] DLITERAL ; IMMEDIATE
: [CHAR] [COMPILE] ASCII ; IMMEDIATE
: D>S DROP ;
: LSHIFT 0 DO 2* LOOP ;
0 CONSTANT R/O
: COMPARE (S c-addr1 u1 c-addr2 u2 --> n )
\ =======
ROT OVER = IF
COMP
ELSE
2DROP DROP -1 \ to be improved
THEN
;
: >NUMBER (S ud1 c-addr1 u1 --> ud2 c-addr2 u2 )
\ =======
2DUP + DUP >R DUP C@ >R BL SWAP C!
TUCK >R 1- DUP >R DUP C@ >R
TUCK C!
CONVERT
R> R@ C! R> CHAR+ TUCK - R> -
R> R> C!
;
\ Seiteneffekt: der Dateiname wird in Grossbuchstaben umgewandelt
\ (das fuehrt zu doppelten Strings)
\
\ Adresse / Offset | Groesse | Datentyp
\ -----------------------+---------+-----------
\ fileid | B/FCB | FCB
\ fileid + B/FCB | B/REC | DTA
\ fileid + B/FCB + B/REC | WORD | DTA Offset
: OPEN-FILE (S c-addr u fam --> fileid ior )
\ =========
DROP
2DUP SWAP 1- DUP >R DUP C@ >R TUCK C!
?UPPERCASE FIND IF
EXECUTE
NIP NIP
ELSE
( c-addr u c-addr0 )
"CREATE HERE [ B/FCB B/REC + CELL+ ] LITERAL DUP ALLOT
( c-addr u fileid size )
OVER SWAP ERASE
DUP CHAR+ 11 CHARS BLANK
( c-addr u fileid )
\ Dateierweiterung (Punkt) suchen
-ROT 2DUP 0 SWAP 0 ?DO
DROP I 1+ OVER I + C@ ASCII . = ?LEAVE
LOOP
( fcb c-addr u c-addr ldot )
NIP TUCK -
( fcb c-addr ldot rdot )
\ Dateierweiterung nach FCB+9 kopieren
?DUP IF \ Erweiterung t1..t3
2 PICK 2 PICK + 4 PICK 9 + ROT CMOVE \ kopieren
THEN
\ Dateiname ohne Punkt nach FCB+1 kopieren
2DUP + 1- C@ ASCII . = IF 1- THEN \ Punkt auslassen
2 PICK 1+ SWAP CMOVE \ Name f1..f8 kopieren
THEN
0 OVER 12 + C! \ reset FCB extent (ex)
0 OVER 32 + C! \ reset FCB record (cr)
B/REC OVER [ B/FCB B/REC + ] LITERAL + ! \ reset DTA offset
DUP 15 BDOS 255 <> IF 0 ELSE 1 THEN \ OPEN FILE
R> R> C! \ restore count byte
;
: READ-LINE (S c-addr u1 fileid --> u2 flag ior )
\ =========
0 ROT 0 ?DO
( c-addr fileid u2 )
OVER [ B/FCB B/REC + ] LITERAL + @ B/REC = IF
OVER B/FCB + SET-DMA \ SET DMA ADDRESS
OVER 20 BDOS \ READ SEQUENTIAL
255 <> IF
0 2 PICK [ B/FCB B/REC + ] LITERAL + ! \ DTA Offset := 0
THEN
\ OVER [ B/FCB B/REC + CELL+ ] LITERAL DUMP
THEN
( c-addr fileid u2 )
OVER [ B/FCB B/REC + ] LITERAL + @ B/REC < IF
OVER [ B/FCB B/REC + ] LITERAL +
DUP @ DUP 1+ ROT ! \ DTA Offset += 1
2 PICK B/FCB + + C@ \ naechstes Zeichen
( c-addr fileid u2 ch )
DUP 13 = OVER 10 = OR IF \ Zeilenende
2DROP I LEAVE
ELSE DUP 26 = OVER 0= OR IF \ Dateiende
2DROP -1 LEAVE
ELSE
3 PICK I + C!
THEN
THEN
ELSE
DROP -1 LEAVE
THEN
LOOP
NIP NIP
DUP 0>= 0
;
: CLOSE-FILE (S fileid --> ior )
\ ==========
16 BDOS \ CLOSE FILE
;
: THROW (S n --> )
\ =====
DROP
;
ENDPGM