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
|
: \ 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 - ;
: 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 ;
\ }}}
\ I/O {{{
0 constant stdin
1 constant stdout
2 constant stderr
: sys-write 0 syscall3 ;
: sys-read 1 syscall3 ;
: type swap stdout 1 syscall3 drop ;
: emit sp 1 type drop ;
\ }}}
bye
|
