-
Notifications
You must be signed in to change notification settings - Fork 3
/
yoda.core
177 lines (153 loc) · 13 KB
/
yoda.core
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
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
only forth definitions
\ ----- defining words -----------------------------------
: create here constant ; \ create: ( -- ) ( s: word -- ) execute: ( -- a )
: create$ here constant$ ; \ create: ( --) ( $1 -- ) execute: ( -- a )
: variable create cell allot ; \ create: ( -- ) ( s: word -- ) execute: ( -- a )
: primitive code postpone code, ;code inline ; \ create: ( $1 -- ) ( s: word -- )
: buffer: create allot ; \ create: ( a -- ) ( s: word -- ) execute ( -- a )
' have$ alias xt inline
: noname ( -- xt ) last$ dup$ xt protect trash$ ;
\ ----- system constants ---------------------------------
' noop alias chars immediate
' noop alias cells immediate
' noop alias aligned immediate
' noop alias align immediate
' 1+ alias char+ inline
' 1+ alias cell+ inline
' 1- alias cell- inline
\ ----- arithmetics --------------------------------------
' lshift alias << ( x1 u -- x2 ) inline
' rshift alias >> ( x1 u -- x2 ) inline
: /mod ( n1 n2 -- n3 n4 ) 1 -rot */mod ; \ divisions are truncated, symmetric
: */ ( n1 n2 n3 -- n4 ) */mod nip ; inline
: / ( n1 n2 -- n3 ) /mod nip ; inline
: mod ( n1 n2 -- n3 ) /mod drop ;
: % ( n1 n2 -- n3 ) #50 */ dup 0< 1 or + 2/ ; \ percentage rounded, not truncated
: cull ( x1 x2 f -- x1|x2 ) if nip exit then drop ; transient inline
: min ( n1 n2 -- n1|n2 ) 2dup > cull ;
: max ( n1 n2 -- n1|n2 ) 2dup < cull ;
: umin ( u1 u2 -- u1|u2 ) 2dup u> cull ;
: umax ( u1 u2 -- u1|u2 ) 2dup u< cull ;
: s>d ( n -- d ) dup 0< ; inline
: within ( x low high -- flag ) over - >r - r> u< ;
: um/mod ( d u1 -- u2 u3 ) ud/mod drop ; inline \ d / u1 -> quotient u3 remainder u2
: dabs ( d1 -- d2 ) dup 0< lest dnegate ;
\ ----- memory -------------------------------------------
: kibi ( n1 -- n2 ) #10 << ; inline
bits #22 < unless : mebi ( n1 -- n2 ) #20 << ; inline
bits #32 < unless : gibi ( n1 -- n2 ) #30 << ; inline
#128 kibi cells 1- constant memend ( must be 2^u-1 ) transient \ use a configurable item instead
: unused ( -- u ) here negate memend and ;
: pad ( -- a ) here #256 + ; inline \ use a configuration item instead
: erase ( a u -- ) 0 fill ; inline \ 0 -> m[a++], u times
: scrape ( a i -- i*x ) for skim swap next drop ;
: spread ( i*x a u -- ) tuck cells +
swap for cell- tuck ! next drop ;
\ ----- i/o ----------------------------------------------
defer query$ ' simplequery$ is query$
: type ( c-addr u -- ) pack$ type$ ; inline
: ltype$ ( u -- ) ( $1 -- ) dup$ type$ count$ - spaces ;
: rtype$ ( u -- ) ( $1 -- ) dup$ count$ - spaces type$ ;
: c-addr ( -- a ) ( $1 -- ) here dup 1+ unpack$ over c! ; transient
: c-addr,u ( -- a u ) ( $1 -- ) here dup unpack$ ; transient
: parse ( c -- c-addr u ) parse$ c-addr,u ;
: parse-name ( -- c-addr u ) word$ c-addr,u ;
: source ( -- c-addr u ) "tib" env$ c-addr,u ;
: word ( c -- c-addr ) -whitespace parse$ c-addr ;
: s( ( -- c-addr u ) ')' parse ;
: .( ( -- ) ( s: delim ) ')' parse$ type$ ; immediate
: c" ( -- ) ( $1 -- ) '"' parse$ c-addr
dup postpone literal
c@ 1+ allot ; compiled
: s" ( -- ) postpone c" postpone count ; compiled
: ." ( -- ) '"' parse$
postpone literal$
postpone type$ ; compiled
\ ----- pictured number conversion -----------------------
' prepend$ alias hold inline
: holds$ ( -- ) ( $1 $2 -- $3 ) swap$ join$ ; inline
: holds ( c-addr u -- ) pack$ holds$ ; inline
: sign ( f -- ) ( $1 -- $2 ) 0< lest '-' hold ;
: # ( d1 -- d2 ) ( string: $1 -- $2 ) base @ ud/mod
rot '0 +
dup '9 u> #39 and +
hold ;
' 2drop alias #>$ inline
: <# ( -- $1 ) "" ; inline
: #s ( d1 -- d2 ) begin # 2dup or 0= until ;
: #>type ( d -- ) ( $1 -- ) #>$ type$ ; inline
: #> ( d -- ) #>$ c-addr,u ; inline
: udconvert ( ud -- ) ( -- $1 ) <# #s #>$ ;
: dconvert ( d -- ) ( -- $1 ) tuck dabs udconvert sign ;
: d. ( d -- ) dconvert type$ space ;
: ud. ( ud -- ) udconvert type$ space ;
: d.r ( d u -- ) >r dconvert r> rtype$ ;
: ud.r ( ud u -- ) >r udconvert r> rtype$ ;
' drop alias x>$ inline transient
' <# alias <x inline transient
: xs ( d -- d ) begin x dup 0= until ; inline transient
: x>type ( x -- ) ( $1 -- ) x>$ type$ ; inline transient
: x> ( x -- a n )( $1 -- ) x>$ c-addr,u ; inline transient
trash x
: uconvert ( u -- ) ( -- $1 ) <x xs x>$ ;
: convert ( n -- ) ( -- $1 ) dup abs uconvert sign ;
: . ( n -- ) convert type$ space ;
: u. ( u -- ) uconvert type$ space ;
: .r ( n u -- ) >r convert r> rtype$ ;
: u.r ( u1 u2 -- ) >r uconvert r> rtype$ ;
\ ----- files and loading --------------------------------
' satisfy alias needs: inline
\ produces execution token and removes header of last word: : foo ... ; noname
: needed ( -- f ) ( stream: word ) word$ needed$ ; inline
: have ( -- 0|xt ) ( stream: word ) word$ have$ ; inline \ word exists?
: lack ( -- flag ) ( stream: word ) have 0= ; inline \ word missing?
: ['] ( -- ) ( stream: word ) ' literal, ; compiled
\ ----- environment --------------------------------------
"environment" newwordlist$ constant environment
: environment? ( c-addr u -- false | i*x true ) environment searchwordlist
dup lest count scrape true ;
: environment! ( i*x i c-addr u -- ) here -rot environment writewordlist
dup c,
here swap dup cells allot spread ; transient
\ #255 1 s( /COUNTED-STRING) environment! \ max count of chars in a counted string
\ pad here - 1- 1 s( /HOLD) environment! \ size of the pictured numeric output string buffer, in characters
\ #4095 1 s( /PAD) environment! \ size of the scratch area pointed to by PAD, in characters
\ bits 1 s( ADDRESS-UNIT-BITS) environment! \ size of one address unit, in bits
\ false 1 s( FLOORED) environment! \ true if floored division is the default
\ #127 1 s( MAX-CHAR) environment! \ maximum value of any character in the implementation-defined character set
\ -1 msb 1- 2 s( MAX-D) environment! \ largest usable signed double number
\ -1 dup 2 s( MAX-UD) environment! \ largest usable unsigned double number
\ 4 .
\ maxint 1 s( MAX-N) environment! \ largest usable signed integer
\ maxuint 1 s( MAX-U) environment! \ largest usable unsigned integer
\ #1023 1 s( RETURN-STACK-CELLS) environment! \ maximum size of the return stack, in cells
\ #2047 1 s( STACK-CELLS) environment! \ maximum size of the data stack, in cells
\ 5 .
\ ----- unsorted -----------------------------------------
: evaluate ( c-addr u -- ) pack$ evaluate$ ; inline
: quit ( ??? -- ) warm
begin
query$ evaluate$
prompt
again ;
"cold" primitive cold
' cold alias abort
: (abort") ( ??? flag -- ??? | empty ) if type$ cr abort then drop$ ;
: abort" ( -- ) ( s: string deliited by " ) '" parse$
postpone literal$
['] (abort") compile, ; compiled
: ?abort ( f -- ) lest abort ;
\ ----- files and loading --------------------------------
' origin alias thisfile \ better symmetry with thisfile$
: once ( -- ) loaded lest done ; \ prevent reloading file
: from ( -- ) ( stream: filename ) word$ from$ ; inline
: thisfile$ ( -- ) ( -- $1 ) thisfile filename$ ; inline \ produce name of currently loaded file
\ ----- experiments --------------------------------------
done
omit
\ modify word name prior to header creation
\ background: let a word with "compiled" properties change header flags (issue 17)
: rather ( $1 -- )
>body[0]="${ss[-1]}"
drop$ ;
: foo [ "bar" rather ] me .name cr ;