3008 lines
98 KiB
Forth
3008 lines
98 KiB
Forth
\ Create the FORTH word list, which includes the name FORTH and all the primitives
|
|
CURRENT @ @ ( save the latest word in the bootstrap word list )
|
|
CREATE FORTH CURRENT @ @ , ( create FORTH with itself as the initial value )
|
|
CURRENT @ XCHG ( restore bootstrap list & get address of FORTH )
|
|
PRIMITIVE-WORDLIST @ OVER CELL - ! ( set the link field to the last primitive word )
|
|
CELL 2* + CURRENT ! ( make FORTH the current compilation word list )
|
|
|
|
\ Create the other startup word lists
|
|
\ These and FORTH will be edited later to have the DOES> effect of
|
|
\ changing the search order just like words defined with VOCABULARY
|
|
CREATE SYSTEM 0 ,
|
|
CREATE UTILITY 0 ,
|
|
CREATE LINUX 0 ,
|
|
|
|
\ Get and set the current compilation word list
|
|
: GET-CURRENT ( -- wid ) CURRENT @ ;
|
|
: SET-CURRENT ( wid -- ) CURRENT ! ;
|
|
|
|
\ Reserved for "invalid address" or "object not present"
|
|
\ Signifies (the absence of) a memory address, not a number
|
|
0 CONSTANT NULL
|
|
|
|
\ Unit suffixes, e.g. 4 KB ≡ 4096 (bytes)
|
|
: KB ( u1 -- u2 ) 10 LSHIFT ;
|
|
: MB ( u1 -- u2 ) 20 LSHIFT ;
|
|
|
|
\ Shorthand for working with cell-aligned addresses
|
|
: CELL+ ( addr1 -- addr2 ) CELL + ;
|
|
: CELL- ( addr1 -- addr2 ) CELL - ;
|
|
: CELLS+ ( addr1 n -- addr2 ) CELL * + ;
|
|
: CELLS- ( addr1 n -- addr2 ) CELL * - ;
|
|
: CELLS ( n1 -- n2 ) CELL * ;
|
|
|
|
\ Returns the least multiple of u >= the aligned u
|
|
\ The alignment u must be a power of two
|
|
: ALIGNED-TO ( addr1 u -- addr2 )
|
|
TUCK 1- + SWAP NEGATE AND ;
|
|
|
|
\ Round up to the next cell-aligned address
|
|
: ALIGNED ( addr -- a-addr ) CELL ALIGNED-TO ;
|
|
|
|
\ Return the next address in the compilation/data area
|
|
: HERE ( -- addr ) CP @ ;
|
|
|
|
\ Use this list until we get around to defining the real GET-ORDER
|
|
: STARTUP-ORDER ( -- widn ... wid1 n )
|
|
[ BOOTSTRAP-WORDLIST ] LITERAL
|
|
[ LINUX ] LITERAL
|
|
[ UTILITY ] LITERAL
|
|
[ SYSTEM ] LITERAL
|
|
[ FORTH ] LITERAL
|
|
5 ;
|
|
' STARTUP-ORDER ' BOOTSTRAP-GET-ORDER DEFER!
|
|
|
|
UTILITY SET-CURRENT
|
|
|
|
\ Field accessors for execution tokens
|
|
: >BODY ( xt -- a-addr ) [ 2 CELLS ] LITERAL + ;
|
|
: >DFA ( xt -- a-addr ) CELL+ ;
|
|
: >CFA ( xt -- a-addr ) ;
|
|
: >LINK ( xt -- a-addr ) CELL- ;
|
|
: >FLAGS ( xt -- c-addr ) [ CELL 1+ ] LITERAL - ;
|
|
: >NAME ( xt -- c-addr u ) >FLAGS DUP C@ F_LENMASK AND TUCK - SWAP ;
|
|
|
|
' FORTH >BODY SET-CURRENT
|
|
|
|
\ Given the xt of a word defined with VOCABULARY, return the word list identifier
|
|
\ This allows the use of vocabulary words with SET-ORDER or SEARCH-WORDLIST
|
|
: >WORDLIST ( vocabulary-xt -- wid ) >BODY ;
|
|
|
|
' SYSTEM >WORDLIST SET-CURRENT
|
|
|
|
\ Set the current compilation word list to the given vocabulary
|
|
: (DEFINITIONS) ( vocabulary-xt -- ) >WORDLIST SET-CURRENT ;
|
|
|
|
\ Set or clear the HIDDEN flag for word with the given execution token
|
|
: (HIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN OR SWAP C! ;
|
|
: (UNHIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN INVERT AND SWAP C! ;
|
|
|
|
\ Use GET-CURRENT and SET-CURRENT to manipulate the compilation word list
|
|
' CURRENT (HIDE)
|
|
|
|
\ This is only used during early startup
|
|
' STARTUP-ORDER (HIDE)
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
: IMMEDIATE? ( xt -- flag ) >FLAGS C@ F_IMMED AND 0<> ;
|
|
: HIDDEN? ( xt -- flag ) >FLAGS C@ F_HIDDEN AND 0<> ;
|
|
|
|
\ Decrement the array size and increment the address by the same amount
|
|
: /STRING ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ;
|
|
\ Semantically equivalent to "1 /STRING"
|
|
: 1/STRING ( c-addr u -- c-addr+1 u-1 ) 1- SWAP 1+ SWAP ;
|
|
|
|
\ Standard (ANS FORTH) THROW code assignments (-255 ... -1)
|
|
-1 CONSTANT EXCP-ABORT
|
|
-2 CONSTANT EXCP-FAIL
|
|
-3 CONSTANT EXCP-STACK-OVERFLOW
|
|
-4 CONSTANT EXCP-STACK-UNDERFLOW
|
|
-5 CONSTANT EXCP-RETURN-OVERFLOW
|
|
-6 CONSTANT EXCP-RETURN-UNDERFLOW
|
|
-8 CONSTANT EXCP-DICTIONARY-OVERFLOW
|
|
-9 CONSTANT EXCP-INVALID-ADDRESS
|
|
-12 CONSTANT EXCP-TYPE-MISMATCH
|
|
-13 CONSTANT EXCP-UNDEFINED-WORD
|
|
-17 CONSTANT EXCP-PNO-OVERFLOW
|
|
-24 CONSTANT EXCP-BAD-NUMERIC-ARGUMENT
|
|
-36 CONSTANT EXCP-NON-EXISTENT-FILE
|
|
-37 CONSTANT EXCP-FILE-IO
|
|
-39 CONSTANT EXCP-UNEXPECTED-EOF
|
|
-56 CONSTANT EXCP-QUIT
|
|
|
|
\ Non-standard system error codes (-4095 ... -256)
|
|
-256 CONSTANT EXCP-HEAP-OVERFLOW
|
|
-257 CONSTANT EXCP-DEFER-UNINITIALIZED
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
\ THROWN-STRING holds the address and size of the string passed to FAIL
|
|
\ It may also be used to hold context strings for other system exception codes
|
|
CREATE THROWN-STRING 2 CELLS ALLOT
|
|
NULL 0 THROWN-STRING 2!
|
|
|
|
\ This is called by THROW when n is nonzero
|
|
\ CATCH saves and restores the current target and substitutes its own version
|
|
\ BAILOUT will be replaced by DEFAULT-UNWIND later in the startup
|
|
DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|
' BAILOUT ' THROW-UNWIND DEFER!
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ QUIT needs to be defined after INTERPRET
|
|
DEFER QUIT
|
|
' BAILOUT ' QUIT DEFER!
|
|
|
|
\ If n is nonzero, return control to the nearest CATCH on the return stack
|
|
\ If there is no CATCH, perform the function of ABORT (clear data stack and QUIT)
|
|
\ Absent CATCH, whether a message is displayed depends on the value of n:
|
|
\ -1 (ABORT) no message
|
|
\ -2 (FAIL) the string passed to THROW-STRING
|
|
\ otherwise message is implementation-dependent
|
|
\
|
|
\ For use after CATCH; like THROW but doesn't change the string
|
|
\ Also, if n is EXCP-QUIT then invokes QUIT for special handling (keeps data stack)
|
|
: RETHROW ( k*x n -- k*x | i*x n <noreturn> )
|
|
?DUP IF DUP EXCP-QUIT = IF QUIT THEN THROW-UNWIND THEN ;
|
|
\ THROW while storing a string for context
|
|
: THROW-STRING ( k*x n c-addr u -- k*x | i*x n <noreturn> )
|
|
2>R ?DUP IF 2R> THROWN-STRING 2! THROW-UNWIND ELSE 2RDROP THEN ;
|
|
\ Basic THROW without any string (store an empty string)
|
|
: THROW ( k*x n -- k*x | i*x n <noreturn> )
|
|
"" THROW-STRING ;
|
|
|
|
\ By default, clear the data stack and QUIT without any message
|
|
\ This behavior can be overridden with CATCH
|
|
: ABORT ( i*x -- R: j*x -- ) EXCP-ABORT THROW ;
|
|
|
|
\ Display a message and ABORT
|
|
\ This behavior can be overridden with CATCH
|
|
: FAIL ( c-addr u -- <none> | <noreturn> )
|
|
EXCP-FAIL -ROT THROW-STRING ;
|
|
|
|
\ If flag is non-zero, display a message and ABORT
|
|
\ This behavior can be overridden with CATCH
|
|
: ?FAIL ( flag c-addr u -- <none> | <noreturn> )
|
|
ROT IF FAIL ELSE 2DROP THEN ;
|
|
|
|
: …TODO… "not implemented" FAIL ;
|
|
|
|
\ Get the execution token of the most recent word in the compilation word list
|
|
\ If the word list is empty the result will be zero
|
|
: LATEST ( -- xt | NULL ) GET-CURRENT @ ;
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
\ Set the given xt as the most recent word in the compilation word list
|
|
\ Since this replaces the head of a linked list it may affect the entire list,
|
|
\ not just the most recent word
|
|
: LATEST! ( xt -- ) GET-CURRENT ! ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Set the latest defined word as immediate
|
|
\ Note that IMMEDIATE is itself an immediate word
|
|
: IMMEDIATE LATEST >FLAGS DUP C@ F_IMMED OR SWAP C! ; IMMEDIATE
|
|
|
|
\ Switch from compiling to interpreting, or vice-versa
|
|
: [ IMMEDIATE FALSE STATE ! ;
|
|
: ] IMMEDIATE TRUE STATE ! ;
|
|
|
|
\ Just a visual separator, no compilation or runtime effect
|
|
: ▪ IMMEDIATE ;
|
|
|
|
\ Returns the least power of two greater than or equal to u1
|
|
: NATURALLY-ALIGNED ( u1 -- u2 )
|
|
1- ▪ DUP U2/ OR ▪ DUP 2 RSHIFT OR ▪ DUP 4 RSHIFT OR
|
|
▪ DUP 8 RSHIFT OR ▪ DUP 16 RSHIFT OR ▪ 1+ ;
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
: DEFERRED? ( xt -- ) >CFA @ ▪ DODEFER <> ▪ EXCP-TYPE-MISMATCH AND ▪ THROW ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Fetch and store the target of the deferred word denoted by deferred-xt
|
|
: DEFER@ ( deferred-xt -- xt ) DUP DEFERRED? ▪ >DFA @ ;
|
|
: DEFER! ( xt deferred-xt -- ) DUP DEFERRED? ▪ >DFA ! ;
|
|
|
|
' LINUX (DEFINITIONS)
|
|
|
|
\ Next we'll be defining a lot of constants for system calls and other ABI data
|
|
\ CONSTANT is still a bootstrap word here, but ⇒ is just temporary
|
|
: ⇒ [ ' CONSTANT , ] ;
|
|
|
|
\ x86 system call numbers
|
|
1 ⇒ SYS_EXIT
|
|
2 ⇒ SYS_FORK
|
|
3 ⇒ SYS_READ
|
|
4 ⇒ SYS_WRITE
|
|
6 ⇒ SYS_CLOSE
|
|
7 ⇒ SYS_WAITPID
|
|
12 ⇒ SYS_CHDIR
|
|
13 ⇒ SYS_TIME
|
|
15 ⇒ SYS_CHMOD
|
|
20 ⇒ SYS_GETPID
|
|
21 ⇒ SYS_MOUNT
|
|
25 ⇒ SYS_STIME
|
|
26 ⇒ SYS_PTRACE
|
|
27 ⇒ SYS_ALARM
|
|
29 ⇒ SYS_PAUSE
|
|
30 ⇒ SYS_UTIME
|
|
33 ⇒ SYS_ACCESS
|
|
34 ⇒ SYS_NICE
|
|
36 ⇒ SYS_SYNC
|
|
37 ⇒ SYS_KILL
|
|
40 ⇒ SYS_RMDIR
|
|
41 ⇒ SYS_DUP
|
|
43 ⇒ SYS_TIMES
|
|
45 ⇒ SYS_BRK
|
|
48 ⇒ SYS_SIGNAL
|
|
52 ⇒ SYS_UMOUNT2
|
|
54 ⇒ SYS_IOCTL
|
|
57 ⇒ SYS_SETPGID
|
|
60 ⇒ SYS_UMASK
|
|
61 ⇒ SYS_CHROOT
|
|
62 ⇒ SYS_USTAT
|
|
64 ⇒ SYS_GETPPID
|
|
65 ⇒ SYS_GETPGRP
|
|
66 ⇒ SYS_SETSID
|
|
68 ⇒ SYS_SGETMASK
|
|
69 ⇒ SYS_SSETMASK
|
|
74 ⇒ SYS_SETHOSTNAME
|
|
75 ⇒ SYS_SETRLIMIT
|
|
76 ⇒ SYS_GETRLIMIT
|
|
77 ⇒ SYS_GETRUSAGE
|
|
78 ⇒ SYS_GETTIMEOFDAY
|
|
79 ⇒ SYS_SETTIMEOFDAY
|
|
82 ⇒ SYS_SELECT
|
|
87 ⇒ SYS_SWAPON
|
|
88 ⇒ SYS_REBOOT
|
|
89 ⇒ SYS_READDIR
|
|
91 ⇒ SYS_MUNMAP
|
|
96 ⇒ SYS_GETPRIORITY
|
|
97 ⇒ SYS_SETPRIORITY
|
|
101 ⇒ SYS_IOPERM
|
|
103 ⇒ SYS_SYSLOG
|
|
104 ⇒ SYS_SETITIMER
|
|
105 ⇒ SYS_GETITIMER
|
|
110 ⇒ SYS_IOPL
|
|
111 ⇒ SYS_VHANGUP
|
|
112 ⇒ SYS_IDLE
|
|
114 ⇒ SYS_WAIT4
|
|
115 ⇒ SYS_SWAPOFF
|
|
116 ⇒ SYS_SYSINFO
|
|
117 ⇒ SYS_IPC
|
|
118 ⇒ SYS_FSYNC
|
|
121 ⇒ SYS_SETDOMAINNAME
|
|
122 ⇒ SYS_UNAME
|
|
123 ⇒ SYS_MODIFY_LDT
|
|
124 ⇒ SYS_ADJTIMEX
|
|
125 ⇒ SYS_MPROTECT
|
|
128 ⇒ SYS_INIT_MODULE
|
|
129 ⇒ SYS_DELETE_MODULE
|
|
131 ⇒ SYS_QUOTACTL
|
|
132 ⇒ SYS_GETPGID
|
|
133 ⇒ SYS_FCHDIR
|
|
135 ⇒ SYS_SYSFS
|
|
136 ⇒ SYS_PERSONALITY
|
|
140 ⇒ SYS__LLSEEK
|
|
142 ⇒ SYS__NEWSELECT
|
|
143 ⇒ SYS_FLOCK
|
|
144 ⇒ SYS_MSYNC
|
|
145 ⇒ SYS_READV
|
|
146 ⇒ SYS_WRITEV
|
|
147 ⇒ SYS_GETSID
|
|
148 ⇒ SYS_FDATASYNC
|
|
149 ⇒ SYS__SYSCTL
|
|
151 ⇒ SYS_MUNLOCK
|
|
152 ⇒ SYS_MLOCKALL
|
|
153 ⇒ SYS_MUNLOCKALL
|
|
154 ⇒ SYS_SCHED_SETPARAM
|
|
155 ⇒ SYS_SCHED_GETPARAM
|
|
156 ⇒ SYS_SCHED_SETSCHEDULER
|
|
157 ⇒ SYS_SCHED_GETSCHEDULER
|
|
158 ⇒ SYS_SCHED_YIELD
|
|
159 ⇒ SYS_SCHED_GET_PRIORITY_MAX
|
|
160 ⇒ SYS_SCHED_GET_PRIORITY_MIN
|
|
162 ⇒ SYS_NANOSLEEP
|
|
163 ⇒ SYS_MREMAP
|
|
166 ⇒ SYS_VM86
|
|
168 ⇒ SYS_POLL
|
|
172 ⇒ SYS_PRCTL
|
|
173 ⇒ SYS_RT_SIGRETURN
|
|
174 ⇒ SYS_RT_SIGACTION
|
|
175 ⇒ SYS_RT_SIGPROCMASK
|
|
176 ⇒ SYS_RT_SIGPENDING
|
|
178 ⇒ SYS_RT_SIGQUEUEINFO
|
|
179 ⇒ SYS_RT_SIGSUSPEND
|
|
180 ⇒ SYS_PREAD64
|
|
181 ⇒ SYS_PWRITE64
|
|
183 ⇒ SYS_GETCWD
|
|
184 ⇒ SYS_CAPGET
|
|
185 ⇒ SYS_CAPSET
|
|
186 ⇒ SYS_SIGALTSTACK
|
|
190 ⇒ SYS_VFORK
|
|
192 ⇒ SYS_MMAP2
|
|
193 ⇒ SYS_TRUNCATE64
|
|
194 ⇒ SYS_FTRUNCATE64
|
|
195 ⇒ SYS_STAT64
|
|
196 ⇒ SYS_LSTAT64
|
|
198 ⇒ SYS_LCHOWN32
|
|
199 ⇒ SYS_GETUID32
|
|
200 ⇒ SYS_GETGID32
|
|
201 ⇒ SYS_GETEUID32
|
|
202 ⇒ SYS_GETEGID32
|
|
203 ⇒ SYS_SETREUID32
|
|
204 ⇒ SYS_SETREGID32
|
|
205 ⇒ SYS_GETGROUPS32
|
|
206 ⇒ SYS_SETGROUPS32
|
|
208 ⇒ SYS_SETRESUID32
|
|
209 ⇒ SYS_GETRESUID32
|
|
210 ⇒ SYS_SETRESGID32
|
|
211 ⇒ SYS_GETRESGID32
|
|
212 ⇒ SYS_CHOWN32
|
|
213 ⇒ SYS_SETUID32
|
|
214 ⇒ SYS_SETGID32
|
|
215 ⇒ SYS_SETFSUID32
|
|
216 ⇒ SYS_SETFSGID32
|
|
217 ⇒ SYS_PIVOT_ROOT
|
|
218 ⇒ SYS_MINCORE
|
|
219 ⇒ SYS_MADVISE
|
|
220 ⇒ SYS_GETDENTS64
|
|
221 ⇒ SYS_FCNTL64
|
|
224 ⇒ SYS_GETTID
|
|
225 ⇒ SYS_READAHEAD
|
|
226 ⇒ SYS_SETXATTR
|
|
227 ⇒ SYS_LSETXATTR
|
|
228 ⇒ SYS_FSETXATTR
|
|
229 ⇒ SYS_GETXATTR
|
|
230 ⇒ SYS_LGETXATTR
|
|
231 ⇒ SYS_FGETXATTR
|
|
232 ⇒ SYS_LISTXATTR
|
|
233 ⇒ SYS_LLISTXATTR
|
|
234 ⇒ SYS_FLISTXATTR
|
|
235 ⇒ SYS_REMOVEXATTR
|
|
236 ⇒ SYS_LREMOVEXATTR
|
|
237 ⇒ SYS_FREMOVEXATTR
|
|
239 ⇒ SYS_SENDFILE64
|
|
241 ⇒ SYS_SCHED_SETAFFINITY
|
|
242 ⇒ SYS_SCHED_GETAFFINITY
|
|
243 ⇒ SYS_SET_THREAD_AREA
|
|
244 ⇒ SYS_GET_THREAD_AREA
|
|
245 ⇒ SYS_IO_SETUP
|
|
246 ⇒ SYS_IO_DESTROY
|
|
247 ⇒ SYS_IO_GETEVENTS
|
|
248 ⇒ SYS_IO_SUBMIT
|
|
249 ⇒ SYS_IO_CANCEL
|
|
252 ⇒ SYS_EXIT_GROUP
|
|
253 ⇒ SYS_LOOKUP_DCOOKIE
|
|
255 ⇒ SYS_EPOLL_CTL
|
|
256 ⇒ SYS_EPOLL_WAIT
|
|
257 ⇒ SYS_REMAP_FILE_PAGES
|
|
258 ⇒ SYS_SET_TID_ADDRESS
|
|
259 ⇒ SYS_TIMER_CREATE
|
|
262 ⇒ SYS_TIMER_GETOVERRUN
|
|
263 ⇒ SYS_TIMER_DELETE
|
|
268 ⇒ SYS_STATFS64
|
|
269 ⇒ SYS_FSTATFS64
|
|
270 ⇒ SYS_TGKILL
|
|
271 ⇒ SYS_UTIMES
|
|
272 ⇒ SYS_FADVISE64_64
|
|
274 ⇒ SYS_MBIND
|
|
275 ⇒ SYS_GET_MEMPOLICY
|
|
276 ⇒ SYS_SET_MEMPOLICY
|
|
277 ⇒ SYS_MQ_OPEN
|
|
278 ⇒ SYS_MQ_UNLINK
|
|
281 ⇒ SYS_MQ_NOTIFY
|
|
282 ⇒ SYS_MQ_GETSETATTR
|
|
283 ⇒ SYS_KEXEC_LOAD
|
|
284 ⇒ SYS_WAITID
|
|
286 ⇒ SYS_ADD_KEY
|
|
287 ⇒ SYS_REQUEST_KEY
|
|
288 ⇒ SYS_KEYCTL
|
|
289 ⇒ SYS_IOPRIO_SET
|
|
290 ⇒ SYS_IOPRIO_GET
|
|
292 ⇒ SYS_INOTIFY_ADD_WATCH
|
|
293 ⇒ SYS_INOTIFY_RM_WATCH
|
|
294 ⇒ SYS_MIGRATE_PAGES
|
|
296 ⇒ SYS_MKDIRAT
|
|
297 ⇒ SYS_MKNODAT
|
|
298 ⇒ SYS_FCHOWNAT
|
|
299 ⇒ SYS_FUTIMESAT
|
|
300 ⇒ SYS_FSTATAT64
|
|
301 ⇒ SYS_UNLINKAT
|
|
303 ⇒ SYS_LINKAT
|
|
304 ⇒ SYS_SYMLINKAT
|
|
305 ⇒ SYS_READLINKAT
|
|
306 ⇒ SYS_FCHMODAT
|
|
310 ⇒ SYS_UNSHARE
|
|
311 ⇒ SYS_SET_ROBUST_LIST
|
|
312 ⇒ SYS_GET_ROBUST_LIST
|
|
313 ⇒ SYS_SPLICE
|
|
314 ⇒ SYS_SYNC_FILE_RANGE
|
|
315 ⇒ SYS_TEE
|
|
316 ⇒ SYS_VMSPLICE
|
|
317 ⇒ SYS_MOVE_PAGES
|
|
318 ⇒ SYS_GETCPU
|
|
319 ⇒ SYS_EPOLL_PWAIT
|
|
322 ⇒ SYS_TIMERFD_CREATE
|
|
324 ⇒ SYS_FALLOCATE
|
|
327 ⇒ SYS_SIGNALFD4
|
|
328 ⇒ SYS_EVENTFD2
|
|
329 ⇒ SYS_EPOLL_CREATE1
|
|
330 ⇒ SYS_DUP3
|
|
331 ⇒ SYS_PIPE2
|
|
332 ⇒ SYS_INOTIFY_INIT1
|
|
335 ⇒ SYS_RT_TGSIGQUEUEINFO
|
|
336 ⇒ SYS_PERF_EVENT_OPEN
|
|
338 ⇒ SYS_FANOTIFY_INIT
|
|
339 ⇒ SYS_FANOTIFY_MARK
|
|
340 ⇒ SYS_PRLIMIT64
|
|
341 ⇒ SYS_NAME_TO_HANDLE_AT
|
|
342 ⇒ SYS_OPEN_BY_HANDLE_AT
|
|
344 ⇒ SYS_SYNCFS
|
|
345 ⇒ SYS_SENDMMSG
|
|
346 ⇒ SYS_SETNS
|
|
347 ⇒ SYS_PROCESS_VM_READV
|
|
348 ⇒ SYS_PROCESS_VM_WRITEV
|
|
349 ⇒ SYS_KCMP
|
|
350 ⇒ SYS_FINIT_MODULE
|
|
351 ⇒ SYS_SCHED_SETATTR
|
|
352 ⇒ SYS_SCHED_GETATTR
|
|
353 ⇒ SYS_RENAMEAT2
|
|
354 ⇒ SYS_SECCOMP
|
|
355 ⇒ SYS_GETRANDOM
|
|
356 ⇒ SYS_MEMFD_CREATE
|
|
357 ⇒ SYS_BPF
|
|
358 ⇒ SYS_EXECVEAT
|
|
359 ⇒ SYS_SOCKET
|
|
360 ⇒ SYS_SOCKETPAIR
|
|
361 ⇒ SYS_BIND
|
|
362 ⇒ SYS_CONNECT
|
|
363 ⇒ SYS_LISTEN
|
|
364 ⇒ SYS_ACCEPT4
|
|
365 ⇒ SYS_GETSOCKOPT
|
|
366 ⇒ SYS_SETSOCKOPT
|
|
367 ⇒ SYS_GETSOCKNAME
|
|
368 ⇒ SYS_GETPEERNAME
|
|
369 ⇒ SYS_SENDTO
|
|
370 ⇒ SYS_SENDMSG
|
|
371 ⇒ SYS_RECVFROM
|
|
372 ⇒ SYS_RECVMSG
|
|
373 ⇒ SYS_SHUTDOWN
|
|
374 ⇒ SYS_USERFAULTFD
|
|
375 ⇒ SYS_MEMBARRIER
|
|
376 ⇒ SYS_MLOCK2
|
|
377 ⇒ SYS_COPY_FILE_RANGE
|
|
378 ⇒ SYS_PREADV2
|
|
379 ⇒ SYS_PWRITEV2
|
|
380 ⇒ SYS_PKEY_MPROTECT
|
|
381 ⇒ SYS_PKEY_ALLOC
|
|
382 ⇒ SYS_PKEY_FREE
|
|
383 ⇒ SYS_STATX
|
|
384 ⇒ SYS_ARCH_PRCTL
|
|
386 ⇒ SYS_RSEQ
|
|
393 ⇒ SYS_SEMGET
|
|
394 ⇒ SYS_SEMCTL
|
|
395 ⇒ SYS_SHMGET
|
|
396 ⇒ SYS_SHMCTL
|
|
397 ⇒ SYS_SHMAT
|
|
398 ⇒ SYS_SHMDT
|
|
399 ⇒ SYS_MSGGET
|
|
400 ⇒ SYS_MSGSND
|
|
401 ⇒ SYS_MSGRCV
|
|
402 ⇒ SYS_MSGCTL
|
|
403 ⇒ SYS_CLOCK_GETTIME64
|
|
404 ⇒ SYS_CLOCK_SETTIME64
|
|
405 ⇒ SYS_CLOCK_ADJTIME64
|
|
406 ⇒ SYS_CLOCK_GETRES_TIME64
|
|
407 ⇒ SYS_CLOCK_NANOSLEEP_TIME64
|
|
408 ⇒ SYS_TIMER_GETTIME64
|
|
409 ⇒ SYS_TIMER_SETTIME64
|
|
410 ⇒ SYS_TIMERFD_GETTIME64
|
|
411 ⇒ SYS_TIMERFD_SETTIME64
|
|
412 ⇒ SYS_UTIMENSAT_TIME64
|
|
413 ⇒ SYS_PSELECT6_TIME64
|
|
414 ⇒ SYS_PPOLL_TIME64
|
|
416 ⇒ SYS_IO_PGETEVENTS_TIME64
|
|
417 ⇒ SYS_RECVMMSG_TIME64
|
|
418 ⇒ SYS_MQ_TIMEDSEND_TIME64
|
|
419 ⇒ SYS_MQ_TIMEDRECEIVE_TIME64
|
|
420 ⇒ SYS_SEMTIMEDOP_TIME64
|
|
421 ⇒ SYS_RT_SIGTIMEDWAIT_TIME64
|
|
422 ⇒ SYS_FUTEX_TIME64
|
|
423 ⇒ SYS_SCHED_RR_GET_INTERVAL_TIME64
|
|
424 ⇒ SYS_PIDFD_SEND_SIGNAL
|
|
425 ⇒ SYS_IO_URING_SETUP
|
|
426 ⇒ SYS_IO_URING_ENTER
|
|
427 ⇒ SYS_IO_URING_REGISTER
|
|
428 ⇒ SYS_OPEN_TREE
|
|
429 ⇒ SYS_MOVE_MOUNT
|
|
430 ⇒ SYS_FSOPEN
|
|
431 ⇒ SYS_FSCONFIG
|
|
432 ⇒ SYS_FSMOUNT
|
|
433 ⇒ SYS_FSPICK
|
|
434 ⇒ SYS_PIDFD_OPEN
|
|
435 ⇒ SYS_CLONE3
|
|
437 ⇒ SYS_OPENAT2
|
|
438 ⇒ SYS_PIDFD_GETFD
|
|
439 ⇒ SYS_FACCESSAT2
|
|
|
|
\ Special dirfd for *at syscalls to resolve path relative to current directory
|
|
-100 ⇒ AT_FDCWD
|
|
|
|
\ Common flags for *at syscalls
|
|
1 8 LSHIFT ⇒ AT_SYMLINK_NOFOLLOW
|
|
1 9 LSHIFT ⇒ AT_REMOVEDIR ( only for unlinkat )
|
|
1 9 LSHIFT ⇒ AT_EACCESS ( only for faccessat )
|
|
1 10 LSHIFT ⇒ AT_SYMLINK_FOLLOW
|
|
1 11 LSHIFT ⇒ AT_NO_AUTOMOUNT
|
|
1 12 LSHIFT ⇒ AT_EMPTY_PATH
|
|
3 13 LSHIFT ⇒ AT_STATX_SYNC_TYPE ( mask )
|
|
1 15 LSHIFT ⇒ AT_RECURSIVE
|
|
|
|
\ Sync types for statx
|
|
0 13 LSHIFT ⇒ AT_STATX_SYNC_AS_STAT
|
|
1 13 LSHIFT ⇒ AT_STATX_FORCE_SYNC
|
|
2 13 LSHIFT ⇒ AT_STATX_DONT_SYNC
|
|
|
|
\ errno values
|
|
\ System calls return -errno in the range [-4095, -1]
|
|
1 ⇒ ERRNO_EPERM
|
|
2 ⇒ ERRNO_ENOENT
|
|
3 ⇒ ERRNO_ESRCH
|
|
4 ⇒ ERRNO_EINTR
|
|
5 ⇒ ERRNO_EIO
|
|
6 ⇒ ERRNO_ENXIO
|
|
7 ⇒ ERRNO_E2BIG
|
|
8 ⇒ ERRNO_ENOEXEC
|
|
9 ⇒ ERRNO_EBADF
|
|
10 ⇒ ERRNO_ECHILD
|
|
11 ⇒ ERRNO_EAGAIN
|
|
12 ⇒ ERRNO_ENOMEM
|
|
13 ⇒ ERRNO_EACCES
|
|
14 ⇒ ERRNO_EFAULT
|
|
15 ⇒ ERRNO_ENOTBLK
|
|
16 ⇒ ERRNO_EBUSY
|
|
17 ⇒ ERRNO_EEXIST
|
|
18 ⇒ ERRNO_EXDEV
|
|
19 ⇒ ERRNO_ENODEV
|
|
20 ⇒ ERRNO_ENOTDIR
|
|
21 ⇒ ERRNO_EISDIR
|
|
22 ⇒ ERRNO_EINVAL
|
|
23 ⇒ ERRNO_ENFILE
|
|
24 ⇒ ERRNO_EMFILE
|
|
25 ⇒ ERRNO_ENOTTY
|
|
26 ⇒ ERRNO_ETXTBSY
|
|
27 ⇒ ERRNO_EFBIG
|
|
28 ⇒ ERRNO_ENOSPC
|
|
29 ⇒ ERRNO_ESPIPE
|
|
30 ⇒ ERRNO_EROFS
|
|
31 ⇒ ERRNO_EMLINK
|
|
32 ⇒ ERRNO_EPIPE
|
|
33 ⇒ ERRNO_EDOM
|
|
34 ⇒ ERRNO_ERANGE
|
|
|
|
\ signal numbers
|
|
1 ⇒ SIGHUP
|
|
2 ⇒ SIGINT
|
|
3 ⇒ SIGQUIT
|
|
4 ⇒ SIGILL
|
|
5 ⇒ SIGTRAP
|
|
6 ⇒ SIGABRT
|
|
6 ⇒ SIGIOT
|
|
7 ⇒ SIGBUS
|
|
8 ⇒ SIGFPE
|
|
9 ⇒ SIGKILL
|
|
10 ⇒ SIGUSR1
|
|
11 ⇒ SIGSEGV
|
|
12 ⇒ SIGUSR2
|
|
13 ⇒ SIGPIPE
|
|
14 ⇒ SIGALRM
|
|
15 ⇒ SIGTERM
|
|
16 ⇒ SIGSTKFLT
|
|
17 ⇒ SIGCHLD
|
|
18 ⇒ SIGCONT
|
|
19 ⇒ SIGSTOP
|
|
20 ⇒ SIGTSTP
|
|
21 ⇒ SIGTTIN
|
|
22 ⇒ SIGTTOU
|
|
23 ⇒ SIGURG
|
|
24 ⇒ SIGXCPU
|
|
25 ⇒ SIGXFSZ
|
|
26 ⇒ SIGVTALRM
|
|
27 ⇒ SIGPROF
|
|
28 ⇒ SIGWINCH
|
|
29 ⇒ SIGIO
|
|
29 ⇒ SIGPOLL
|
|
30 ⇒ SIGPWR
|
|
31 ⇒ SIGSYS
|
|
|
|
\ openat2() access modes
|
|
0 ⇒ O_RDONLY
|
|
1 ⇒ O_WRONLY
|
|
2 ⇒ O_RDWR
|
|
|
|
\ openat2() flags
|
|
1 6 LSHIFT ⇒ O_CREAT
|
|
1 7 LSHIFT ⇒ O_EXCL
|
|
1 8 LSHIFT ⇒ O_NOCTTY
|
|
1 9 LSHIFT ⇒ O_TRUNC
|
|
1 10 LSHIFT ⇒ O_APPEND
|
|
1 11 LSHIFT ⇒ O_NONBLOCK
|
|
1 12 LSHIFT ⇒ O_DSYNC
|
|
1 13 LSHIFT ⇒ FASYNC
|
|
1 14 LSHIFT ⇒ O_DIRECT
|
|
1 15 LSHIFT ⇒ O_LARGEFILE
|
|
1 16 LSHIFT ⇒ O_DIRECTORY
|
|
1 17 LSHIFT ⇒ O_NOFOLLOW
|
|
1 18 LSHIFT ⇒ O_NOATIME
|
|
1 19 LSHIFT ⇒ O_CLOEXEC
|
|
1 20 LSHIFT ⇒ __O_SYNC
|
|
1 21 LSHIFT ⇒ O_PATH
|
|
1 22 LSHIFT ⇒ __O_TMPFILE
|
|
|
|
__O_SYNC O_DSYNC OR ⇒ O_SYNC
|
|
__O_TMPFILE O_DIRECTORY OR ⇒ O_TMPFILE
|
|
|
|
\ Achor location for whence argument to _llseek
|
|
0 ⇒ SEEK_SET
|
|
1 ⇒ SEEK_CUR
|
|
2 ⇒ SEEK_END
|
|
|
|
\ Names for the standard file descriptor numbers
|
|
0 ⇒ STDIN
|
|
1 ⇒ STDOUT
|
|
2 ⇒ STDERR
|
|
|
|
\ Hide ⇒ since it depends on the bootstrap CONSTANT
|
|
' ⇒ (HIDE)
|
|
|
|
\ Generic wrapper that will retry any system call on EINTR
|
|
: SYSCALL-RETRY ( xu ... x1 sc xt n -- x )
|
|
1+ 1+ N>R NULL BEGIN DROP NR@ DROP EXECUTE DUP ERRNO_EINTR + UNTIL NR> NDROP ;
|
|
|
|
\ Specializations for specific numbers of parameters
|
|
: SYSCALL0-RETRY [ ' SYSCALL0 ] LITERAL 0 SYSCALL-RETRY ;
|
|
: SYSCALL1-RETRY [ ' SYSCALL1 ] LITERAL 1 SYSCALL-RETRY ;
|
|
: SYSCALL2-RETRY [ ' SYSCALL2 ] LITERAL 2 SYSCALL-RETRY ;
|
|
: SYSCALL3-RETRY [ ' SYSCALL3 ] LITERAL 3 SYSCALL-RETRY ;
|
|
: SYSCALL4-RETRY [ ' SYSCALL4 ] LITERAL 4 SYSCALL-RETRY ;
|
|
: SYSCALL5-RETRY [ ' SYSCALL5 ] LITERAL 5 SYSCALL-RETRY ;
|
|
: SYSCALL6-RETRY [ ' SYSCALL6 ] LITERAL 6 SYSCALL-RETRY ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Write a character array to the given file descriptor
|
|
\ Repeat write syscall until entire string is written
|
|
\ Abandon output on any error other than EINTR
|
|
: TYPE-FD ( c-addr u fd -- fd: "ccc" )
|
|
>R ▪ BEGIN ?DUP WHILE
|
|
2DUP R@ -ROT SYS_WRITE SYSCALL3-RETRY DUP 0<= IF 2DROP RDROP EXIT THEN
|
|
/STRING REPEAT ▪ DROP RDROP ;
|
|
|
|
\ Specializations for output to stdout and stderr
|
|
: TYPE ( c-addr u -- "ccc" ) STDOUT TYPE-FD ;
|
|
: TYPE-ERR ( c-addr u -- stderr: "ccc" ) STDERR TYPE-FD ;
|
|
|
|
\ Write one character to FD 1 (stdout)
|
|
: EMIT ( c -- "c" ) SP@ 2DUP C! 1 TYPE DROP ;
|
|
|
|
\ Convert from a double-cell signed number to a single-cell signed number
|
|
\ For 2's complement this is just DROP but e.g. sign-magnitude would require more
|
|
\ For unsigned numbers just use DROP
|
|
: D>S ( d -- n ) DROP ;
|
|
|
|
\ Separate the division and modulus operators
|
|
: /MOD ( n1 n2 -- n1%n2 n1/n2 ) >R S>D R> FM/MOD D>S ;
|
|
: / ( n1 n2 -- n1/n2 ) >R S>D R> FM/MOD D>S NIP ;
|
|
: MOD ( n1 n2 -- n1%n2 ) >R S>D R> FM/MOD 2DROP ;
|
|
|
|
\ Single-cell unsigned division and modulus
|
|
: U/MOD ( u1 u2 -- u1%u2 u1/u2 ) 0 SWAP UM/MOD DROP ;
|
|
: U/ ( u1 u2 -- u1/u2 ) 0 SWAP UM/MOD DROP NIP ;
|
|
: UMOD ( u1 u2 -- u1%u2 ) 0 SWAP UM/MOD 2DROP ;
|
|
|
|
\ Symmetric division and remainder
|
|
: SM/REM ( d1 n1 -- d1%n1 d1/n1 )
|
|
DUP >R FM/MOD DUP IF OVER 0< IF 1+ SWAP R> - SWAP ELSE RDROP THEN THEN ;
|
|
|
|
\ Signed minimum and maximum
|
|
: MIN ( n1 n2 -- n1|n2 ) 2DUP > IF NIP ELSE DROP THEN ;
|
|
: MAX ( n1 n2 -- n1|n2 ) 2DUP < IF NIP ELSE DROP THEN ;
|
|
|
|
\ Unsigned minimum and maximum
|
|
: UMIN ( u1 u2 -- u1|n2 ) 2DUP U> IF NIP ELSE DROP THEN ;
|
|
: UMAX ( u1 u2 -- u1|n2 ) 2DUP U< IF NIP ELSE DROP THEN ;
|
|
|
|
\ Return -1, 0, or 1 if n is respectively negative, zero, or positive
|
|
: SIGNUM ( n -- -1 | 0 | 1 ) DUP 0<= SWAP 0>= - ;
|
|
|
|
\ Return -1, 0, or 1 if n1|u1 is less than, equal to, or greater than n2|u2
|
|
: <=> ( n1 n2 -- -1 | 0 | 1 ) 2DUP < -ROT > - ;
|
|
: U<=> ( u1 u2 -- -1 | 0 | 1 ) 2DUP U< -ROT U> - ;
|
|
|
|
\ True if n1 >= n2 && n1 <= n3, false otherwise
|
|
: WITHIN ( n1|u1 n2|u2 n3|u3 -- flag ) OVER - -ROT - U> ;
|
|
|
|
\ Double-cell versions of standard numeric words
|
|
: DABS ( d -- +d ) 2DUP D0< IF DNEGATE THEN ;
|
|
: DMIN ( d1 d2 -- d1|d2 ) 2OVER 2OVER D> IF 2SWAP THEN 2DROP ;
|
|
: DMAX ( d1 d2 -- d1|d2 ) 2OVER 2OVER D< IF 2SWAP THEN 2DROP ;
|
|
: DUMIN ( ud1 ud2 -- ud1|ud2 ) 2OVER 2OVER DU> IF 2SWAP THEN 2DROP ;
|
|
: DUMAX ( ud1 ud2 -- ud1|ud2 ) 2OVER 2OVER DU< IF 2SWAP THEN 2DROP ;
|
|
: DSIGNUM ( d -- -1 | 0 | 1 ) 2DUP D0= IF DROP ELSE D0< 2 * 1+ THEN ;
|
|
|
|
\ Return -1, 0, or 1 if d1|ud1 is less than, equal to, or greater than d2|ud2
|
|
: D<=> ( d1 d2 -- -1 | 0 | 1 ) 2OVER 2OVER D> >R D< R> - ;
|
|
: DU<=> ( ud1 ud2 -- -1 | 0 | 1 ) 2OVER 2OVER DU> >R DU< R> - ;
|
|
|
|
\ Define names for the whitespace characters
|
|
8 CONSTANT HT \ Horizontal Tab
|
|
10 CONSTANT LF \ Line Feed (newline)
|
|
11 CONSTANT VT \ Vertical Tab
|
|
12 CONSTANT FF \ Form Feed
|
|
13 CONSTANT CR \ Carriage Return
|
|
32 CONSTANT BL \ BLank (space)
|
|
|
|
\ Test whether the given character is whitespace (HT, LF, VT, FF, CR, or BL)
|
|
\ Note that HT, LF, VT, FF, and CR together form the range 9 ... 13 inclusive
|
|
: SPACE? ( c -- flag )
|
|
DUP BL = IF DROP TRUE EXIT THEN
|
|
9 - [ 13 9 - ] LITERAL U<= ;
|
|
|
|
\ Emit a blank (space) character
|
|
: SPACE ( -- "<space>" ) BL EMIT ;
|
|
|
|
\ Emit a horizontal tab character
|
|
: TAB ( -- "<tab>" ) HT EMIT ;
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
\ The implementation-dependent End-of-Line string
|
|
\ Here this is just a LF (Unix convention) but it could be CR (Mac) or CR+LF (DOS)
|
|
: (EOL) ( -- c-addr u ) "\n" ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Emit the implementation-dependent End-of-Line string
|
|
: EOL ( -- "<eol>" ) (EOL) TYPE ;
|
|
|
|
\ Emit n blank (space) characters
|
|
: SPACES ( n -- "<spaces>" ) BEGIN ?DUP WHILE 1- SPACE REPEAT ;
|
|
|
|
\ Terminate the program, successfully
|
|
\ This will never return, even if the system call does
|
|
: BYE ( -- <noreturn> )
|
|
BEGIN 0 SYS_EXIT SYSCALL1 DROP AGAIN ;
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
\ When growing the data area, round the end address up to a multiple of this size
|
|
65536 CONSTANT DATA-SEGMENT-ALIGNMENT
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Allocate n consecutive bytes from the end of the data area
|
|
\ If necessary use the brk system call to grow the data area
|
|
\ The value n can be negative to release the most recently allocated space
|
|
: ALLOT ( n -- )
|
|
DUP 0< IF
|
|
DUP C0 HERE - < IF EXCP-BAD-NUMERIC-ARGUMENT THROW THEN
|
|
ELSE
|
|
DUP HERE INVERT U> IF EXCP-DICTIONARY-OVERFLOW THROW THEN
|
|
THEN
|
|
HERE + DUP BRK @ U> IF
|
|
[ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND
|
|
DUP SYS_BRK SYSCALL1-RETRY OVER <> IF EXCP-DICTIONARY-OVERFLOW THROW THEN
|
|
BRK !
|
|
THEN
|
|
CP ! ;
|
|
|
|
\ Only use this version of ALLOT from here on
|
|
' ALLOT ' BOOTSTRAP-ALLOT DEFER!
|
|
|
|
\ Allocate one character from the data area and fill it with the value on the stack
|
|
: C, ( c -- ) HERE 1 ALLOT C! ;
|
|
|
|
\ Allocate one cell from the data area and fill it with the value on the stack
|
|
: , ( x -- ) HERE CELL ALLOT ! ;
|
|
|
|
\ Allocate two cells from the data area and fill them with the values on the stack
|
|
: 2, ( x1 x2 -- ) HERE [ 2 CELLS ] LITERAL ALLOT 2! ;
|
|
|
|
\ Allocate >= 0 and < u bytes such that the next address is a multiple of u
|
|
\ The alignment u must be a power of two
|
|
: ALIGN-TO ( u -- ) HERE SWAP ALIGNED-TO HERE - ALLOT ;
|
|
|
|
\ Allocate bytes from the data area (less than one cell) to cell-align the address
|
|
: ALIGN CELL ALIGN-TO ;
|
|
|
|
\ Compile the name field of a word header, which is a counted string _right_ aligned
|
|
\ to a cell boundary, with the length at the _end_ of the string. Example:
|
|
\ [ x x x N ][ A M E 4 ]
|
|
: NAME, ( c-addr u -- )
|
|
TUCK ▪ ALIGN HERE OVER + 1+ ▪ NEGATE CELL 1- AND ALLOT
|
|
HERE ▪ OVER ALLOT ▪ SWAP CMOVE ▪ C, ;
|
|
|
|
\ Append the effect of the token on top of the stack to the current definition.
|
|
\ Here it's equivalent to , since words are just arrays of execution tokens.
|
|
\ Once COMPILE, has been defined we can use POSTPONE for non-immediate words.
|
|
: COMPILE, ( xt -- ) , ;
|
|
|
|
\ Append the LIT xt and the topmost word on the stack to the current definition.
|
|
: LITERAL ( x -- ; -- x ) IMMEDIATE
|
|
POSTPONE LIT , ;
|
|
|
|
\ Append the LITSTRING xt and a copy of the string passed on the stack.
|
|
: SLITERAL ( c-addr1 u -- ; -- c-addr2 u ) IMMEDIATE
|
|
POSTPONE LITSTRING DUP C, HERE SWAP DUP ALLOT CMOVE ALIGN ;
|
|
|
|
: 2LITERAL ( x1 x2 -- ; -- x1 x2 ) IMMEDIATE
|
|
POSTPONE 2LIT 2, ;
|
|
|
|
\ Append the execution semantics of the current definition to the current definition
|
|
: RECURSE IMMEDIATE
|
|
LATEST COMPILE, ;
|
|
|
|
\ Unhide the current definition so it can refer to itself by name
|
|
: RECURSIVE IMMEDIATE
|
|
LATEST (UNHIDE) ;
|
|
|
|
\ Define [[ <code> ]] as shorthand for [ <code> ] LITERAL
|
|
: [[ IMMEDIATE POSTPONE [ ;
|
|
: ]] ( x -- ) POSTPONE ] POSTPONE LITERAL ;
|
|
|
|
\ Aliases to improve readability
|
|
: NULL= ( addr -- flag ) IMMEDIATE STATE @ IF POSTPONE 0= ELSE 0= THEN ;
|
|
: NULL<> ( addr -- flag ) IMMEDIATE STATE @ IF POSTPONE 0<> ELSE 0<> THEN ;
|
|
|
|
\ Our first control-flow primitive: <cond> IF <true> {ELSE <false>} THEN
|
|
\
|
|
\ IF compiles an unresolved conditional branch.
|
|
\ AHEAD compiles an unconditional branch (same effect as FALSE IF).
|
|
\ Both AHEAD and IF leave the address of the unresolved offset on the stack.
|
|
\
|
|
\ THEN consumes the offset address and resolves it to the next code address.
|
|
\
|
|
\ ELSE inserts an unconditional branch (to THEN) and also resolves the
|
|
\ previous forward reference (from IF).
|
|
\
|
|
\ Via AND-IF and ONWARD-AHEAD the unresolve branch offset cell may be used
|
|
\ as the link field of a linked list to connect multiple forward branches to
|
|
\ the same THEN. When THEN is executed it will follow the links and update all
|
|
\ the connected branches to the same location. The list is terminated with NULL
|
|
\ in the link field. Example:
|
|
\
|
|
\ \ The IF and AND-IF both branch to <code2> if the condition is false
|
|
\ \ This is functionally a short-circuit AND condition
|
|
\ \ Without the ELSE they would both branch to <code3>
|
|
\ <cond1> IF <cond2> AND-IF <code1> ELSE <code2> THEN <code3>
|
|
\
|
|
\ ALWAYS is provided as a placeholder; it has the same effect as TRUE IF but
|
|
\ includes no branch. The "orig" value it leaves on the stack (NULL) is ignored
|
|
\ by THEN and marks the end of the list if consumed by AND-IF or ONWARD-AHEAD.
|
|
\ This can be used as a base for control structures with zero or more branches.
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ <cond1> IF <code1> {ELSE <code3>} THEN
|
|
: ALWAYS ( C: -- orig ) IMMEDIATE
|
|
NULL ;
|
|
: AND-IF ( C: orig1 -- orig2 ; flag -- ) IMMEDIATE
|
|
POSTPONE 0BRANCH HERE SWAP , ;
|
|
: ONWARD-AHEAD ( C: orig1 -- orig2 ) IMMEDIATE
|
|
POSTPONE BRANCH HERE SWAP , ;
|
|
: THEN ( C: orig -- ) IMMEDIATE
|
|
BEGIN ?DUP WHILE HERE OVER - SWAP XCHG REPEAT ;
|
|
|
|
: IF ( C: -- orig ; flag -- ) IMMEDIATE
|
|
POSTPONE ALWAYS POSTPONE AND-IF ;
|
|
: AHEAD ( C: -- orig ; flag -- ) IMMEDIATE
|
|
POSTPONE ALWAYS POSTPONE ONWARD-AHEAD ;
|
|
|
|
: ELSE ( C: orig1 -- orig2 ) IMMEDIATE
|
|
POSTPONE AHEAD SWAP POSTPONE THEN ;
|
|
|
|
\ Unbounded loop: BEGIN <body> AGAIN
|
|
\ Simple conditional loop: BEGIN <condition> UNTIL
|
|
\ Mid-loop condition(s): BEGIN <cond1> WHILE {<cond2> WHILE}… <body> REPEAT
|
|
\ Mixed WHILE/UNTIL loop: BEGIN <cond1> WHILE {<cond2> WHILE}… <condN> UNTIL
|
|
|
|
: BEGIN ( C: -- null-orig dest ) IMMEDIATE
|
|
POSTPONE ALWAYS ▪ HERE ;
|
|
: AGAIN ( C: orig dest -- ) IMMEDIATE
|
|
POSTPONE BRANCH ▪ HERE - , ▪ POSTPONE THEN ;
|
|
: UNTIL ( C: orig dest -- ) ( Runtime: flag -- ) IMMEDIATE
|
|
POSTPONE 0BRANCH HERE - , POSTPONE THEN ;
|
|
: WHILE ( C: orig1 dest -- orig2 dest ) ( Runtime: flag -- ) IMMEDIATE
|
|
SWAP POSTPONE AND-IF SWAP ;
|
|
: REPEAT ( C: orig dest -- ) IMMEDIATE
|
|
POSTPONE AGAIN ;
|
|
|
|
\ Sequential equality tests:
|
|
\ <x> CASE
|
|
\ <x0> OF <code0> ENDOF
|
|
\ <x1> OF <code1> ENDOF
|
|
\ ...
|
|
\ ENDCASE
|
|
\
|
|
\ When <x> equals <x0> execute <code0>, when <x> equals <x1> execute <code1>, etc.
|
|
\ During compilation the stack holds a list of forward references to the ENDCASE,
|
|
\ with the number of references on top. Inside OF ... ENDOF there is additionally
|
|
\ a forward reference to the ENDOF (as with IF ... THEN) above the ENDCASE counter.
|
|
\
|
|
\ Begin by creating a placeholder for the unresolved ENDOF forward references
|
|
: CASE ( C: -- null-orig ) IMMEDIATE
|
|
POSTPONE ALWAYS ;
|
|
\ At runtime test the flag on top of the stack; branch to ENDOF if false
|
|
: OF? ( C: orig-case -- orig-case orig-of ; x flag -- x ) IMMEDIATE
|
|
POSTPONE IF ;
|
|
\ Equivalent to TRUE OF?, but with one less branch
|
|
: OTHERWISE ( C: orig-case -- orig-case orig-of ; x -- x ) IMMEDIATE
|
|
POSTPONE ALWAYS ;
|
|
\ At runtime compare the values on the top of the stack; branch to ENDOF if unequal
|
|
\ Keep the first value for the next OF if unequal, otherwise consume both
|
|
: OF ( C: orign ... orig1 n -- orign ... orig1 n orig-of ; x y -- {x} ) IMMEDIATE
|
|
POSTPONE OVER POSTPONE = POSTPONE OF? POSTPONE DROP ;
|
|
\ Create a forward branch to ENDCASE and resolve the one from OF
|
|
: ENDOF ( C: orig-case1 orig-of -- orig-case2 ) IMMEDIATE
|
|
SWAP POSTPONE ONWARD-AHEAD SWAP POSTPONE THEN ;
|
|
\ Drop the <x> value in case none of the OF...ENDOF clauses matched
|
|
\ Resolve all the forward branches from ENDOF to the location after ENDCASE
|
|
: ENDCASE ( C: orig-case -- ) IMMEDIATE
|
|
POSTPONE DROP POSTPONE THEN ;
|
|
|
|
\ Range loop: <limit> <index> DO <code> LOOP
|
|
\ <limit> <index> DO <code> <step> +LOOP
|
|
\ <limit> <index> ?DO <code> LOOP
|
|
\ <limit> <index> ?DO <code> <step> +LOOP
|
|
CREATE LEAVE-ORIG NULL ,
|
|
: DO ( C: -- outer-stack dest ; limit index -- R: -- limit index ) IMMEDIATE
|
|
POSTPONE 2>R LEAVE-ORIG @
|
|
POSTPONE ALWAYS LEAVE-ORIG !
|
|
POSTPONE BEGIN ;
|
|
: ?DO ( C: -- outer-stack dest ; limit index -- R: -- limit index ) IMMEDIATE
|
|
POSTPONE 2>R LEAVE-ORIG @
|
|
POSTPONE 2R@ POSTPONE <> POSTPONE IF LEAVE-ORIG !
|
|
POSTPONE BEGIN ;
|
|
: LEAVE ( C: -- ; -- R: limit index -- ) IMMEDIATE
|
|
LEAVE-ORIG @ POSTPONE ONWARD-AHEAD LEAVE-ORIG ! ;
|
|
: UNLOOP ( R: limit index -- ) IMMEDIATE
|
|
POSTPONE 2RDROP ;
|
|
: +LOOP ( C: outer-stack dest -- ; n -- R: {limit index} -- ) IMMEDIATE
|
|
POSTPONE RSP@ POSTPONE +! POSTPONE 2R@ POSTPONE = POSTPONE UNTIL
|
|
LEAVE-ORIG @ POSTPONE THEN POSTPONE UNLOOP LEAVE-ORIG ! ;
|
|
: LOOP ( C: outer-stack dest -- ; -- R: {limit index} -- ) IMMEDIATE
|
|
1 POSTPONE LITERAL POSTPONE +LOOP ;
|
|
' LEAVE-ORIG (HIDE)
|
|
|
|
\ Return the current index value from the innermost or next-innermost loop.
|
|
\ The loops must be directly nested with no other changes to the return stack
|
|
: I 1 RPICK ;
|
|
: J 3 RPICK ;
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
\ With 32-bit cells, a double-cell number has 64 bits
|
|
\ Space is reserved for binary output with a leading minus sign and a trailing space
|
|
\ The minimum pictured numeric output buffer size is thus 66 bytes
|
|
\ The PNO buffer may be used for transient data like interpreted string literals
|
|
80 CONSTANT PNO-BUFFER-BYTES
|
|
|
|
CREATE PNO-BUFFER PNO-BUFFER-BYTES ALLOT
|
|
PNO-BUFFER PNO-BUFFER-BYTES + CONSTANT PNO-BUFFER-END
|
|
CREATE PNO-POINTER PNO-BUFFER-END ,
|
|
|
|
\ Return the number of characters consumed/remaining in the PNO buffer
|
|
: PNO-USED ( -- u ) PNO-BUFFER-END PNO-POINTER @ - ;
|
|
: PNO-REMAINING ( -- u ) PNO-POINTER @ PNO-BUFFER - ;
|
|
|
|
\ THROW if there are less than u bytes remaining in the PNO buffer
|
|
: PNO-CHECK ( u -- ) PNO-REMAINING U> IF EXCP-PNO-OVERFLOW THROW THEN ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
: <# PNO-BUFFER-END PNO-POINTER ! ;
|
|
: HOLD ( char -- ) PNO-POINTER 1 DUP PNO-CHECK OVER -! @ C! ;
|
|
: HOLDS ( c-addr u -- ) PNO-POINTER OVER DUP PNO-CHECK OVER -! @ SWAP CMOVE ;
|
|
: #PAD ( c n -- )
|
|
0 MAX DUP PNO-USED UMIN - DUP PNO-CHECK PNO-POINTER 2DUP -! @ SWAP ROT FILL ;
|
|
: #> ( xd -- c-addr u ) 2DROP PNO-BUFFER-END PNO-POINTER @ TUCK - ;
|
|
|
|
: SIGN ( n -- ) 0< IF [[ CHAR - ]] HOLD THEN ;
|
|
|
|
: #B ( ud1 u -- ud2 )
|
|
UM/MOD ROT DUP 10 >= IF 10 - [[ CHAR A ]] + ELSE [[ CHAR 0 ]] + THEN HOLD ;
|
|
|
|
: # ( ud1 -- ud2 ) 10 #B ;
|
|
|
|
: #SB ( ud u -- )
|
|
>R BEGIN R@ #B 2DUP D0= UNTIL RDROP ;
|
|
|
|
: #S ( ud -- ) 10 #SB ;
|
|
|
|
\ Decimal Fixed Precision with u digits after the decimal point
|
|
\ Example: 12345 0 <# 3 #DFP #> ≡ "12.345"
|
|
: #DFP ( ud1 u -- ud2 ) BEGIN ?DUP WHILE 1- >R # R> REPEAT [[ CHAR . ]] HOLD #S ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Display the unsigned double-cell number at the top of the stack, right-aligned
|
|
: DU.R ( ud n -- "<digits>" ) >R <# #S BL R> #PAD #> TYPE ;
|
|
|
|
\ Display the signed double-cell number at the top of the stack, right-aligned
|
|
: D.R ( d n -- "<minus?><digits>" )
|
|
>R DUP -ROT DABS <# #S ROT SIGN BL R> #PAD #> TYPE ;
|
|
|
|
\ Single-cell versions of DU.R and D.R
|
|
: U.R ( u n -- "<digits>" ) 0 SWAP DU.R ;
|
|
: .R ( n1 n2 -- "<minus?><digits>" ) >R S>D R> D.R ;
|
|
|
|
\ Versions of DU.R, D.R, U.R, and .R without right-alignment
|
|
: DU. ( ud -- "<digits>" ) 0 DU.R ;
|
|
: U. ( u -- "<digits>" ) 0 0 DU.R ;
|
|
: D. ( d -- "<minus?><digits>" ) 0 D.R ;
|
|
: . ( n -- "<minus?><digits>" ) S>D 0 D.R ;
|
|
|
|
\ Return the number of words on the data and return stacks, respectively
|
|
: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ;
|
|
: RDEPTH ( -- n ) RSP@ CELL+ R0 SWAP - CELL / ;
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
: STARTUP-UNWIND ( k*x n -- i*x <noreturn> )
|
|
"Exception " TYPE-ERR DUP ABS 0 <# (EOL) HOLDS #S ROT SIGN #> TYPE-ERR
|
|
THROWN-STRING 2@ DUP IF TYPE-ERR "\n" TYPE-ERR THEN
|
|
[ ' BAILOUT COMPILE, ] ;
|
|
|
|
' STARTUP-UNWIND ' THROW-UNWIND DEFER!
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
CREATE DISPLAY-ITEM-LIMIT 6 ,
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Display the content of the data stack
|
|
: .S ( -- "<text>" )
|
|
"S(" TYPE DEPTH . "):" TYPE
|
|
SP@ DUP DISPLAY-ITEM-LIMIT @ CELLS+ S0 UMIN
|
|
DUP S0 <> IF " …" TYPE THEN
|
|
BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ;
|
|
|
|
\ Display the content of the return stack
|
|
: .RS ( -- "<text>" )
|
|
\ Skip the topmost cell, which is the return address for the call to .RS
|
|
"R(" TYPE RDEPTH 1- . "):" TYPE
|
|
RSP@ CELL+ DUP DISPLAY-ITEM-LIMIT @ CELLS+ R0 UMIN
|
|
DUP R0 <> IF " …" TYPE THEN
|
|
BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ;
|
|
|
|
\ Display a block of memory
|
|
: DUMP ( addr u -- )
|
|
OVER + 16 ALIGNED-TO ▪ SWAP TUCK -16 AND ▪ ?DO
|
|
I 0 <# ":" HOLDS 16 #SB [[ CHAR 0 ]] 9 #PAD #> TYPE
|
|
I 16 + I ?DO
|
|
DUP I C@ 0 <# 16 #SB [[ CHAR 0 ]] 2 #PAD
|
|
ROT I = IF [[ CHAR > ]] ELSE BL THEN HOLD BL HOLD #> TYPE
|
|
LOOP ▪ EOL
|
|
16 +LOOP ▪ DROP ;
|
|
|
|
\ Remove trailing whitespace from a string (only affects length)
|
|
: -TRAILING ( c-addr u1 -- c-addr u2 )
|
|
BEGIN DUP WHILE 2DUP 1- + C@ SPACE? WHILE 1- REPEAT ;
|
|
|
|
\ Convert a character to lowercase or uppercase, respectively
|
|
: TO-LOWER ( ch1 -- ch2 )
|
|
DUP [[ CHAR A ]] [[ CHAR Z 1+ ]] WITHIN IF [[ CHAR a CHAR A - ]] + THEN ;
|
|
: TO-UPPER ( ch1 -- ch2 )
|
|
DUP [[ CHAR a ]] [[ CHAR z 1+ ]] WITHIN IF [[ CHAR a CHAR A - ]] - THEN ;
|
|
|
|
\ If ch is an alphanumeric character return the value in range [0, 36) and TRUE
|
|
\ Otherwise just return FALSE
|
|
: >DIGIT ( ch -- u TRUE | FALSE )
|
|
DUP [[ CHAR 0 ]] [[ CHAR 9 1+ ]] WITHIN IF [[ CHAR 0 ]] - TRUE EXIT THEN
|
|
DUP [[ CHAR A ]] [[ CHAR Z 1+ ]] WITHIN IF [[ CHAR A 10 - ]] - TRUE EXIT THEN
|
|
DUP [[ CHAR a ]] [[ CHAR z 1+ ]] WITHIN IF [[ CHAR a 10 - ]] - TRUE EXIT THEN
|
|
DROP FALSE ;
|
|
|
|
\ Like >DIGIT but only returns TRUE if ch is a valid digit for the given base
|
|
: >DIGIT-BASE ( ch base -- u TRUE | FALSE )
|
|
SWAP >DIGIT ?0DUP IF SWAP 2DUP U< DUP 0= IF NIP THEN THEN NIP ;
|
|
|
|
\ Convert a string in the given base to an unsigned double-cell number
|
|
\ Stop at the end of the string or when the next character is not valid for the base
|
|
\ Return the double-cell number and the remainder of the string
|
|
: >NUMBER-BASE ( c-addr1 u1 base -- ud c-addr2 u2 )
|
|
>R 0 0 2SWAP BEGIN
|
|
DUP WHILE ▪ OVER C@ >DIGIT WHILE
|
|
DUP R@ U>= ▪ DUP IF DROP THEN ▪ 0= WHILE
|
|
>R 1/STRING ▪ 2SWAP ▪ 2R@ DROP 0 D* ▪ R> 0 D+ ▪ 2SWAP
|
|
AGAIN ▪ RDROP ;
|
|
|
|
: >NUMBER ( c-addr1 u1 -- ud c-addr2 u2 )
|
|
DUP 0= IF 0 0 2SWAP EXIT THEN
|
|
OVER C@ [[ CHAR 0 ]] = IF
|
|
1/STRING
|
|
DUP 0= IF 0 0 2SWAP EXIT THEN
|
|
OVER C@ TO-UPPER CASE
|
|
[[ CHAR B ]] OF 1/STRING 2 ENDOF
|
|
[[ CHAR X ]] OF 1/STRING 16 ENDOF
|
|
8 SWAP
|
|
ENDCASE
|
|
ELSE
|
|
10
|
|
THEN
|
|
>NUMBER-BASE ;
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
\ Parse a signed number; to succeed the entire input string must be consumed
|
|
: PARSENUMBER ( c-addr u -- 0 | n 1 | d 2 )
|
|
DUP 0= IF NIP EXIT THEN ▪ OVER C@ [[ CHAR - ]] = >R
|
|
R@ IF 1/STRING DUP 0= IF RDROP NIP EXIT THEN THEN
|
|
>NUMBER
|
|
R> IF 2SWAP DNEGATE 2SWAP THEN
|
|
DUP 1 = IF OVER C@ [[ CHAR # ]] = AND-IF
|
|
2DROP 2
|
|
ELSE NIP 0= IF
|
|
DROP 1
|
|
ELSE
|
|
2DROP 0
|
|
THEN THEN ;
|
|
|
|
' PARSENUMBER ' BOOTSTRAP-PARSENUMBER DEFER!
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
\ Copy the bootstrap SOURCE values into variables to allow changing the input buffer
|
|
CREATE INPUT-BUFFER SOURCE 2,
|
|
|
|
\ The SOURCE-ID is -1 for a string (EVALUATE) or 0 for user input
|
|
\ Any other values are implementation-defined, for example FD numbers for file input
|
|
CREATE CURRENT-SOURCE-ID -1 ,
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Report the current input buffer region and SOURCE-ID
|
|
: SOURCE ( -- c-addr u ) INPUT-BUFFER 2@ ;
|
|
: SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ;
|
|
|
|
\ Save and restore the input source parameters (e.g. file position)
|
|
\ This does not include the input buffer (SOURCE) or the SOURCE-ID
|
|
: SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ;
|
|
: RESTORE-INPUT ( xu ... x1 u -- flag ) OVER >IN ! NDROP TRUE ;
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
CREATE EXCEPTION-STACK NULL ,
|
|
|
|
\ Called when THROW is called inside of CATCH
|
|
\ Restore the input source specification, stack point, and return stack pointer
|
|
\ Push the error code from THROW onto the data stack
|
|
\ Return to the code that called CATCH
|
|
: CATCH-UNWIND ( k*x n -- i*x <noreturn> )
|
|
EXCEPTION-STACK @ RSP!
|
|
2R> ▪ [[ ' THROW-UNWIND ]] DEFER! ▪ EXCEPTION-STACK !
|
|
R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP
|
|
R> SWAP >R SP! R> ;
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
\ Returns TRUE if currently executing inside CATCH, or FALSE otherwise
|
|
: CATCHING? ( -- flag ) EXCEPTION-STACK @ NULL<> ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Run xt while trapping calls to THROW, ABORT, FAIL, etc.
|
|
\ On success has the effect of xt and also leaves the value 0 on top of the stack
|
|
\ On failure the stacks and input source are reverted and the THROW code is pushed
|
|
: CATCH ( i*x xt -- j*x 0 | i*x n )
|
|
\ Save the original RSP to quickly remove the exception frame data on success
|
|
RSP@
|
|
\ Save the stack poiner but don't include the xt and RSP on the top
|
|
SP@ 2 CELLS+ >R
|
|
\ Save the input source specification
|
|
SAVE-INPUT N>R ▪ SOURCE 2>R ▪ SOURCE-ID >R
|
|
\ We'll need these to revert the effect of CATCH, with or without THROW
|
|
EXCEPTION-STACK @ ▪ [[ ' THROW-UNWIND ]] DEFER@ ▪ 2>R
|
|
\ Push the new exception stack frame
|
|
RSP@ EXCEPTION-STACK !
|
|
\ Arrange for THROW to call CATCH-UNWIND instead of DEFAULT-UNWIND
|
|
[ ' CATCH-UNWIND ' THROW-UNWIND ] 2LITERAL DEFER!
|
|
\ Save the original return stack so we can quickly free the exception frame
|
|
\ Run the function; if THROW is called then EXECUTE won't return
|
|
>R EXECUTE
|
|
\ Revert THROW-UNWIND, EXCEPTION-STACK, and RSP; return 0 to indicates success
|
|
R> 2R> ▪ [[ ' THROW-UNWIND ]] DEFER! ▪ EXCEPTION-STACK ! ▪ RSP! ▪ 0 ;
|
|
|
|
: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ;
|
|
|
|
\ Placeholder to be replaced before switching to terminal input
|
|
DEFER REFILL
|
|
' FALSE ' REFILL DEFER!
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
: PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ;
|
|
|
|
: PEEK-CHAR ( -- c )
|
|
PARSE-AREA 0= "Unexpected end of input" ?FAIL C@ ;
|
|
|
|
: SKIP-CHAR 1 >IN +! ;
|
|
|
|
: NEXT-CHAR ( -- c ) PEEK-CHAR SKIP-CHAR ;
|
|
|
|
: SKIP-SPACES ( "<spaces?>" -- )
|
|
BEGIN ▪ PARSE-EMPTY? 0= WHILE ▪ PEEK-CHAR SPACE? WHILE ▪ SKIP-CHAR ▪ REPEAT ;
|
|
|
|
: ENSURE-NONEMPTY ( -- f=eof )
|
|
BEGIN PARSE-EMPTY? ?0DUP WHILE REFILL 0= ?DUP UNTIL 0= ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Comments; ignore all characters until the next EOL or ) character, respectively
|
|
: \ ( "ccc<eol>" -- ) IMMEDIATE
|
|
BEGIN PARSE-EMPTY? 0= WHILE NEXT-CHAR LF = UNTIL ;
|
|
: ( ( "ccc<closeparen>" -- ) IMMEDIATE
|
|
BEGIN ENSURE-NONEMPTY WHILE NEXT-CHAR [[ CHAR ) ]] = UNTIL ;
|
|
|
|
\ Skip whitespace; read and return the next word delimited by whitespace
|
|
\ The delimiting whitespace character is left in the parse area
|
|
: PARSE-NAME ( "<spaces?>name<space>" -- c-addr u )
|
|
BEGIN
|
|
SKIP-SPACES ▪ PARSE-EMPTY?
|
|
WHILE
|
|
REFILL 0= IF EXCP-UNEXPECTED-EOF THROW THEN
|
|
REPEAT
|
|
PARSE-AREA DROP
|
|
BEGIN ▪ PARSE-EMPTY? 0= WHILE ▪ PEEK-CHAR SPACE? 0= WHILE ▪ SKIP-CHAR ▪ REPEAT
|
|
PARSE-AREA DROP OVER - ;
|
|
|
|
\ Read the next word and return the first character
|
|
: CHAR ( "<spaces?>name" -- c )
|
|
PARSE-NAME DROP C@ ;
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
\ Create the header for a word in the data space and return its xt
|
|
\ The word is NOT added to the current compilation word list
|
|
\ The start and end of the header are both cell-aligned
|
|
: (CREATE-RAW) ( c-addr u link dfa cfa -- xt )
|
|
2>R >R ▪ F_LENMASK UMIN NAME, ▪ R> , ▪ 2R> , , ▪ HERE 2 CELLS- ;
|
|
|
|
\ Called when a word using DOES> is executed (not compiled) to set
|
|
\ the runtime behavior of the most recently defined word
|
|
: (DOES) ( dfa -- ) LATEST DODOES OVER >CFA ! >DFA ! ;
|
|
|
|
\ The runtime effect of MARK, after the string label is pushed onto the stack
|
|
: (MARK) ( c-addr u -- ) "-- " TYPE TYPE " --\n" TYPE .S R> .RS >R ;
|
|
|
|
\ The default target for DEFER words until initialized with DEFER! or IS
|
|
: (DEFER-UNINITIALIZED) EXCP-DEFER-UNINITIALIZED THROW ;
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
\ Use to create words programmatically without reading the name from the input
|
|
: (CREATE) ( c-addr u -- )
|
|
LATEST NULL DODATA (CREATE-RAW) HERE OVER >DFA ! LATEST! ;
|
|
|
|
\ Define a threaded FORTH word
|
|
\ The word is initially hidden so it can refer to a prior word with the same name
|
|
\ The definition is terminated with the ; immediate word, which unhides the name
|
|
: (:) ( c-addr u -- )
|
|
(CREATE) LATEST ▪ DUP (HIDE) ▪ DOCOL SWAP >CFA ! ▪ POSTPONE ] ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Append "<addr> (DOES) EXIT" to the current definition
|
|
\ where <addr> is the next address after the "EXIT" as a literal number
|
|
\ Stay in compilation mode for the body of the DOES> clause
|
|
: DOES> IMMEDIATE
|
|
POSTPONE LIT HERE NULL , ▪ POSTPONE (DOES) POSTPONE EXIT ▪ HERE SWAP ! ;
|
|
|
|
\ End a definition by appending EXIT and leaving compilation mode
|
|
\ Unhide the name if it isn't empty (e.g. from :NONAME)
|
|
: ; IMMEDIATE
|
|
POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ;
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
\ Create a deferred word; the target is stored in the DFA field
|
|
\ The default target throws an exception — replace it using DEFER! or IS
|
|
: (DEFER) ( c-addr u -- )
|
|
(CREATE) [[ ' (DEFER-UNINITIALIZED) ]] LATEST DODEFER OVER >CFA ! >DFA ! ;
|
|
|
|
\ Use the deferred-word mechanism to create an alternate name for the given xt
|
|
\ A deferred word, while indirect, is more compact than a single-word colon
|
|
\ definition and avoids the setup and teardown of a redundant return stack frame
|
|
: (ALIAS) ( xt c-addr u -- ) (DEFER) LATEST DEFER! ;
|
|
|
|
\ Define a named constant
|
|
\ Execution: ( value "<spaces?>name" -- )
|
|
\ name Execution: ( -- value )
|
|
\
|
|
\ By default CREATEd words have codeword DODATA which returns the value
|
|
\ of the DFA field, so store the constant value there
|
|
\
|
|
\ Alternate definition:
|
|
\ : (CONSTANT) (:) POSTPONE LITERAL POSTPONE ; ;
|
|
: (CONSTANT) ( x c-addr u -- ; -- x ) (CREATE) LATEST >DFA ! ;
|
|
|
|
\ Same for double-cell constants; no DFA trick this time
|
|
: (2CONSTANT) ( x1 x2 -- ) (CREATE) ▪ HERE ▪ 2 CELLS ALLOT ▪ 2!
|
|
DOES> ( -- x1 x2 ) 2@ ;
|
|
|
|
\ Define a named variables which return the address of their data when executed.
|
|
\ The initial value is formally undefined. This implementation sets it to NULL.
|
|
: (VARIABLE) ( c-addr u -- ; -- a-addr ) (CREATE) NULL , ;
|
|
: (2VARIABLE) ( c-addr u -- ; -- a-addr ) (CREATE) [ NULL NULL ] 2LITERAL 2, ;
|
|
|
|
\ Define a single-cell named value which returns its data (not address) when executed.
|
|
\ Named values defined with VALUE can be modified with TO.
|
|
\ Execution: ( x "<spaces?>name" -- )
|
|
\ name execution: ( -- value )
|
|
: (VALUE) ( x c-addr u -- ; -- x' ) (CREATE) , DOLOAD LATEST >CFA ! ;
|
|
|
|
\ Define an array of u1 single-cell elements; word returns address of element u (<u1)
|
|
: (ARRAY) ( u1 c-addr u2 -- ) (CREATE) CELLS ALLOT
|
|
DOES> ( u -- a-addr ) SWAP CELL * + ;
|
|
|
|
\ Define an array of u1 double-cell elements; word returns address of element u (<u1)
|
|
: (2ARRAY) ( u1 c-addr u2 -- ) (CREATE) 2* CELLS ALLOT
|
|
DOES> ( u -- a-addr ) SWAP [[ 2 CELLS ]] * + ;
|
|
|
|
\ Debugging aid; shows a label and the contents of the stacks at runtime
|
|
: MARK ( "<spaces?>name" ) IMMEDIATE
|
|
PARSE-NAME STATE @ IF POSTPONE SLITERAL POSTPONE (MARK) ELSE (MARK) THEN ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ The utility words defined previously, but with the name read from the parse area
|
|
: CREATE PARSE-NAME (CREATE) ;
|
|
: : PARSE-NAME (:) ;
|
|
: DEFER PARSE-NAME (DEFER) ;
|
|
: ALIAS PARSE-NAME (ALIAS) ;
|
|
: CONSTANT PARSE-NAME (CONSTANT) ;
|
|
: 2CONSTANT PARSE-NAME (2CONSTANT) ;
|
|
: VARIABLE PARSE-NAME (VARIABLE) ;
|
|
: 2VARIABLE PARSE-NAME (2VARIABLE) ;
|
|
: VALUE PARSE-NAME (VALUE) ;
|
|
: ARRAY PARSE-NAME (ARRAY) ;
|
|
: 2ARRAY PARSE-NAME (2ARRAY) ;
|
|
|
|
\ Define a word with no name, leaving its xt on the stack
|
|
: :NONAME "" (:) LATEST ;
|
|
|
|
\ Structures begin with byte alignment and an offset of zero
|
|
1 0 2CONSTANT STRUCT
|
|
|
|
\ Basic type descriptors giving alignment and size for each type
|
|
1 1 2CONSTANT CHAR%
|
|
1 ALIGNED 1 CELLS 2CONSTANT CELL%
|
|
1 ALIGNED 2 CELLS 2CONSTANT 2CELL%
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
\ Extra field type descriptors for FFI structs
|
|
\ The signed/unsigned variants are just for documentation
|
|
1 DUP 2CONSTANT int8% LATEST
|
|
▪ DUP ALIAS uint8%
|
|
▪ DUP ALIAS char%
|
|
▪ DUP ALIAS signed-char%
|
|
▪ ALIAS unsigned-char%
|
|
2 DUP 2CONSTANT int16% LATEST
|
|
▪ DUP ALIAS uint16%
|
|
▪ DUP ALIAS signed-short%
|
|
▪ ALIAS unsigned-short%
|
|
4 DUP 2CONSTANT int32% LATEST
|
|
▪ DUP ALIAS uint32%
|
|
▪ DUP ALIAS signed-int%
|
|
▪ DUP ALIAS unsigned-int%
|
|
▪ DUP ALIAS signed-long%
|
|
▪ ALIAS unsigned-long%
|
|
\ Maximum alignment is four bytes, even for 64-bit integer types
|
|
4 8 2CONSTANT int64% LATEST
|
|
▪ DUP ALIAS uint64%
|
|
▪ DUP ALIAS signed-long-long%
|
|
▪ ALIAS unsigned-long-long%
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Within STRUCT … ENDSTRUCT, define a field with the given alignment and size
|
|
\ Each field word has runtime effect ( struct-addr -- field-addr)
|
|
\ If field offset is zero then the word is marked as immediate and generates no code
|
|
: FIELD ( align1 offset1 field-align field-bytes -- align2 offset2 )
|
|
: -ROT NATURALLY-ALIGNED ▪ DUP >R ▪ ALIGNED-TO DUP
|
|
?DUP IF POSTPONE LITERAL POSTPONE + ELSE POSTPONE IMMEDIATE THEN
|
|
POSTPONE ; ▪ + SWAP R> UMAX SWAP ;
|
|
|
|
\ Consume the final alignment and offset and define a type descriptor for the struct
|
|
: ENDSTRUCT ( align offset "<spaces?>name" -- )
|
|
SWAP NATURALLY-ALIGNED TUCK ALIGNED-TO 2CONSTANT ;
|
|
|
|
\ Accessors for type descriptors
|
|
: %SIZEOF ( align size -- size ) IMMEDIATE
|
|
STATE @ IF POSTPONE NIP ELSE NIP THEN ;
|
|
: %ALIGNOF ( align size -- align ) IMMEDIATE
|
|
STATE @ IF POSTPONE DROP ELSE DROP THEN ;
|
|
|
|
\ Inline :NONAME-style function literals. "{ <code> }" has the runtime effect
|
|
\ of placing the execution token for an anonymous function with the runtime
|
|
\ effect of <code> on the top of the data stack. A branch is emitted to skip
|
|
\ over the memory used for the nested definition. If RECURSE is used in <code>
|
|
\ it will create a recursive call to the anonymous inner function. In the word
|
|
\ list, after the }, the inner definition is ordered before the outer definition.
|
|
\ LATEST always refers to the innermost enclosing definition.
|
|
\
|
|
\ Example:
|
|
\ > : TIMES 0 ?DO DUP EXECUTE LOOP DROP ;
|
|
\ > : GREETINGS { "Hello" TYPE EOL } 3 TIMES ;
|
|
\ > GREETINGS
|
|
\ Hello
|
|
\ Hello
|
|
\ Hello
|
|
\
|
|
\ Compilation effect: ( C: -- outer-xt orig inner-xt state )
|
|
\ Interpreter effect: ( S: -- inner-xt state )
|
|
\ Enters compilation mode if not already compiling
|
|
: { ( -- {outer-xt orig} inner-xt state ) IMMEDIATE
|
|
STATE @
|
|
DUP IF
|
|
LATEST
|
|
NULL OVER >LINK XCHG LATEST!
|
|
POSTPONE AHEAD
|
|
ROT
|
|
POSTPONE [
|
|
THEN
|
|
:NONAME SWAP ;
|
|
|
|
\ Terminate a definition started with { .
|
|
\ Leave compilation mode if STATE was 0 before { was executed
|
|
\ Otherwise:
|
|
\ Resolve the forward branch over the inner function
|
|
\ Add outer-xt back to the word list after inner-xt
|
|
\ Generate a literal for inner-xt
|
|
: } ( {outer-xt orig} inner-xt state -- {inner-xt} ) IMMEDIATE
|
|
POSTPONE ;
|
|
IF
|
|
( S: outer-xt orig inner-xt )
|
|
\ Resolve the forward branch over the inner definition
|
|
-ROT POSTPONE THEN
|
|
\ Re-append the outer definition to the word list
|
|
LATEST OVER >LINK ! LATEST!
|
|
\ Return to compilation mode (was ended by ; )
|
|
POSTPONE ]
|
|
\ Compile inner-xt as a literal in the outer definition
|
|
POSTPONE LITERAL
|
|
\ ELSE ( nothing to do )
|
|
( S: inner-xt )
|
|
THEN ;
|
|
|
|
\ Conditional compilation / interpreted conditions
|
|
\ No effect if flag is true, otherwise skips words until matching [ELSE] or [THEN]
|
|
\ Skips over nested [IF] … [THEN] or [IF] … [ELSE] … [THEN] structures
|
|
\ The skipped words are not interpreted, so \ ( " etc. have no special meaning
|
|
: [IF] ( flag -- ) IMMEDIATE
|
|
0= IF
|
|
0 BEGIN
|
|
PARSE-NAME 2>R
|
|
2R@ "[IF]" COMPARE 0= IF
|
|
1+
|
|
ELSE 2R@ "[THEN]" COMPARE 0<> IF 2R@ "[ELSE]" COMPARE 0<> AND-IF
|
|
ELSE
|
|
?DUP 0= IF 2RDROP EXIT THEN
|
|
1-
|
|
THEN THEN
|
|
2RDROP
|
|
AGAIN
|
|
THEN ;
|
|
|
|
\ Skips words until matching [THEN]
|
|
\ Skips over nested [IF] … [THEN] or [IF] … [ELSE] … [THEN] structures
|
|
: [ELSE] IMMEDIATE
|
|
0 BEGIN
|
|
PARSE-NAME 2>R
|
|
2R@ "[IF]" COMPARE 0= IF
|
|
1+
|
|
ELSE 2R@ "[THEN]" COMPARE 0= IF
|
|
?DUP 0= IF 2RDROP EXIT THEN
|
|
1-
|
|
THEN THEN
|
|
2RDROP
|
|
AGAIN ;
|
|
|
|
\ [THEN] is just a placeholder to terminate [IF] or [ELSE]; no compilation effect
|
|
: [THEN] IMMEDIATE ;
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
\ Orders 0 ... 17 with sizes 32 bytes ... 4 MiB
|
|
32 CONSTANT BUDDY-MIN-BYTES
|
|
18 CONSTANT BUDDY-ORDERS
|
|
|
|
: BUDDY-ORDER-BYTES ( order -- n-bytes ) BUDDY-MIN-BYTES SWAP LSHIFT ;
|
|
|
|
BUDDY-ORDERS 1- BUDDY-ORDER-BYTES CONSTANT BUDDY-MAX-BYTES
|
|
|
|
BUDDY-ORDERS ARRAY BUDDY-HEADS
|
|
{ BUDDY-ORDERS 0 ?DO 0 I BUDDY-HEADS ! LOOP } EXECUTE
|
|
|
|
: ?BUDDY-ORDER ( order -- )
|
|
BUDDY-ORDERS U>= "order out of bounds" ?FAIL ;
|
|
|
|
: ?BUDDY-ALIGNED ( a-addr order -- )
|
|
SWAP BUDDY-ORDER-BYTES 1- AND "address is not naturally aligned" ?FAIL ;
|
|
|
|
: BUDDY-FREE ( a-addr order -- )
|
|
TUCK ?BUDDY-ORDER ▪ 2DUP ?BUDDY-ALIGNED ▪ >R DUP BUDDY-HEADS
|
|
BEGIN
|
|
( S: order head-addr R: a-addr )
|
|
DUP @
|
|
DUP NULL= IF
|
|
\ Append to end of list
|
|
DROP NULL R@ ! R> SWAP !
|
|
DROP EXIT
|
|
THEN
|
|
( S: order head-addr block-addr R: freed-addr )
|
|
2 PICK 1+ BUDDY-ORDERS <= IF
|
|
DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ = AND-IF
|
|
\ Found the buddy on the free list; coalesce
|
|
@ SWAP !
|
|
\ Pick the lower (naturally aligned) block address
|
|
DUP BUDDY-ORDER-BYTES INVERT R> AND >R
|
|
\ Repeat process with the next-higher order
|
|
1+ DUP BUDDY-HEADS
|
|
ELSE
|
|
\ Insert before first item with address >= this addr
|
|
DUP R@ U>= IF R@ ! R> SWAP ! DROP EXIT THEN
|
|
\ Otherwise advance to next block
|
|
NIP
|
|
THEN
|
|
AGAIN ;
|
|
|
|
: BUDDY-ALLOCATE ( order -- a-addr ) RECURSIVE
|
|
DUP ?BUDDY-ORDER
|
|
DUP BUDDY-HEADS @ ?DUP IF DUP @ ROT BUDDY-HEADS ! EXIT THEN
|
|
DUP 1+ BUDDY-ORDERS >= IF EXCP-HEAP-OVERFLOW THROW THEN
|
|
DUP 1+ BUDDY-ALLOCATE SWAP 2DUP BUDDY-ORDER-BYTES + SWAP BUDDY-FREE ;
|
|
|
|
: BUDDY-ORDER-FROM-BYTES ( u-bytes -- order )
|
|
DUP 0= ?DUP 0= IF DUP DUP 1- AND THEN
|
|
"buddy allocator block size is not a power of two" ?FAIL
|
|
DUP BUDDY-MIN-BYTES - [[ BUDDY-MAX-BYTES BUDDY-MIN-BYTES - ]] U>
|
|
"buddy allocator block size out of bounds" ?FAIL
|
|
BUDDY-MIN-BYTES / 0 SWAP BEGIN 2/ ?DUP 0<> WHILE SWAP 1+ SWAP REPEAT ;
|
|
|
|
: BUDDY-COUNT ( order -- u )
|
|
DUP ?BUDDY-ORDER ▪ BUDDY-HEADS @ 0 SWAP BEGIN ?DUP WHILE @ SWAP 1+ SWAP REPEAT ;
|
|
|
|
VARIABLE TOTAL
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
: BUDDY-STATS
|
|
0 TOTAL !
|
|
BUDDY-ORDERS 0 DO
|
|
I BUDDY-COUNT ?DUP IF
|
|
DUP I BUDDY-ORDER-BYTES * TOTAL +!
|
|
. "x" TYPE I BUDDY-ORDER-BYTES . SPACE
|
|
THEN
|
|
LOOP "total " TYPE TOTAL @ . EOL ;
|
|
|
|
' TOTAL (HIDE)
|
|
|
|
' LINUX (DEFINITIONS)
|
|
|
|
4 KB CONSTANT PAGESIZE
|
|
|
|
0 CONSTANT PROT_NONE
|
|
1 CONSTANT PROT_READ
|
|
2 CONSTANT PROT_WRITE
|
|
4 CONSTANT PROT_EXEC
|
|
|
|
2 CONSTANT MAP_PRIVATE
|
|
32 CONSTANT MAP_ANONYMOUS
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
\ Simple wrapper for munmap() that retries on EINTR
|
|
: MMAP-UNMAP ( addr length -- )
|
|
DUP IF SYS_MUNMAP SYSCALL2-RETRY DROP ELSE 2DROP THEN ;
|
|
|
|
: MMAP-ALLOCATE ( size -- a-addr )
|
|
NULL SWAP PROT_READ PROT_WRITE OR
|
|
MAP_PRIVATE MAP_ANONYMOUS OR -1 0 SYS_MMAP2 SYSCALL6-RETRY
|
|
DUP -4095 U>= IF EXCP-HEAP-OVERFLOW THROW THEN ;
|
|
|
|
: MMAP-ALLOCATE-ALIGNED ( size -- a-addr )
|
|
NATURALLY-ALIGNED
|
|
DUP 2* MMAP-ALLOCATE SWAP
|
|
( S: addr size )
|
|
2DUP ALIGNED-TO
|
|
( S: addr size a-addr )
|
|
-ROT >R >R
|
|
( S: a-addr R: size addr )
|
|
R@ OVER R@ - MMAP-UNMAP
|
|
DUP R> R@ 2* + SWAP R> + TUCK - MMAP-UNMAP ;
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
STRUCT
|
|
CELL% FIELD MEMBLOCK>SIZE
|
|
CELL% FIELD MEMBLOCK>MAGIC
|
|
2CELL% 0 * FIELD MEMBLOCK>DATA
|
|
ENDSTRUCT MEMBLOCK%
|
|
|
|
\ This is used to identify blocks returned by ALLOCATE
|
|
0xC0DE3319 CONSTANT MEMBLOCK-MAGIC
|
|
|
|
0 MEMBLOCK>DATA CONSTANT MEMBLOCK-DATA-OFFSET
|
|
|
|
: MEMBLOCK-CHECK-MAGIC ( memblock-addr -- )
|
|
MEMBLOCK>MAGIC @ MEMBLOCK-MAGIC <> IF EXCP-INVALID-ADDRESS THROW THEN ;
|
|
|
|
: DATA>MEMBLOCK ( obj-addr -- memblock-addr )
|
|
MEMBLOCK-DATA-OFFSET - DUP MEMBLOCK-CHECK-MAGIC ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
: ALLOCATE ( size -- obj-addr )
|
|
DUP 0= IF EXIT THEN
|
|
MEMBLOCK-DATA-OFFSET + DUP BUDDY-MAX-BYTES U> IF
|
|
PAGESIZE ALIGNED-TO DUP MMAP-ALLOCATE
|
|
ELSE
|
|
NATURALLY-ALIGNED DUP BUDDY-MIN-BYTES U< IF DROP BUDDY-MIN-BYTES THEN
|
|
BUDDY-ORDER-FROM-BYTES DUP [[ ' BUDDY-ALLOCATE ]] CATCH ?DUP IF
|
|
DUP EXCP-HEAP-OVERFLOW <> IF RETHROW THEN DROP
|
|
BUDDY-MAX-BYTES MMAP-ALLOCATE-ALIGNED BUDDY-ORDERS 1- BUDDY-FREE
|
|
BUDDY-ALLOCATE
|
|
THEN
|
|
THEN
|
|
TUCK MEMBLOCK>SIZE !
|
|
MEMBLOCK-MAGIC OVER MEMBLOCK>MAGIC !
|
|
MEMBLOCK>DATA ;
|
|
|
|
: FREE ( obj-addr -- )
|
|
?DUP IF
|
|
DATA>MEMBLOCK ▪ 0 OVER MEMBLOCK>MAGIC ! ▪ DUP MEMBLOCK>SIZE @
|
|
DUP BUDDY-ORDERS U< IF BUDDY-FREE ELSE MMAP-UNMAP THEN
|
|
THEN ;
|
|
|
|
' UTILITY (DEFINITIONS)
|
|
|
|
: OBJECT-SIZE ( obj-addr -- size )
|
|
DUP IF
|
|
DATA>MEMBLOCK
|
|
DUP MEMBLOCK>MAGIC @ MEMBLOCK-MAGIC <> IF EXCP-INVALID-ADDRESS THROW THEN
|
|
MEMBLOCK>SIZE @ DUP BUDDY-ORDERS U< IF BUDDY-ORDER-BYTES THEN
|
|
MEMBLOCK-DATA-OFFSET -
|
|
THEN ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ If size is 0 then free obj-addr1 (which may be NULL) and return NULL
|
|
\ Otherwise if obj-addr1 is NULL then allocate size bytes
|
|
\ If neither obj-addr1 nor size is 0 then return an object with allocated size
|
|
\ greater than or equal to size containing the same bytes as obj-addr1 up to
|
|
\ size or the original object size, whichever is less
|
|
\ The returned address may be equal to obj-addr1; if it is not, the original
|
|
\ obj-addr1 is freed and no longer valid
|
|
: RESIZE ( obj-addr1 size -- obj-addr1 | obj-addr2 | NULL )
|
|
DUP 0= IF DROP FREE NULL EXIT THEN
|
|
OVER NULL= IF NIP ALLOCATE EXIT THEN
|
|
OVER OBJECT-SIZE MEMBLOCK-DATA-OFFSET +
|
|
OVER MEMBLOCK-DATA-OFFSET + BUDDY-MIN-BYTES UMAX
|
|
2DUP U>= IF
|
|
\ Allocated space is larger than requested size, shrink if <= 50% used
|
|
( S: obj-addr1 size obj-size req-size )
|
|
SWAP 2/ U> IF DROP EXIT THEN
|
|
ELSE
|
|
\ Allocated space is smaller, must reallocate
|
|
( S: obj-addr1 size obj-size req-size )
|
|
2DROP
|
|
THEN
|
|
( S: obj-addr1 size )
|
|
TUCK ALLOCATE
|
|
( S: size obj-addr1 obj-addr2 )
|
|
OVER >R OVER OBJECT-SIZE >R ROT R> UMIN OVER >R
|
|
( S: obj-addr1 obj-addr2 copy-size R: obj-addr1 obj-addr2 )
|
|
CMOVE R> R> FREE ;
|
|
|
|
\ Allocate memory to hold a copy of the data describe by c-addr and u
|
|
\ This can be used to duplicate strings
|
|
: DUPLICATE ( c-addr u -- obj-addr u )
|
|
DUP ALLOCATE >R >R 2R@ CMOVE 2R> ;
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
\ Execute the closure captured at a-addr
|
|
\ The memory at a-addr consists of a cell count, an xt, and >=0 cells of data
|
|
\ The cell count includes the xt and must be >=1
|
|
\ For example, if a-addr points to "4 xt x1 x2 x3" (ascending addresses) then
|
|
\ this is equivalent to the sequence "x3 x2 x1 xt EXECUTE"
|
|
: (CLOSURE) ( i*x a-addr -- j*x )
|
|
DUP @ SWAP CELL+ N@ EXECUTE ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Read one cell and increment
|
|
: @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ;
|
|
|
|
\ Store cell and increment; note the arguments are opposite of ! to improve flow
|
|
: !(+) ( a-addr1 data -- a-addr2 ) OVER ! CELL+ ;
|
|
|
|
\ Store xt1 and xu ... x1 in a "closure object" and return an execution token.
|
|
\ The execution token may be passed to FREE-CLOSURE to release the memory when
|
|
\ the closure is no longer needed. When executed, the closure xt will place
|
|
\ xu ... x1 on the data stack and then execute the captured xt1.
|
|
: CLOSURE ( xu ... x1 xt1 u -- xt2 )
|
|
1+ DUP 5 + CELLS ALLOCATE DUP 2 CELLS+ >R
|
|
\ name(0) link(NULL) codeword dataword #words xt x1 x2 x3 …
|
|
0 !(+) NULL !(+) DODOES !(+) [[ ' (CLOSURE) >DFA @ ]] !(+) OVER !(+) N! R> ;
|
|
|
|
\ Return a closure which executes xt1 followed by xt2
|
|
: COMPOSE ( xt1 xt2 -- xt3 )
|
|
{ >R EXECUTE R> EXECUTE } 2 CLOSURE ;
|
|
|
|
\ The xt points to the codeword, which is two cells above the base of the object
|
|
: FREE-CLOSURE ( closure-xt -- ) 2 CELLS- FREE ;
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
0x33A110CA CONSTANT ALLOCA-MARK
|
|
|
|
: ?ALLOCA-MARK R> R@ ALLOCA-MARK <> "mismatched UNALLOCA" ?FAIL >R ;
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ NOTE: ALLOCA, UNALLOCA, and %ALLOCA all assume that the return address
|
|
\ ("nest-sys" in ANS FORTH) is a single cell which may be relocated.
|
|
|
|
\ Allocate some space from the return stack; must release with UNALLOCA
|
|
: ALLOCA ( bytes -- a-addr )
|
|
R> RSP@ ROT OVER SWAP - -8 AND DUP RSP! -ROT >R ALLOCA-MARK >R >R ;
|
|
|
|
\ Release return-stack space reserved with ALLOCA
|
|
: UNALLOCA R> ?ALLOCA-MARK RDROP R> RSP! >R ;
|
|
|
|
\ Reserve data or heap space for a data structure given alignment and size
|
|
\ It is assumed that ALLOCATE and ALLOCA (but not ALLOT) return addresses
|
|
\ suitably aligned for any primitive data type; %ALLOCATE and %ALLOCA are
|
|
\ not suitable for data structures with unusually high alignment requirements
|
|
\ %ALLOCATE must be paired with FREE; %ALLOCA must be paired with UNALLOCA
|
|
: %ALLOT ( align bytes -- a-addr ) SWAP ALIGN-TO HERE SWAP ALLOT ;
|
|
: %ALLOCATE ( align bytes -- a-addr ) %SIZEOF ALLOCATE ;
|
|
: %ALLOCA ( align bytes -- a-addr ) NIP R> SWAP ALLOCA SWAP >R ;
|
|
|
|
\ Reserve data space for a data structure and give it a name
|
|
\ The content is indeterminate and must be initialized before the first use
|
|
: %VARIABLE ( align bytes "<spaces?>name" -- ) %ALLOT CONSTANT ;
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
\ This structure describes one entry in the search order linked list
|
|
STRUCT
|
|
CELL% FIELD ORDER>LINK
|
|
CELL% FIELD ORDER>WID
|
|
ENDSTRUCT ORDER%
|
|
|
|
VARIABLE CURRENT-ORDER
|
|
NULL CURRENT-ORDER !
|
|
|
|
DEFER MINIMUM-ORDER
|
|
|
|
' FORTH (DEFINITIONS)
|
|
|
|
\ Return the current search order
|
|
: GET-ORDER ( -- widn ... wid1 n )
|
|
{ ?DUP IF DUP ORDER>WID @ >R ORDER>LINK @ RECURSE R> SWAP 1+ THEN }
|
|
0 CURRENT-ORDER @ ROT EXECUTE ;
|
|
|
|
\ Add the word list wid as the first word list in the search order
|
|
\ Semantically equivalent to:
|
|
\ : PUSH-ORDER ( wid -- ) >R GET-ORDER R> SWAP 1+ SET-ORDER ;
|
|
: PUSH-ORDER ( wid -- )
|
|
ORDER% %ALLOCATE TUCK ORDER>WID !
|
|
DUP CURRENT-ORDER XCHG SWAP ORDER>LINK ! ;
|
|
|
|
\ Remove and return the first word list in the search order
|
|
\ Semantically equivalent to:
|
|
\ : POP-ORDER ( -- wid ) GET-ORDER 1- SWAP >R SET-ORDER R> ;
|
|
: POP-ORDER ( -- wid | NULL )
|
|
CURRENT-ORDER @ DUP IF
|
|
DUP ORDER>LINK @ CURRENT-ORDER !
|
|
DUP ORDER>WID @ SWAP FREE
|
|
THEN ;
|
|
|
|
\ Return the first word list in the search order
|
|
: PEEK-ORDER ( -- wid | NULL )
|
|
CURRENT-ORDER @ DUP IF ORDER>WID @ THEN ;
|
|
|
|
\ Set the current search order
|
|
: SET-ORDER ( widn ... wid1 n | -n -- )
|
|
DUP 0< IF DROP MINIMUM-ORDER THEN
|
|
\ Free the previous search order linked list
|
|
NULL CURRENT-ORDER XCHG BEGIN ?DUP WHILE DUP ORDER>LINK @ SWAP FREE REPEAT
|
|
\ Build the new search order linked list
|
|
0 OVER ?DO I PICK PUSH-ORDER -1 +LOOP NDROP ;
|
|
|
|
\ Make the first list in the search order the current compilation word list
|
|
: DEFINITIONS PEEK-ORDER SET-CURRENT ;
|
|
|
|
\ Run a function for each word in the given word list
|
|
\ xt Execution: ( i*x word-xt -- stop-flag j*x )
|
|
: WITH-WORDLIST ( i*x wid xt -- j*x )
|
|
>R @ BEGIN ?DUP WHILE
|
|
>R 2R@ SWAP EXECUTE IF RDROP 0 ELSE R> >LINK @ THEN
|
|
REPEAT RDROP ;
|
|
|
|
\ Like WITH-WORDLIST but only runs the function for visible (non-hidden) words
|
|
: WITH-VISIBLE ( x*i wid xt -- x*j )
|
|
SWAP { DUP HIDDEN? IF DROP FALSE ELSE SWAP DUP >R EXECUTE R> SWAP THEN }
|
|
WITH-WORDLIST DROP ;
|
|
|
|
\ Display the name of each visible word in the given word list
|
|
: SHOW-WORDLIST ( wid -- ) { >NAME TYPE SPACE FALSE } WITH-VISIBLE EOL ;
|
|
|
|
\ Return the number of visible words in the given word list
|
|
: COUNT-WORDLIST ( wid -- n ) 0 SWAP { DROP 1+ FALSE } WITH-VISIBLE ;
|
|
|
|
\ Look up a name in a word list and return the execution token and immediate flag
|
|
\ If the name is not found return the name with the status value 0
|
|
\ If the name is an immediate word return the execution token with status -1
|
|
\ Otherwise return the execution token with status 1
|
|
: SEARCH-WORDLIST ( c-addr u wid -- c-addr u 0 | xt 1 | xt -1 )
|
|
SWAP F_LENMASK UMIN 0 ROT {
|
|
>R DROP 2DUP R@ >NAME COMPARE 0= IF
|
|
2DROP R> DUP IMMEDIATE? 1 OR TRUE
|
|
ELSE
|
|
RDROP 0 FALSE
|
|
THEN
|
|
} WITH-VISIBLE ;
|
|
|
|
\ Search-Order extension words
|
|
: ALSO PEEK-ORDER PUSH-ORDER ;
|
|
: ONLY -1 SET-ORDER ;
|
|
: ORDER
|
|
"Order:" TYPE GET-ORDER 0 ?DO SPACE U. LOOP EOL
|
|
"Current: " TYPE GET-CURRENT U. EOL ;
|
|
: PREVIOUS POP-ORDER DROP ;
|
|
|
|
\ Create a unnamed word list
|
|
\ In this implementation a word list is just a pointer to the most recent word
|
|
: WORDLIST ( -- wid )
|
|
ALIGN HERE NULL , ;
|
|
|
|
\ Define a new named word list
|
|
\ Executing the word will replace the first item in the search order
|
|
: VOCABULARY ( "<spaces?>name" )
|
|
CREATE NULL ,
|
|
DOES> POP-ORDER DROP PUSH-ORDER ;
|
|
|
|
' SYSTEM (DEFINITIONS)
|
|
|
|
VOCABULARY ROOT
|
|
{ [[ ' ROOT >WORDLIST ]] 1 } ' MINIMUM-ORDER DEFER!
|
|
|
|
\ Redefine the predefined word lists as named vocabularies
|
|
\ FORTH is a Search-Order extension word
|
|
: CONVERT ( xt -- )
|
|
[[ ' ROOT >CFA @ ]] OVER >CFA !
|
|
[[ ' ROOT >DFA @ ]] SWAP >DFA ! ;
|
|
|
|
' FORTH CONVERT
|
|
' UTILITY CONVERT
|
|
' SYSTEM CONVERT
|
|
' LINUX CONVERT
|
|
|
|
' CONVERT (HIDE)
|
|
|
|
\ Prepare the initial search order
|
|
BOOTSTRAP-WORDLIST ▪ ' LINUX >WORDLIST ▪ ' UTILITY >WORDLIST
|
|
' SYSTEM >WORDLIST ▪ ' FORTH >WORDLIST ▪ DUP ▪ 6 SET-ORDER
|
|
|
|
\ Use the real search order as the bootstrap search order from now on
|
|
' GET-ORDER ' BOOTSTRAP-GET-ORDER DEFER!
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
\ Create a word to revert the search order, data space, and compilation word list
|
|
\ to their respective states from immediately before the marker was defined.
|
|
\ An ambiguous condition exists if anything defined after the marker is referenced
|
|
\ after the marker word is executed, including words created in other word lists.
|
|
: MARKER ( "<spaces?>name<space>" -- )
|
|
HERE ▪ LATEST ▪ GET-CURRENT ▪ GET-ORDER
|
|
CREATE ▪ DUP 4 + ▪ DUP 1+ ▪ HERE ▪ OVER CELLS ALLOT ▪ N!
|
|
DOES> @(+) SWAP N@ ▪ SET-ORDER ▪ SET-CURRENT ▪ LATEST! ▪ CP ! ;
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
DEFER FIND-HOOK ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
|
|
{ 0 } ' FIND-HOOK DEFER!
|
|
|
|
ROOT DEFINITIONS
|
|
|
|
' ONLY ALIAS ONLY
|
|
' FORTH ALIAS FORTH
|
|
' ALSO ALIAS ALSO
|
|
' PREVIOUS ALIAS PREVIOUS
|
|
' GET-ORDER ALIAS GET-ORDER
|
|
' SET-ORDER ALIAS SET-ORDER
|
|
' VOCABULARY ALIAS VOCABULARY
|
|
' >WORDLIST ALIAS >WORDLIST
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
\ Apply SEARCH-WORDLIST to each word list in the current search order
|
|
: FIND ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
|
|
FIND-HOOK ?DUP IF EXIT THEN
|
|
2>R GET-ORDER
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
1- SWAP
|
|
2R> ROT SEARCH-WORDLIST
|
|
?DUP IF 2>R NDROP 2R> EXIT THEN
|
|
2>R
|
|
REPEAT
|
|
2R> 0 ;
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
\ Same as FIND except that unknown words are reported and result in a call to THROW
|
|
: FIND-OR-THROW ( c-addr u -- xt 1 | xt -1 )
|
|
FIND ?DUP 0= IF EXCP-UNDEFINED-WORD -ROT THROW-STRING THEN ;
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
\ Read a word from the input (during runtime) and return its execution token
|
|
\ Aborts if the word is not found in the current (runtime) search order list
|
|
: ' ( "<spaces?>name" -- xt ) PARSE-NAME FIND-OR-THROW DROP ;
|
|
|
|
\ Read a word and append its compilation semantics to the current definition.
|
|
: POSTPONE ( "<spaces?>name" -- ) IMMEDIATE
|
|
PARSE-NAME FIND-OR-THROW 0< IF
|
|
COMPILE,
|
|
ELSE
|
|
POSTPONE LITERAL
|
|
POSTPONE COMPILE,
|
|
THEN ;
|
|
|
|
\ Shorthand for { ' <name> DEFER! } or { [[ ' <name> ]] DEFER! } depending on STATE
|
|
\ If used during compilation, capture the name immediately but set target at runtime
|
|
: IS ( "<spaces?>name" -- ; xt -- ) IMMEDIATE
|
|
( Interpret: xt "<spaces?>name" -- )
|
|
' STATE @ IF POSTPONE LITERAL POSTPONE DEFER! ELSE DEFER! THEN ;
|
|
|
|
: ACTION-OF ( "<spaces?>name" -- ; -- xt ) IMMEDIATE
|
|
' STATE @ IF POSTPONE LITERAL POSTPONE DEFER@ ELSE DEFER@ THEN ;
|
|
|
|
: DEFERS ( "<spaces?>name" -- ; i*x -- j*x ) IMMEDIATE
|
|
' DEFER@ COMPILE, ;
|
|
|
|
\ When compiling, append code to store to the data field area of the named value.
|
|
\ When interpreting, store to the data field directly.
|
|
\ An ambiguous condition exists if the name was not created with VALUE.
|
|
: TO ( x "<spaces?>name" -- ) IMMEDIATE
|
|
' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ;
|
|
|
|
\ Hide the named word: HIDE <name>
|
|
: HIDE ( "<spaces?>name" -- ) ' (HIDE) ;
|
|
|
|
\ Begin a new colon definition; hide & redirect the previous
|
|
\ (deferred) word with the same name to the new definition
|
|
: :FINALIZE ( "<spaces?>name" -- )
|
|
: LATEST DUP >NAME FIND-OR-THROW DROP DUP (HIDE) DEFER! ;
|
|
|
|
\ Produce the size or alignment of the subsequent type descriptor as a literal
|
|
\ The type-name should be a word like CELL% returning an alignment and a size
|
|
: SIZEOF ( "<spaces?><type-name>" -- size ) IMMEDIATE
|
|
' EXECUTE %SIZEOF STATE @ IF POSTPONE LITERAL THEN ;
|
|
: ALIGNOF ( "<spaces?><type-name>" -- size ) IMMEDIATE
|
|
' EXECUTE %ALIGNOF STATE @ IF POSTPONE LITERAL THEN ;
|
|
|
|
\ Produce the offset of the subsequent field name as a literal
|
|
\ The field-name should be a word which adds a field offset to a given address
|
|
: OFFSETOF ( "<spaces?><field-name>" -- ; -- offset ) IMMEDIATE
|
|
0 ' EXECUTE STATE @ IF POSTPONE LITERAL THEN ;
|
|
|
|
\ At runtime subtract the offset of a named field from the given address
|
|
\ As an optimization, if the field offset is zero then this generates no code
|
|
: CONTAINEROF ( "<spaces?><field-name>" -- ; field-addr -- struct-addr ) IMMEDIATE
|
|
0 ' EXECUTE STATE @ IF ?DUP IF POSTPONE LITERAL POSTPONE - THEN ELSE - THEN ;
|
|
|
|
\ Store x at addr, saving the original value, and then execute xt
|
|
\ When xt returns normally or THROWs (without CATCH), restore the saved value
|
|
: !LOCALLY ( i*x xt x addr -- j*x )
|
|
TUCK XCHG >R >R CATCH 2R> ! RETHROW ;
|
|
|
|
\ Save the single-cell value at addr and then execute xt
|
|
\ When xt returns normally or THROWs (without CATCH), restore the saved value
|
|
: PRESERVED ( i*x xt addr -- j*x )
|
|
DUP @ >R >R CATCH 2R> ! RETHROW ;
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
\ The size of this buffer will determine the maximum line length
|
|
4096 CONSTANT TERMINAL-BUFFER-BYTES
|
|
TERMINAL-BUFFER-BYTES ALLOCATE CONSTANT TERMINAL-BUFFER
|
|
|
|
\ If we read more than one line then these will refer to the rest of the data
|
|
2VARIABLE TIB-LEFTOVER
|
|
NULL 0 TIB-LEFTOVER 2!
|
|
|
|
\ Placeholder for later support for input from files
|
|
DEFER REFILL-FROM-FILE
|
|
' FALSE IS REFILL-FROM-FILE
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
\ Attempt to replace the parse area with the next line from the current source
|
|
\ Return TRUE if the parse area was refilled, or FALSE otherwise
|
|
\ REFILL always fails if the current source is a string (from EVALUATE)
|
|
:FINALIZE REFILL ( -- flag )
|
|
SOURCE-ID -1 = IF FALSE EXIT THEN
|
|
SOURCE-ID 0> IF REFILL-FROM-FILE EXIT THEN
|
|
\ Shift any leftover characters after the previous line to the start of the buffer
|
|
TIB-LEFTOVER 2@ TERMINAL-BUFFER SWAP DUP >R CMOVE
|
|
\ Look for the linefeed character which marks the end of the first line
|
|
R> 0 BEGIN
|
|
\ If at the end with room in the buffer, read more from the file descriptor
|
|
2DUP = IF
|
|
DUP TERMINAL-BUFFER-BYTES U< IF
|
|
STDIN OVER TERMINAL-BUFFER TERMINAL-BUFFER-BYTES ROT /STRING
|
|
( S: length idx src-id buff buff-size )
|
|
SYS_READ SYSCALL3-RETRY DUP 0< IF EXCP-FILE-IO THROW THEN
|
|
( S: length idx u-read )
|
|
\ Add the amount of data read to the length; index is unchanged
|
|
ROT + SWAP
|
|
THEN
|
|
THEN
|
|
\ At this point if index equals length then buffer is full or read returned 0
|
|
\ Either way, we won't be reading any more into the buffer
|
|
2DUP <>
|
|
WHILE
|
|
\ Check if the next character is a linefeed
|
|
1+ DUP 1- TERMINAL-BUFFER + C@ LF =
|
|
UNTIL
|
|
( S: length idx )
|
|
\ idx is the next location after the linefeed, if found, or else equal to length
|
|
\ Save the rest, if any, for the next REFILL
|
|
TUCK - >R TERMINAL-BUFFER OVER + R> TIB-LEFTOVER 2!
|
|
( S: idx )
|
|
\ The new input buffer is the first idx characters of the terminal buffer
|
|
TERMINAL-BUFFER OVER INPUT-BUFFER 2!
|
|
DUP IF 0 >IN ! THEN
|
|
0<> ;
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
\ Parse up to limit digits in the given base, appending them to u1 to produce u2.
|
|
: ESCAPED-DIGITS ( u1 base limit -- u2 )
|
|
0 ?DO
|
|
PEEK-CHAR OVER >DIGIT-BASE 0= IF LEAVE THEN
|
|
SKIP-CHAR ▪ >R TUCK * ▪ R> + SWAP
|
|
LOOP ▪ DROP ;
|
|
|
|
\ Read one logical string character, which may be an escape sequence
|
|
: ESCAPED-CHAR ( "<escapeseq>" | "c" -- c )
|
|
NEXT-CHAR DUP [[ CHAR \ ]] = IF
|
|
DROP NEXT-CHAR CASE
|
|
[[ CHAR a ]] OF 7 ENDOF
|
|
[[ CHAR b ]] OF 8 ENDOF
|
|
[[ CHAR t ]] OF 9 ENDOF
|
|
[[ CHAR n ]] OF 10 ENDOF
|
|
[[ CHAR v ]] OF 11 ENDOF
|
|
[[ CHAR f ]] OF 12 ENDOF
|
|
[[ CHAR r ]] OF 13 ENDOF
|
|
[[ CHAR e ]] OF 27 ENDOF
|
|
[[ CHAR " ]] OF [[ CHAR " ]] ENDOF
|
|
[[ CHAR ' ]] OF [[ CHAR ' ]] ENDOF
|
|
[[ CHAR \ ]] OF [[ CHAR \ ]] ENDOF
|
|
DUP TO-LOWER [[ CHAR x ]] = OF? DROP
|
|
NEXT-CHAR 16 >DIGIT-BASE 0= "Invalid \\x… escape sequence" ?FAIL
|
|
16 1 ESCAPED-DIGITS
|
|
ENDOF
|
|
DUP 8 >DIGIT-BASE 0= "Unknown escape sequence" ?FAIL
|
|
8 2 ESCAPED-DIGITS SWAP
|
|
ENDCASE
|
|
THEN ;
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
2VARIABLE STRING-BUFFER
|
|
NULL 0 STRING-BUFFER 2!
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
\ Read a literal character string up to the next double-quote character
|
|
\ The string is stored in a transient buffer and will become invalid when
|
|
\ the next string is read; both the address and content may change
|
|
\ The delimiting double-quote character is removed from the input buffer
|
|
\ Double-quote and backslash characters can be escaped with a backslash
|
|
: READSTRING ( "ccc<doublequote>" -- c-addr u )
|
|
STRING-BUFFER 2@ 0
|
|
( S: addr length index )
|
|
BEGIN
|
|
PARSE-EMPTY? 0=
|
|
WHILE
|
|
PEEK-CHAR [[ CHAR " ]] <>
|
|
DUP 0= IF SKIP-CHAR THEN
|
|
WHILE
|
|
2DUP <= IF
|
|
\ Grow the buffer by at least 50% + 16 bytes
|
|
\ Store the actual allocated object size, not the requested size
|
|
-ROT DUP U2/ + 16 + RESIZE DUP OBJECT-SIZE
|
|
2DUP STRING-BUFFER 2! ROT
|
|
THEN
|
|
ROT 2DUP + ESCAPED-CHAR SWAP C! -ROT 1+
|
|
REPEAT ▪ NIP ;
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
: ?STACK SP@ S0 > IF ▪ S0 SP! ▪ EXCP-STACK-UNDERFLOW THROW ▪ THEN ;
|
|
|
|
\ Read a series of words, numbers, and strings and execute them or compile them
|
|
\ The stack effect depends on the input and the current value of STATE
|
|
: INTERPRET ( i*x "<spaces?>ccc…" -- j*x )
|
|
BEGIN
|
|
SKIP-SPACES
|
|
PARSE-EMPTY? 0=
|
|
WHILE
|
|
PEEK-CHAR [[ CHAR " ]] = IF
|
|
SKIP-CHAR
|
|
READSTRING
|
|
STATE @ IF
|
|
POSTPONE LITSTRING
|
|
255 UMIN DUP C,
|
|
HERE SWAP DUP ALLOT CMOVE ALIGN
|
|
THEN
|
|
ELSE
|
|
PARSE-NAME 2>R
|
|
2R@ PARSENUMBER ?DUP IF
|
|
2RDROP
|
|
STATE @ 0= IF
|
|
DROP
|
|
ELSE 2 = IF
|
|
POSTPONE 2LITERAL
|
|
ELSE
|
|
POSTPONE LITERAL
|
|
THEN THEN
|
|
ELSE
|
|
2R> FIND-OR-THROW
|
|
\ -1 => immediate word; execute regardless of STATE
|
|
\ 1 => read STATE; compile if true, execute if false
|
|
0> IF ▪ STATE @ AND-IF ▪ COMPILE, ▪ ELSE EXECUTE ▪ THEN
|
|
THEN
|
|
THEN
|
|
?STACK
|
|
REPEAT ;
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
: EVALUATE ( i*x c-addr u -- j*x )
|
|
SAVE-INPUT N>R ▪ SOURCE 2>R ▪ SOURCE-ID >R
|
|
0 >IN ! ▪ INPUT-BUFFER 2! ▪ -1 CURRENT-SOURCE-ID ! ▪ INTERPRET
|
|
R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP ;
|
|
|
|
LINUX DEFINITIONS
|
|
|
|
' unsigned-char% ALIAS cc%
|
|
' unsigned-int% ALIAS speed%
|
|
' unsigned-int% ALIAS tcflag%
|
|
|
|
19 CONSTANT NCCS
|
|
|
|
STRUCT
|
|
tcflag% FIELD termios>iflag
|
|
tcflag% FIELD termios>oflag
|
|
tcflag% FIELD termios>cflag
|
|
tcflag% FIELD termios>lflag
|
|
cc% FIELD termios>line
|
|
cc% NCCS * FIELD termios>cc
|
|
ENDSTRUCT termios%
|
|
|
|
0x5401 CONSTANT IOCTL_TCGETS
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
: TTY? ( fd -- flag )
|
|
IOCTL_TCGETS termios% %ALLOCA SYS_IOCTL SYSCALL3 UNALLOCA 0= ;
|
|
|
|
STDIN TTY? CONSTANT INTERACTIVE?
|
|
|
|
\ Empty the return stack, make stdin the input source, and enter interpretation state
|
|
:FINALIZE QUIT ( -- <noreturn> )
|
|
CATCHING? IF EXCP-QUIT THROW THEN
|
|
R0 RSP!
|
|
0 CURRENT-SOURCE-ID !
|
|
FALSE STATE !
|
|
BEGIN
|
|
[ INTERACTIVE? ] [IF] "> " TYPE [THEN]
|
|
REFILL 0= IF BYE THEN
|
|
INTERPRET
|
|
[ INTERACTIVE? ] [IF]
|
|
STATE @ 0= IF DEPTH IF .S THEN "OK\n" TYPE THEN
|
|
[THEN]
|
|
AGAIN ;
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
32 CONSTANT #REPORTERS
|
|
#REPORTERS 2ARRAY REPORTERS ( reporter-xt exception-code )
|
|
|
|
MARKER REVERT
|
|
{ #REPORTERS 0 ?DO NULL 0 I REPORTERS 2! LOOP } EXECUTE
|
|
REVERT
|
|
|
|
\ Return the matching entry, the next empty slot, or NULL if neither exists
|
|
: REPORTER ( n -- addr t=match )
|
|
DUP HASHCELL ▪ DUP #REPORTERS + SWAP ?DO
|
|
I #REPORTERS 1- AND ▪ REPORTERS
|
|
2DUP 2@ SWAP -ROT = TUCK SWAP NULL= OR IF
|
|
ROT DROP UNLOOP EXIT
|
|
THEN ▪ 2DROP
|
|
LOOP ▪ DROP NULL FALSE ;
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
\ Set the reporter for the given exception code
|
|
: REPORTER! ( xt n -- ) ( xt: -- )
|
|
DUP REPORTER DROP ▪ DUP NULL= "hash table is full" ?FAIL ▪ 2! ;
|
|
|
|
\ Run the reporter for the given exception code, or give the default report
|
|
: REPORT ( n -- )
|
|
DUP REPORTER IF
|
|
NIP 2@ DROP EXECUTE
|
|
ELSE
|
|
DROP ▪ "Uncaught exception: " TYPE-ERR
|
|
DUP ▪ ABS 0 <# #S ROT SIGN #> ▪ TYPE-ERR EOL ;
|
|
THEN ;
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
{ ( no message for ABORT ) } EXCP-ABORT REPORTER!
|
|
{ THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR } EXCP-FAIL REPORTER!
|
|
{ "Stack overflow\n" TYPE-ERR } EXCP-STACK-OVERFLOW REPORTER!
|
|
{ "Stack underflow\n" TYPE-ERR } EXCP-STACK-UNDERFLOW REPORTER!
|
|
{ "Return stack overflow\n" TYPE-ERR } EXCP-RETURN-OVERFLOW REPORTER!
|
|
{ "Return stack underflow\n" TYPE-ERR } EXCP-RETURN-UNDERFLOW REPORTER!
|
|
{ "Dictionary overflow\n" TYPE-ERR } EXCP-DICTIONARY-OVERFLOW REPORTER!
|
|
{ "Invalid memory address\n" TYPE-ERR } EXCP-INVALID-ADDRESS REPORTER!
|
|
{ "Argument type mismatch\n" TYPE-ERR } EXCP-TYPE-MISMATCH REPORTER!
|
|
{ "Undefined word: " TYPE-ERR THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR }
|
|
EXCP-UNDEFINED-WORD REPORTER!
|
|
{ "Pictured numeric output string overflow\n" TYPE-ERR }
|
|
EXCP-PNO-OVERFLOW REPORTER!
|
|
{ "Invalid numeric argument\n" TYPE-ERR } EXCP-BAD-NUMERIC-ARGUMENT REPORTER!
|
|
{ "Non-existent file\n" TYPE-ERR } EXCP-NON-EXISTENT-FILE REPORTER!
|
|
{ "File I/O exception\n" TYPE-ERR } EXCP-FILE-IO REPORTER!
|
|
{ "Unexpected end of file\n" TYPE-ERR } EXCP-UNEXPECTED-EOF REPORTER!
|
|
{ "Quit\n" TYPE-ERR } EXCP-QUIT REPORTER!
|
|
|
|
{ "Out of memory\n" TYPE-ERR } EXCP-HEAP-OVERFLOW REPORTER!
|
|
{ "Uninitialized deferred word\n" TYPE-ERR } EXCP-DEFER-UNINITIALIZED REPORTER!
|
|
|
|
: DEFAULT-UNWIND ( i*x n -- <noreturn> ) REPORT S0 SP! QUIT ;
|
|
' DEFAULT-UNWIND IS THROW-UNWIND
|
|
|
|
\ Switch to the interpreter defined in this startup file
|
|
\ Process the rest of the startup file and then switch to terminal input
|
|
{ PARSE-AREA EVALUATE QUIT } EXECUTE
|
|
|
|
\ *****************************************************************************
|
|
\ Bootstrapping is complete
|
|
\ From this point on we only execute threaded FORTH words defined in this file
|
|
\ *****************************************************************************
|
|
|
|
ONLY FORTH ALSO
|
|
UTILITY ALSO
|
|
SYSTEM ALSO
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
STRUCT
|
|
CELL% FIELD LOCAL>LINK
|
|
CELL% FIELD LOCAL>LENGTH
|
|
CHAR% 0 * FIELD LOCAL>NAME-ADDR
|
|
ENDSTRUCT LOCAL%
|
|
|
|
\ Parameterize LOCAL% to include the length of the name
|
|
: LOCAL% ( u -- align bytes ) >R LOCAL% R> + ;
|
|
|
|
: LOCAL>NAME ( local -- c-addr u ) DUP LOCAL>NAME-ADDR SWAP LOCAL>LENGTH @ ;
|
|
|
|
NULL VALUE LOCAL-NAMES
|
|
|
|
8 CONSTANT #LOCALS
|
|
#LOCALS ARRAY LOCAL-FETCHERS
|
|
#LOCALS ARRAY LOCAL-STORERS
|
|
|
|
MARKER REVERT
|
|
{ #LOCALS 0 ?DO ' I LOCAL-FETCHERS ! ' I LOCAL-STORERS ! LOOP } EXECUTE
|
|
L0@ L0! L1@ L1! L2@ L2! L3@ L3!
|
|
L4@ L4! L5@ L5! L6@ L6! L7@ L7!
|
|
REVERT
|
|
|
|
: LOCAL-INDEX ( c-addr u1 -- u2 TRUE | FALSE )
|
|
LOCAL-NAMES #LOCALS 0 ?DO
|
|
DUP NULL= IF LEAVE THEN
|
|
>R 2DUP R@ LOCAL>NAME COMPARE R> SWAP 0= IF
|
|
DROP 2DROP I TRUE UNLOOP EXIT
|
|
THEN
|
|
LOCAL>LINK @
|
|
LOOP ▪ DROP ▪ 2DROP ▪ FALSE ;
|
|
|
|
: LOCAL-LOOKUP ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
|
|
2DUP FALSE >R
|
|
DUP 1 > IF ▪ 2DUP + 1- C@ [[ CHAR ! ]] = IF ▪ 1- RDROP TRUE >R ▪ THEN ▪ THEN
|
|
LOCAL-INDEX 0= IF RDROP 0 EXIT THEN
|
|
R> 2NIP IF LOCAL-STORERS ELSE LOCAL-FETCHERS THEN @ 1 ;
|
|
|
|
{ LOCAL-LOOKUP ?DUP 0= IF DEFERS FIND-HOOK THEN } IS FIND-HOOK
|
|
|
|
\ The environment consists of an array of pointers to "name=value" C strings
|
|
\ immediately following the NULL-terminated array of argument pointers
|
|
ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
\ Convert a C string to a FORTH string by counting the characters
|
|
: CSTRING ( c-addr -- c-addr u ) 0 BEGIN 2DUP + C@ WHILE 1+ REPEAT ;
|
|
|
|
\ Return the string value of the named environment variable
|
|
: GETENV ( c-addr u -- c-addr2 u2 TRUE | FALSE )
|
|
2>R ENVIRON BEGIN
|
|
DUP @
|
|
DUP WHILE
|
|
0 BEGIN 2DUP + C@ DUP WHILE DUP [[ CHAR = ]] <> WHILE DROP 1+ REPEAT
|
|
IF 2DUP + 1+ CSTRING ELSE 0 0 THEN 2SWAP
|
|
2R@ COMPARE 0= IF 2RDROP ROT DROP TRUE EXIT THEN
|
|
2DROP CELL+
|
|
REPEAT ▪ NIP ▪ 2RDROP ;
|
|
|
|
\ Return the string value of the numbered command-line argument
|
|
\ Argument 0 is (normally) the pathname of the current program
|
|
: ARGV ( u -- c-addr u )
|
|
DUP ARGC U>= IF DROP 0 0 ELSE ARGV SWAP CELLS+ @ CSTRING THEN ;
|
|
|
|
: LOCALS| ( "<spaces?>name1…<spaces>namen<spaces>|" -- ; xn … x1 -- ) IMMEDIATE
|
|
LOCAL-NAMES ▪ NULL TO LOCAL-NAMES
|
|
0 BEGIN
|
|
PARSE-NAME
|
|
2DUP "|" COMPARE 0<>
|
|
WHILE
|
|
DUP LOCAL% %ALLOCATE
|
|
LOCAL-NAMES OVER LOCAL>LINK !
|
|
2DUP LOCAL>LENGTH !
|
|
>R R@ LOCAL>NAME-ADDR SWAP CMOVE
|
|
R> TO LOCAL-NAMES
|
|
1+
|
|
REPEAT ▪ 2DROP ▪ POSTPONE LITERAL POSTPONE N>R ;
|
|
|
|
: UNLOCALS IMMEDIATE POSTPONE NRDROP ;
|
|
|
|
: ENDLOCALS IMMEDIATE
|
|
LOCAL-NAMES BEGIN ?DUP WHILE DUP LOCAL>LINK @ SWAP FREE REPEAT
|
|
TO LOCAL-NAMES ▪ POSTPONE UNLOCALS ;
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
: (TRACE) ( xt -- ) >NAME TYPE SPACE .S ;
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
\ Define a threaded word which also displays its name and the data stack when called
|
|
: :TRACE ( "<spaces?>name" -- ) : LATEST POSTPONE LITERAL POSTPONE (TRACE) ;
|
|
|
|
\ Return TRUE if the given address is the execution token of a word in
|
|
\ the current search order or compilation word list, or FALSE otherwise
|
|
\ The word's name may be hidden or shadowed by another definition
|
|
: WORD? ( addr -- flag )
|
|
>R ▪ GET-ORDER ▪ GET-CURRENT SWAP 1+
|
|
BEGIN ?DUP WHILE
|
|
1- SWAP R@ FALSE ROT
|
|
( S: widn ... wid1 n addr FALSE wid R: addr )
|
|
\ Inner function: ( addr FALSE xt -- addr FALSE FALSE | addr TRUE TRUE )
|
|
{ NIP OVER = DUP } WITH-WORDLIST
|
|
NIP IF RDROP NDROP TRUE EXIT THEN
|
|
REPEAT ▪ RDROP FALSE ;
|
|
|
|
\ Display the top of the stack as a word name if possible, or a number otherwise
|
|
\ Words with zero-length names (e.g. from :NONAME) are displayed as numbers
|
|
: .W ( addr -- "<name>" | "<digits>" )
|
|
\ Is it some kind of word, and if so, is the name not zero-length (:NONAME)?
|
|
DUP WORD? IF ▪ DUP >NAME NIP 0<> AND-IF
|
|
\ Is the name hidden?
|
|
DUP HIDDEN? IF
|
|
"⌀" TYPE
|
|
ELSE
|
|
\ Does FIND with the same name fail to return the same word?
|
|
DUP >NAME FIND IF ▪ OVER = AND-IF ▪ ELSE
|
|
2DROP "¤" TYPE
|
|
THEN
|
|
THEN
|
|
>NAME TYPE
|
|
ELSE
|
|
\ Not a named word in the current search order or compilation word list
|
|
"∷" TYPE U.
|
|
THEN ;
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
\ Display a string in escaped (double-quoted) format, without the delimiters
|
|
: CONTROL-CHAR? ( ch -- flag ) DUP 32 U< SWAP 127 = OR ;
|
|
: TYPE-ESCAPED ( c-addr u -- "<escapeseq*>" )
|
|
0 ?DO DUP C@
|
|
CASE
|
|
DUP 7 14 WITHIN OF? 7 - 2* "\\a\\b\\t\\n\\v\\f\\r" DROP + 2 ENDOF
|
|
27 OF "\\e" ENDOF
|
|
[[ CHAR " ]] OF "\\\"" ENDOF
|
|
[[ CHAR \ ]] OF "\\\\" ENDOF
|
|
OTHERWISE
|
|
0 <# OVER CONTROL-CHAR? IF 16 #B 16 #B "\\x" HOLDS ELSE OVER HOLD THEN #>
|
|
ENDOF
|
|
ENDCASE ▪ TYPE ▪ 1+
|
|
LOOP ▪ DROP ;
|
|
|
|
\ Recognize the pattern BRANCH a:{c-a} {name} {link} b:{codeword} {…} c:LIT d:{b}
|
|
\ This pattern is generated by the { … } inline :NONAME syntax
|
|
: NONAME-LITERAL? ( a-addr -- flag )
|
|
@(+) [[ ' BRANCH ]] = ?0DUP IF
|
|
DUP @ DUP 5 CELLS >= ?0DUP IF
|
|
( S: addr-a offset-c-a )
|
|
OVER + @(+) [[ ' LIT ]] = ?0DUP IF
|
|
( S: addr-a addr-d )
|
|
@ SWAP 3 CELLS+ OVER = ?0DUP IF
|
|
DUP WORD?
|
|
THEN
|
|
ELSE NIP THEN
|
|
ELSE NIP THEN
|
|
THEN NIP ;
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
\ Display the threaded code which starts at a-addr
|
|
\ Continues until it encounters a reference to EXIT beyond any forward branches
|
|
\ Numeric, string, and { … } literals are decoded, plus offsets for branches
|
|
: UNTHREAD ( a-addr -- ) RECURSIVE
|
|
DUP >R
|
|
BEGIN
|
|
@(+) ▪ DUP [[ ' EXIT ]] <> ▪ ?DUP 0= IF OVER R@ U<= THEN
|
|
WHILE
|
|
CASE
|
|
[[ ' LIT ]] OF
|
|
@(+) DUP WORD? IF "[[ ' " TYPE .W " ]] " TYPE ELSE . SPACE THEN
|
|
ENDOF
|
|
[[ ' 2LIT ]] OF
|
|
"[ " TYPE
|
|
@(+) >R @(+) DUP WORD? IF "' " TYPE .W ELSE U. THEN SPACE
|
|
R> DUP WORD? IF "' " TYPE .W ELSE U. THEN
|
|
" ] 2LITERAL " TYPE
|
|
ENDOF
|
|
[[ ' LITSTRING ]] OF
|
|
DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED
|
|
ENDOF
|
|
OVER CELL- NONAME-LITERAL? OF? DROP
|
|
DUP @ OVER + 2 CELLS+ DUP R> UMAX >R SWAP
|
|
"{ " TYPE 3 CELLS+ >DFA @ UNTHREAD "} " TYPE
|
|
ENDOF
|
|
[[ ' BRANCH ]] OF
|
|
"BRANCH " TYPE
|
|
@(+) DUP "{" TYPE DUP 0>= IF "+" TYPE THEN . "} " TYPE
|
|
OVER CELL- + R> UMAX >R
|
|
ENDOF
|
|
[[ ' 0BRANCH ]] OF
|
|
"0BRANCH " TYPE
|
|
@(+) DUP "{" TYPE DUP 0>= IF "+" TYPE THEN . "} " TYPE
|
|
OVER CELL- + R> UMAX >R
|
|
ENDOF
|
|
DUP WORD? IF DUP IMMEDIATE? AND-IF "POSTPONE " TYPE THEN
|
|
DUP .W SPACE
|
|
ENDCASE
|
|
REPEAT ▪ 2DROP RDROP ;
|
|
|
|
: (SEE) ( xt -- )
|
|
DUP >CFA @ CASE
|
|
DOCOL OF
|
|
DUP >NAME DUP IF ": " TYPE TYPE SPACE ELSE 2DROP ":NONAME " TYPE THEN
|
|
DUP IMMEDIATE? IF "IMMEDIATE " TYPE THEN
|
|
>DFA @ UNTHREAD ";\n" TYPE
|
|
ENDOF
|
|
DODEFER OF
|
|
"DEFER " TYPE DUP >NAME TYPE EOL
|
|
DUP >DFA @ DUP WORD? IF "' " TYPE .W ELSE U. THEN " IS " TYPE >NAME TYPE EOL
|
|
ENDOF
|
|
DODATA OF
|
|
DUP EXECUTE . " CONSTANT " TYPE >NAME TYPE EOL
|
|
ENDOF
|
|
DOLOAD OF
|
|
DUP EXECUTE . " VALUE " TYPE >NAME TYPE EOL
|
|
ENDOF
|
|
DODOES OF
|
|
"CREATE " TYPE DUP >NAME TYPE " … DOES> " TYPE
|
|
>DFA @ UNTHREAD ";\n" TYPE
|
|
ENDOF
|
|
\ Anything else can be assumed to be implemented in assembly
|
|
SWAP "CREATE " TYPE >NAME TYPE " … ;CODE … END-CODE\n" TYPE
|
|
ENDCASE ;
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
: SEE ( "<spaces?>name" -- ) ' (SEE) ;
|
|
|
|
: WORDS
|
|
GET-ORDER ?DUP IF 1- SWAP >R NDROP R> SHOW-WORDLIST THEN ;
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
\ AA Tree, a variation on the Red-Black Tree
|
|
\ <https://en.wikipedia.org/wiki/AA_tree>
|
|
|
|
\ Types:
|
|
\ aa-tree: address of AA-TREE%
|
|
\ aa-node: address of AA-NODE%
|
|
\ aa-value-xt: function ( aa-node -- x )
|
|
\ aa-compare-xt: function ( x1 x2 -- -1 | 0 | 1 )
|
|
|
|
STRUCT
|
|
CELL% FIELD AA>LEVEL ( u )
|
|
CELL% FIELD AA>LEFT ( aa-node|NULL )
|
|
CELL% FIELD AA>RIGHT ( aa-node|NULL )
|
|
ENDSTRUCT AA-NODE%
|
|
|
|
STRUCT
|
|
CELL% FIELD AA>ROOT ( aa-node|NULL )
|
|
CELL% FIELD AA>VALUE ( aa-value-xt )
|
|
CELL% FIELD AA>COMPARE ( aa-compare-xt )
|
|
ENDSTRUCT AA-TREE%
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
: AA-INIT-LEAF ( aa-node -- )
|
|
NULL OVER AA>LEFT ! ▪ NULL OVER AA>RIGHT ! ▪ 1 SWAP AA>LEVEL ! ;
|
|
|
|
: AA-NODE-LEVEL ( aa-node -- u ) ?DUP 0= IF 0 ELSE AA>LEVEL @ THEN ;
|
|
: AA-LEAF? ( aa-node -- t=leaf ) DUP AA>LEFT @ SWAP AA>RIGHT @ OR 0= ;
|
|
|
|
: AA-SKEW ( aa-node1|NULL -- aa-node2|NULL )
|
|
DUP IF ▪ DUP AA>LEFT @ IF ▪ DUP AA>LEVEL @ OVER AA>LEFT @ AA>LEVEL @ = IF
|
|
DUP AA>LEFT TUCK @ ▪ AA>RIGHT XCHG ▪ SWAP XCHG
|
|
THEN ▪ THEN ▪ THEN ;
|
|
|
|
: AA-SPLIT ( aa-node1|NULL -- aa-node2|NULL )
|
|
DUP IF ▪ DUP AA>RIGHT @ IF ▪ DUP AA>RIGHT @ AA>RIGHT @ IF
|
|
DUP AA>LEVEL @ ▪ OVER AA>RIGHT @ AA>RIGHT @ AA>LEVEL @ ▪ = IF
|
|
DUP AA>RIGHT TUCK @ AA>LEFT XCHG SWAP XCHG
|
|
1 OVER AA>LEVEL +!
|
|
THEN
|
|
THEN ▪ THEN ▪ THEN ;
|
|
|
|
\ Insert aa-node1 somewhere under aa-node2 and return the updated subtree
|
|
: AA-INSERT-NODE ( aa-node1 aa-node2|NULL aa-tree -- aa-node3 ) RECURSIVE
|
|
OVER 0= IF ▪ 2DROP DUP AA-INIT-LEAF ▪ EXIT ▪ THEN
|
|
OVER >R ▪ >R 2DUP ▪ R@ AA>VALUE @ EXECUTE SWAP ▪ R@ AA>VALUE @ EXECUTE SWAP
|
|
R@ AA>COMPARE @ EXECUTE ▪ 0< IF AA>LEFT ELSE AA>RIGHT THEN
|
|
TUCK @ R> AA-INSERT-NODE ▪ SWAP ! ▪ R> AA-SKEW AA-SPLIT ;
|
|
|
|
\ Lower level(T) and level(right(T)) to be <= min(level(left(T)), level(right(T))) + 1
|
|
: AA-DECREASE-LEVEL ( aa-node -- )
|
|
DUP AA>LEFT @ AA-NODE-LEVEL ▪ OVER AA>RIGHT @ AA-NODE-LEVEL ▪ UMIN 1+ ▪ SWAP
|
|
2DUP AA>LEVEL @ < IF
|
|
2DUP AA>LEVEL !
|
|
AA>RIGHT @ ▪ DUP IF ▪ 2DUP AA>LEVEL @ < IF 2DUP AA>LEVEL ! THEN ▪ THEN
|
|
THEN ▪ 2DROP ;
|
|
|
|
\ Swap the fields of two AA nodes
|
|
: AA-EXCHANGE ( aa-node1 aa-node2 -- )
|
|
2DUP AA>LEFT ▪ SWAP AA>LEFT ▪ EXCHANGE
|
|
2DUP AA>RIGHT ▪ SWAP AA>RIGHT ▪ EXCHANGE
|
|
AA>LEVEL ▪ SWAP AA>LEVEL ▪ EXCHANGE ;
|
|
|
|
\ aa-node1: The root of the current subtree
|
|
\ aa-node2: The node that was removed, or NULL if there was no match
|
|
\ aa-node3: The new subtree root node, or NULL if the subtree is empty
|
|
: AA-DELETE-NODE ( x aa-tree aa-node1|NULL -- aa-node2|NULL aa-node3|NULL ) RECURSIVE
|
|
DUP NULL= IF NIP NIP NULL EXIT THEN
|
|
LOCALS| x tree node |
|
|
x node tree AA>VALUE @ EXECUTE ▪ tree AA>COMPARE @ EXECUTE
|
|
CASE
|
|
DUP 0< OF? DROP
|
|
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
|
|
ENDOF
|
|
DUP 0> OF? DROP
|
|
x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> !
|
|
ENDOF
|
|
node AA-LEAF? IF DROP node NULL UNLOCALS EXIT THEN
|
|
node AA>LEFT @ NULL= IF
|
|
\ swap current node with its successor in the right subtree
|
|
node AA>RIGHT @ AA>LEFT @ NULL= IF
|
|
\ right child is the successor
|
|
node AA>RIGHT @
|
|
DUP AA>LEVEL node AA>LEVEL EXCHANGE
|
|
DUP AA>LEFT node AA>LEFT EXCHANGE
|
|
node SWAP AA>RIGHT XCHG node AA>RIGHT XCHG node!
|
|
ELSE
|
|
\ leftmost descendent of right child is the successor
|
|
node AA>RIGHT BEGIN DUP @ AA>LEFT DUP @ WHILE NIP REPEAT DROP
|
|
node SWAP XCHG ▪ DUP node AA-EXCHANGE ▪ node!
|
|
THEN
|
|
\ recurse into right subtree
|
|
x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> !
|
|
ELSE
|
|
\ swap current node with its predecessor in the left subtree
|
|
node AA>LEFT @ AA>RIGHT @ NULL= IF
|
|
\ left child is the predecessor
|
|
node AA>LEFT @
|
|
DUP AA>LEVEL node AA>LEVEL EXCHANGE
|
|
DUP AA>RIGHT node AA>RIGHT EXCHANGE
|
|
node SWAP AA>LEFT XCHG node AA>LEFT XCHG node!
|
|
ELSE
|
|
\ rightmost descendent of left child is the predecessor
|
|
node AA>LEFT BEGIN DUP @ AA>RIGHT DUP @ WHILE NIP REPEAT DROP
|
|
node SWAP XCHG ▪ DUP node AA-EXCHANGE ▪ node!
|
|
THEN
|
|
\ recurse into left subtree
|
|
x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> !
|
|
THEN
|
|
SWAP
|
|
ENDCASE ( S: aa-node2|NULL )
|
|
node
|
|
ENDLOCALS
|
|
\ Rebalance the tree
|
|
DUP AA-DECREASE-LEVEL
|
|
AA-SKEW
|
|
DUP AA>RIGHT ▪ DUP @ IF
|
|
DUP DUP >R @ AA-SKEW R> !
|
|
DUP @ AA>RIGHT DUP >R @ AA-SKEW R> !
|
|
THEN DROP
|
|
AA-SPLIT
|
|
DUP AA>RIGHT DUP >R @ AA-SPLIT R> ! ;
|
|
|
|
: AA-TRAVERSE-NODE ( i*x node-xt null-xt aa-node|NULL -- j*x ) RECURSIVE
|
|
DUP NULL= IF DROP NIP EXECUTE EXIT THEN
|
|
LOCALS| node-xt null-xt node |
|
|
node-xt node
|
|
node-xt null-xt node AA>LEFT @ [[ ' AA-TRAVERSE-NODE ]] 3 CLOSURE
|
|
node-xt null-xt node AA>RIGHT @ [[ ' AA-TRAVERSE-NODE ]] 3 CLOSURE
|
|
ENDLOCALS
|
|
LOCALS| node-xt node left-xt right-xt |
|
|
right-xt node left-xt node-xt EXECUTE
|
|
left-xt FREE-CLOSURE
|
|
right-xt FREE-CLOSURE
|
|
ENDLOCALS ;
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
: NEW-AA-TREE ( aa-value-xt aa-compare-xt -- aa-tree )
|
|
AA-TREE% %ALLOCATE ▪ TUCK AA>COMPARE ! ▪ TUCK AA>VALUE ! ▪ NULL OVER AA>ROOT ! ;
|
|
|
|
: FREE-AA-TREE ( aa-tree -- )
|
|
DUP AA>ROOT @ "attempted to free non-empty AA tree" ?FAIL FREE ;
|
|
|
|
: AA-EMPTY? ( aa-tree -- t=empty )
|
|
AA>ROOT @ NULL= ;
|
|
|
|
: AA-INSERT ( aa-node aa-tree -- )
|
|
DUP >R AA>ROOT TUCK @ R> AA-INSERT-NODE SWAP ! ;
|
|
|
|
: AA-DELETE ( x aa-tree -- aa-node|NULL )
|
|
DUP AA>ROOT DUP >R @ AA-DELETE-NODE R> ! ;
|
|
|
|
: AA-LOOKUP ( x aa-tree -- aa-node|NULL )
|
|
DUP AA>ROOT @ -ROT ▪ DUP AA>COMPARE @ ▪ SWAP AA>VALUE @
|
|
LOCALS| x compare-xt value-xt |
|
|
BEGIN
|
|
DUP
|
|
WHILE
|
|
DUP value-xt EXECUTE ▪ x ▪ SWAP compare-xt EXECUTE ▪ ?DUP
|
|
WHILE
|
|
0< IF AA>LEFT ELSE AA>RIGHT THEN @
|
|
REPEAT
|
|
ENDLOCALS ;
|
|
|
|
\ node-xt: ( i*x right-xt aa-node left-xt -- j*x )
|
|
\ null-xt: ( i*x -- j*x )
|
|
\ left-xt, right-xt: call node-xt or null-xt with params for left or right child node
|
|
: AA-TRAVERSE ( i*x node-xt null-xt aa-tree -- j*x )
|
|
AA>ROOT @ AA-TRAVERSE-NODE ;
|
|
|
|
: AA-ITERATE ( i*x xt aa-tree -- j*x )
|
|
AA>ROOT @ ?DUP IF
|
|
NULL >R
|
|
BEGIN
|
|
DUP >R AA>LEFT @
|
|
BEGIN ?DUP 0= WHILE
|
|
R> ?DUP 0= IF DROP EXIT THEN
|
|
2DUP 2>R SWAP EXECUTE 2R>
|
|
AA>RIGHT @
|
|
REPEAT
|
|
AGAIN
|
|
THEN ▪ DROP ;
|
|
|
|
: AA-#NODES ( aa-tree -- u )
|
|
>R 0 { DROP 1+ } R> AA-ITERATE ;
|
|
|
|
LINUX ALSO
|
|
|
|
LINUX DEFINITIONS
|
|
|
|
STRUCT
|
|
uint64% FIELD open_how>flags
|
|
uint64% FIELD open_how>mode
|
|
uint64% FIELD open_how>resolve
|
|
ENDSTRUCT open_how%
|
|
|
|
STRUCT
|
|
unsigned-long-long% FIELD stat64>dev
|
|
unsigned-char% 4 * FIELD stat64>__pad0
|
|
unsigned-long% FIELD stat64>__ino
|
|
unsigned-int% FIELD stat64>mode
|
|
unsigned-int% FIELD stat64>nlink
|
|
unsigned-long% FIELD stat64>uid
|
|
unsigned-long% FIELD stat64>gid
|
|
unsigned-long-long% FIELD stat64>rdev
|
|
unsigned-char% 4 * FIELD stat64>__pad3
|
|
signed-long-long% FIELD stat64>size
|
|
unsigned-long% FIELD stat64>blksize
|
|
unsigned-long-long% FIELD stat64>blocks
|
|
unsigned-long% FIELD stat64>atime
|
|
unsigned-long% FIELD stat64>atime_nsec
|
|
unsigned-long% FIELD stat64>mtime
|
|
unsigned-int% FIELD stat64>mtime_nsec
|
|
unsigned-long% FIELD stat64>ctime
|
|
unsigned-long% FIELD stat64>ctime_nsec
|
|
unsigned-long-long% FIELD stat64>ino
|
|
ENDSTRUCT stat64%
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
4096 CONSTANT FILE-BUFFER-BYTES
|
|
4096 CONSTANT SOURCE-BUFFER-BYTES
|
|
|
|
: MAKE-CSTRING ( c-addr1 u -- c-addr2 )
|
|
TUCK ▪ DUP 1+ ALLOCATE ▪ DUP >R ▪ SWAP CMOVE ▪ 0 ▪ SWAP R@ + C! ▪ R> ;
|
|
|
|
: EMPTY-CSTRING "\0" DROP ;
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
STRUCT
|
|
AA-NODE% FIELD FILE>NODE
|
|
CELL% FIELD FILE>FD
|
|
CELL% FIELD FILE>BUFFER
|
|
2CELL% FIELD FILE>LEFTOVER
|
|
2CELL% FIELD FILE>POSITION
|
|
2CELL% FIELD FILE>SOURCE
|
|
ENDSTRUCT FILE%
|
|
|
|
{ CONTAINEROF FILE>NODE ▪ FILE>FD @ } ' <=> NEW-AA-TREE CONSTANT FILES
|
|
|
|
stat64% %VARIABLE STAT64-RESULT
|
|
|
|
: FD>FILE ( fileid -- file-addr )
|
|
FILES AA-LOOKUP ?DUP 0= "unknown file ID" ?FAIL ;
|
|
|
|
: CLEAR-LEFTOVER ( file-addr -- )
|
|
[ NULL 0 ] 2LITERAL ROT FILE>LEFTOVER 2! ;
|
|
|
|
: ENSURE-BUFFER ( file-addr -- )
|
|
FILE>BUFFER DUP @ NULL= IF
|
|
FILE-BUFFER-BYTES ALLOCATE SWAP !
|
|
ELSE DROP THEN ;
|
|
|
|
: ENSURE-SOURCE ( file-addr -- )
|
|
FILE>SOURCE DUP 2@ DROP NULL= IF
|
|
SOURCE-BUFFER-BYTES ALLOCATE 0 ROT 2!
|
|
ELSE DROP THEN ;
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
O_RDONLY CONSTANT R/O ( -- fam )
|
|
O_WRONLY CONSTANT W/O ( -- fam )
|
|
O_RDWR CONSTANT R/W ( -- fam )
|
|
|
|
\ All files are treated as binary files
|
|
: BIN ( fam1 -- fam2 ) IMMEDIATE ;
|
|
|
|
: OPEN-FILE ( c-addr u fam -- fileid )
|
|
-ROT MAKE-CSTRING
|
|
open_how% %ALLOCA
|
|
FILE% %ALLOCATE
|
|
LOCALS| fam name open-how file |
|
|
NULL file FILE>BUFFER !
|
|
file CLEAR-LEFTOVER
|
|
0# file FILE>POSITION 2!
|
|
[ NULL 0 ] 2LITERAL file FILE>SOURCE 2!
|
|
open-how SIZEOF open_how% 0 FILL
|
|
0 fam open-how open_how>flags 2!
|
|
fam [[ O_CREAT __O_TMPFILE OR ]] AND IF
|
|
0 0666 open-how open_how>mode 2!
|
|
THEN
|
|
AT_FDCWD ▪ name ▪ open-how ▪ SIZEOF open_how%
|
|
SYS_OPENAT2 SYSCALL4-RETRY
|
|
name FREE
|
|
DUP ERRNO_ENOENT <> IF ▪ DUP ERRNO_ENOTDIR <> AND-IF ▪ ELSE
|
|
DROP file FREE EXCP-NON-EXISTENT-FILE THROW
|
|
THEN
|
|
DUP 0< IF DROP file FREE EXCP-FILE-IO THROW THEN
|
|
DUP file FILE>FD !
|
|
file FILES AA-LOOKUP NULL<> "internal error - duplicate key in FILES" ?FAIL
|
|
file FILES AA-INSERT
|
|
ENDLOCALS
|
|
UNALLOCA ;
|
|
|
|
: CREATE-FILE ( c-addr u fam -- fileid )
|
|
[[ O_CREAT O_TRUNC OR ]] OR OPEN-FILE ;
|
|
|
|
: REPOSITION-FILE ( ud fileid -- )
|
|
DUP FD>FILE ▪ signed-long-long% %ALLOCA
|
|
LOCALS| file llseek-result |
|
|
-ROT SWAP ▪ llseek-result ▪ SEEK_SET
|
|
SYS__LLSEEK SYSCALL5-RETRY
|
|
file CLEAR-LEFTOVER
|
|
0<> IF RDROP EXCP-FILE-IO THROW THEN
|
|
llseek-result 2@ SWAP file FILE>POSITION 2!
|
|
ENDLOCALS
|
|
UNALLOCA ;
|
|
|
|
: FILE-POSITION ( fileid -- ud ) FD>FILE FILE>POSITION 2@ ;
|
|
|
|
: FLUSH-FILE ( fileid -- ) DUP FILE-POSITION ROT REPOSITION-FILE ;
|
|
|
|
: RESIZE-FILE ( ud fileid -- )
|
|
DUP FLUSH-FILE
|
|
-ROT SYS_FTRUNCATE64 SYSCALL3-RETRY
|
|
0<> IF EXCP-FILE-IO THROW THEN ;
|
|
|
|
: FILE-STATUS ( c-addr u -- stat64-addr )
|
|
STAT64-RESULT SIZEOF stat64% 0 FILL
|
|
AT_FDCWD -ROT MAKE-CSTRING DUP >R STAT64-RESULT 0
|
|
SYS_FSTATAT64 SYSCALL4-RETRY
|
|
R> FREE ▪ 0<> IF EXCP-FILE-IO THROW THEN
|
|
STAT64-RESULT ;
|
|
|
|
: (FILE-STATUS) ( fileid -- stat64-addr )
|
|
STAT64-RESULT SIZEOF stat64% 0 FILL
|
|
FD>FILE FILE>FD @ EMPTY-CSTRING STAT64-RESULT AT_EMPTY_PATH
|
|
SYS_FSTATAT64 SYSCALL4-RETRY
|
|
0<> IF EXCP-FILE-IO THROW THEN
|
|
STAT64-RESULT ;
|
|
|
|
: FILE-SIZE ( fileid -- ud )
|
|
(FILE-STATUS) stat64>size 2@ SWAP ;
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
: (READ-CHAR) ( file-addr -- c TRUE | FALSE )
|
|
>R
|
|
R@ FILE>LEFTOVER 2@ NIP 0= IF
|
|
R@ ENSURE-BUFFER
|
|
R@ FILE>FD @ R@ FILE>BUFFER @ FILE-BUFFER-BYTES
|
|
SYS_READ SYSCALL3-RETRY
|
|
DUP 0< IF DROP EXCP-FILE-IO THROW THEN
|
|
DUP FILE-BUFFER-BYTES U> "read more data than requested" ?FAIL
|
|
R@ FILE>BUFFER @ SWAP R@ FILE>LEFTOVER 2!
|
|
THEN
|
|
R@ FILE>LEFTOVER 2@ DUP IF
|
|
OVER C@ -ROT 1/STRING R@ FILE>LEFTOVER 2!
|
|
R@ FILE>POSITION DUP 2@ 1# D+ ROT 2!
|
|
TRUE
|
|
ELSE
|
|
2DROP FALSE
|
|
THEN
|
|
RDROP ;
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
: READ-FILE ( c-addr u1 fileid -- u2 )
|
|
FD>FILE LOCALS| addr max file |
|
|
0 BEGIN
|
|
DUP max U<
|
|
WHILE
|
|
file (READ-CHAR)
|
|
WHILE
|
|
OVER addr + C!
|
|
1+
|
|
REPEAT
|
|
ENDLOCALS ;
|
|
|
|
: READ-LINE ( c-addr u1 fileid -- u2 t=eof )
|
|
FD>FILE LOCALS| addr max file |
|
|
FALSE 0 BEGIN
|
|
DUP max U<
|
|
WHILE
|
|
file (READ-CHAR)
|
|
DUP 0= IF >R NIP DUP 0= SWAP R> THEN
|
|
WHILE
|
|
DUP LF <> DUP 0= IF NIP THEN
|
|
WHILE
|
|
OVER addr + C!
|
|
1+
|
|
REPEAT
|
|
SWAP
|
|
ENDLOCALS ;
|
|
|
|
UTILITY DEFINITIONS
|
|
|
|
: REFILL-FILE ( fileid -- t=refilled )
|
|
FD>FILE >R
|
|
R@ ENSURE-SOURCE
|
|
R@ FILE>SOURCE 2@ DROP SOURCE-BUFFER-BYTES R@ FILE>FD @ READ-LINE
|
|
0= SWAP R@ FILE>SOURCE 2@ DROP SWAP R@ FILE>SOURCE 2! RDROP ;
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
:FINALIZE REFILL-FROM-FILE ( -- t=refilled )
|
|
SOURCE-ID DUP 0< "not a valid file source" ?FAIL
|
|
DUP [[ ' REFILL-FILE ]] CATCH ?DUP IF
|
|
DUP EXCP-FILE-IO <> IF RETHROW THEN
|
|
DROP 2DROP FALSE EXIT
|
|
THEN
|
|
DUP IF ▪ OVER FD>FILE FILE>SOURCE 2@ ▪ INPUT-BUFFER 2! ▪ 0 >IN ! ▪ THEN
|
|
NIP ;
|
|
|
|
FORTH DEFINITIONS
|
|
|
|
: WRITE-FILE ( c-addr u fileid -- )
|
|
FD>FILE >R
|
|
R@ FILE>LEFTOVER 2@ NIP IF R@ FILE>FD @ FLUSH-FILE THEN
|
|
BEGIN DUP WHILE
|
|
2DUP R@ FILE>FD @ -ROT SYS_WRITE SYSCALL3-RETRY
|
|
DUP -4095 1 WITHIN IF DROP EXCP-FILE-IO THROW THEN
|
|
DUP OVER U> "wrote more data than requested" ?FAIL
|
|
DUP 0 R@ FILE>POSITION 2@ D+ R@ FILE>POSITION 2!
|
|
/STRING
|
|
REPEAT ▪ 2DROP ▪ RDROP ;
|
|
|
|
: WRITE-LINE ( c-addr u fileid -- )
|
|
DUP >R WRITE-FILE (EOL) R> WRITE-FILE ;
|
|
|
|
: CLOSE-FILE ( fileid -- )
|
|
FD>FILE ▪ DUP FILE>FD @ FILES AA-DELETE DROP
|
|
DUP FILE>FD @ SYS_CLOSE SYSCALL1 DROP ( do not retry close )
|
|
DUP FILE>BUFFER @ FREE ▪ DUP FILE>SOURCE 2@ DROP FREE ▪ FREE ;
|
|
|
|
: RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- )
|
|
2>R 2>R AT_FDCWD 2R> MAKE-CSTRING AT_FDCWD OVER 2R> ROT >R MAKE-CSTRING DUP >R 0
|
|
SYS_RENAMEAT2 SYSCALL5-RETRY
|
|
R> FREE R> FREE ▪ 0<> IF EXCP-FILE-IO THROW THEN ;
|
|
|
|
: DELETE-FILE ( c-addr u -- )
|
|
AT_FDCWD -ROT MAKE-CSTRING DUP >R 0
|
|
SYS_UNLINKAT SYSCALL3-RETRY
|
|
R> FREE ▪ 0<> IF EXCP-FILE-IO THROW THEN ;
|
|
|
|
: INCLUDE-FILE ( i*x fileid -- j*x )
|
|
SAVE-INPUT N>R ▪ SOURCE 2>R ▪ SOURCE-ID >R
|
|
CURRENT-SOURCE-ID !
|
|
BEGIN REFILL WHILE INTERPRET REPEAT
|
|
R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP ;
|
|
|
|
: INCLUDED ( i*x c-addr u -- j*x )
|
|
R/O OPEN-FILE DUP >R [[ ' INCLUDE-FILE ]] CATCH R> CLOSE-FILE RETHROW ;
|
|
|
|
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ;
|
|
|
|
SYSTEM DEFINITIONS
|
|
|
|
{
|
|
ONLY FORTH DEFINITIONS
|
|
ARGC 2 U>= IF
|
|
1 ARGV [[ ' INCLUDED ]] CATCH
|
|
DUP EXCP-QUIT = IF
|
|
DROP 2DROP QUIT
|
|
ELSE ?DUP IF
|
|
REPORT 2DROP
|
|
THEN THEN
|
|
BYE
|
|
THEN
|
|
[ INTERACTIVE? ] [IF] BANNER [THEN]
|
|
} EXECUTE
|