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
147
148
149
150
151
152
153
154
155
156
157
158
159
|
: \ 10 parse 2drop ; immediate \ test
: ( [ char ) ] literal parse 2drop ; immediate ( test )
: binary 2 base ! ;
: octal 8 base ! ;
: decimal 10 base ! ;
: hex 16 base ! ;
: nip swap drop ;
: tuck swap over ;
: <mark here ;
: <resolve here 4 + - d, ;
: >mark here 0 d, ;
: >resolve dup here swap - 4 - swap d! ;
: begin <mark ; immediate compile-only
: again branch <resolve ; immediate compile-only
: until ?branch <resolve ; immediate compile-only
: if ?branch >mark ; immediate compile-only
: else branch >mark swap >resolve ; immediate compile-only
: then >resolve ; immediate compile-only
: while ?branch >mark ; immediate compile-only
: repeat branch swap <resolve >resolve ; immediate compile-only
: ?dup dup 0<> if dup then ;
: allot dp +! ;
: ?find ?dup if find 0= if 2drop abort then else abort then ;
: 'h parse-name ?find ;
: ' 'h >body ;
: [compile] ' ( word ) compile, ; immediate compile-only
: ['] ' ( word ) [compile] literal ; immediate compile-only
: postpone 'h ( word ) dup immediate? if >body compile,
else >body [compile] literal ['] compile, compile, then ; immediate compile-only
: cells 8 * ;
: cell+ 8 + ;
: cell- 8 - ;
: create parse-name (header) latest ! ['] (create) compile, 0 , ;
: does> latest @ >body 2 + ['] (does>) over ! \ replace call loc
( replace destination ) 11 + r> swap ! ;
( the lone r> means we don't execute the rest of the word now, )
( but it is actually compiled into the definition and is jumped to )
( by a create does> made word )
: constant create , does> @ ;
: variable create 1 cells allot ;
: value parse-name (header) latest ! postpone literal
[ hex ] c3 c, [ decimal ] ; \ c3 = RET
: to ' ( word ) 6 + state @ if postpone literal postpone ! else ! then ; immediate
: +to ' ( word ) 6 + state @ if postpone literal postpone +! else +! then ; immediate
: -to ' ( word ) 6 + state @ if postpone literal postpone -! else -! then ; immediate
0 constant false
-1 constant true
hex
\ really i should just change the builtins to work with defer
: hijacks ' ( word ) here >r dp ! ( temporarily set dp so we can use , )
49 c, bb c, ( xt ) , \ mov r11, xt
41 c, ff c, e3 c, \ jmp r11
r> dp ! ;
decimal
: cmove, dup >r here swap cmove r> allot ;
: s" [ char " ] literal parse ( a u )
branch >mark >r 2dup cmove, nip ( u ) ( R: mark )
r> dup >resolve 4 + ( u a )
postpone literal ( a ) postpone literal ( u ) ; immediate compile-only
: z" [ char " ] literal parse ( a u )
branch >mark >r 2dup cmove, 0 c, nip ( u ) ( R: mark )
r> dup >resolve 4 + ( u a )
postpone literal ( a ) drop ; immediate compile-only
: zstrlen dup begin dup c@ 0<> while 1+ repeat swap - ;
\ todo s>z becomes s>z, s>z writes to pad (will then need to be moved below pno)
: s>z here -rot cmove, 0 c, ;
\ PRIVATISATION AND HIDING {{{
\ maybe i add locals later, implementation may be complex though. this isn't.
\ privatise just loops through words from the start of privatisation
\ to the end and activates the smudge bit on all of them.
\ privatisation yoinked from pforth
: (hide) cell+ dup c@ 1 or swap c! ;
: hide parse-name ?find (hide) ;
variable private0 variable private$
: private{ latest @ private0 ! ;
: }private latest @ private$ ! ;
: privatise private0 @ 0= private$ @ 0= or if abort then
private$ @
begin dup private0 @ u> while
dup (hide) @ ( → next ht ) repeat drop
0 private0 ! 0 private$ ! ;
\ }}}
\ MMAP {{{
\ MMAP CONSTANTS {{{
hex
\ prot
0 constant PROT_NONE 1 constant PROT_READ 2 constant PROT_WRITE 4 constant PROT_EXEC
\ flags
1 constant MAP_SHARED 2 constant MAP_PRIVATE 3 constant MAP_SHARED_VALIDATE
10 constant MAP_FIXED 20 constant MAP_ANONYMOUS 100 constant MAP_GROWSDOWN
decimal
\ }}}
: mmap 9 syscall6 ;
: munmap 11 syscall2 ;
\ }}}
\ NUMERIC OUTPUT {{{
\ this buffer is also used as a temporary string buffer.
255 constant #pad
create pad 255 cells allot
: pad$ pad #pad + ;
variable hld
: <# pad$ hld ! ;
: hold 1 hld -! ( chr ) hld @ c! ;
: sign 0< if [ char - ] literal hold then ;
: # base @ /mod swap 9 over < if 7 + then [ char 0 ] literal + hold ;
: #s begin # dup 0= until ;
: #> drop hld @ pad$ over - ;
\ }}}
\ ERRNO {{{
\ transform syscall result into [RESULT] IOR output,
\ where IOR is zero on no error and negative on an error (RESULT then being 0)
: >errno dup 0< if 0 swap else 0 then ;
\ }}}
\ I/O {{{
0 constant stdin
1 constant stdout
2 constant stderr
: sys-write 0 syscall3 ;
: sys-read 1 syscall3 ;
: sys-open 2 syscall3 ;
: sys-close 3 syscall1 ;
: type swap stdout sys-read drop ;
: emit sp 1 type drop ;
0 constant r/o
1 constant w/o
2 constant r/w
: open-file swap >r 0 r> sys-open >errno ;
: close-file sys-close ;
: read-file >r swap r> sys-read >errno ;
: write-file >r swap r> sys-write >errno ;
\ }}}
bye
|
