2199 lines
70 KiB
Forth
2199 lines
70 KiB
Forth
\ Get and set the current compilation word list
|
|
: GET-CURRENT ( -- wid ) CURRENT @ ;
|
|
: SET-CURRENT ( wid -- ) CURRENT ! ;
|
|
|
|
\ Keep internal system definitions and ABI constants out of the main word list
|
|
CREATE SYSTEM-WORDLIST 0 ,
|
|
CREATE LINUX-WORDLIST 0 ,
|
|
|
|
SYSTEM-WORDLIST SET-CURRENT
|
|
|
|
\ Use this list until we get around to defining the real GET-ORDER
|
|
: STARTUP-ORDER BOOTSTRAP-WORDLIST LINUX-WORDLIST SYSTEM-WORDLIST FORTH-WORDLIST 4 ;
|
|
LATEST ' BOOTSTRAP-GET-ORDER DEFER!
|
|
|
|
\ Shorthand for selecting the current compilation word list
|
|
: >>SYSTEM SYSTEM-WORDLIST SET-CURRENT ;
|
|
: >>FORTH FORTH-WORDLIST SET-CURRENT ;
|
|
: >>LINUX LINUX-WORDLIST SET-CURRENT ;
|
|
|
|
>>FORTH
|
|
|
|
0 CONSTANT NULL
|
|
|
|
: KB 10 LSHIFT ;
|
|
: MB 20 LSHIFT ;
|
|
|
|
\ Shorthand for working with cell-aligned addresses
|
|
: CELL+ ( addr1 -- addr2 ) CELL + ;
|
|
: CELL- ( addr1 -- addr2 ) CELL - ;
|
|
: CELLS ( n1 -- n2 ) CELL * ;
|
|
: CELLS+ ( addr1 n -- addr2 ) CELL * + ;
|
|
: CELLS- ( addr1 n -- addr2 ) CELL * - ;
|
|
|
|
\ Round up to the next cell-aligned address
|
|
: ALIGNED ( addr -- a-addr )
|
|
[ CELL 1- ] LITERAL + [ CELL NEGATE ] LITERAL AND ;
|
|
|
|
\ 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+ ;
|
|
|
|
: ALIGNED-TO ( addr1 u -- addr2 )
|
|
NATURALLY-ALIGNED TUCK 1- + SWAP NEGATE AND ;
|
|
|
|
>>SYSTEM
|
|
|
|
\ Field accessors for execution tokens
|
|
: >CFA ( xt -- a-addr ) ;
|
|
: >DFA ( xt -- a-addr ) CELL+ ;
|
|
: >LINK ( xt -- a-addr ) 2 CELLS+ ;
|
|
: >FLAGS ( xt -- c-addr ) 3 CELLS+ ;
|
|
: >NAME ( xt -- c-addr u ) >FLAGS DUP 1+ SWAP C@ F_LENMASK AND ;
|
|
: >BODY ( xt -- a-addr ) >NAME + ALIGNED ;
|
|
|
|
\ 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
|
|
|
|
: IMMEDIATE? ( xt -- flag ) >FLAGS C@ F_IMMED AND 0<> ;
|
|
: HIDDEN? ( xt -- flag ) >FLAGS C@ F_HIDDEN AND 0<> ;
|
|
|
|
\ Fetch and store the target of the deferred word denoted by deferred-xt
|
|
\ Note that this DEFER! can turn any word into a deferred word
|
|
: DEFER@ ( deferred-xt -- xt ) >DFA @ ;
|
|
: DEFER! ( xt deferred-xt -- ) DODEFER OVER >CFA ! >DFA ! ;
|
|
|
|
\ 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
|
|
-13 CONSTANT EXCP-UNDEFINED-WORD
|
|
-24 CONSTANT EXCP-BAD-NUMERIC-ARGUMENT
|
|
-37 CONSTANT EXCP-FILE-IO
|
|
|
|
\ Non-standard system error codes (-4095 ... -256)
|
|
-256 CONSTANT EXCP-HEAP-OVERFLOW
|
|
|
|
>>SYSTEM
|
|
|
|
\ 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
|
|
0 0 THROWN-STRING 2!
|
|
|
|
\ This is called by THROW when n is nonzero
|
|
\ The initial value (DEFAULT-UNWIND) performs the function of ABORT
|
|
\ CATCH saves and restores the current target and substitutes its own version
|
|
DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|
|
|
>>FORTH
|
|
|
|
\ 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
|
|
: RETHROW ( k*x n -- k*x | i*x n <noreturn> )
|
|
?DUP IF THROW-UNWIND THEN ;
|
|
\ THROW while storing a string for context
|
|
: THROW-STRING ( k*x n c-addr u -- k*x | i*x n <noreturn> )
|
|
THROWN-STRING 2! RETHROW ;
|
|
\ Basic THROW without any string (store an empty string)
|
|
: THROW ( k*x n -- k*x | i*x n <noreturn> )
|
|
0 0 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 ;
|
|
|
|
>>LINUX
|
|
|
|
\ x86 system call numbers
|
|
1 CONSTANT SYS_EXIT
|
|
2 CONSTANT SYS_FORK
|
|
3 CONSTANT SYS_READ
|
|
4 CONSTANT SYS_WRITE
|
|
6 CONSTANT SYS_CLOSE
|
|
7 CONSTANT SYS_WAITPID
|
|
12 CONSTANT SYS_CHDIR
|
|
13 CONSTANT SYS_TIME
|
|
15 CONSTANT SYS_CHMOD
|
|
19 CONSTANT SYS_LSEEK
|
|
20 CONSTANT SYS_GETPID
|
|
21 CONSTANT SYS_MOUNT
|
|
25 CONSTANT SYS_STIME
|
|
26 CONSTANT SYS_PTRACE
|
|
27 CONSTANT SYS_ALARM
|
|
29 CONSTANT SYS_PAUSE
|
|
30 CONSTANT SYS_UTIME
|
|
33 CONSTANT SYS_ACCESS
|
|
34 CONSTANT SYS_NICE
|
|
36 CONSTANT SYS_SYNC
|
|
37 CONSTANT SYS_KILL
|
|
40 CONSTANT SYS_RMDIR
|
|
41 CONSTANT SYS_DUP
|
|
43 CONSTANT SYS_TIMES
|
|
45 CONSTANT SYS_BRK
|
|
48 CONSTANT SYS_SIGNAL
|
|
52 CONSTANT SYS_UMOUNT2
|
|
54 CONSTANT SYS_IOCTL
|
|
57 CONSTANT SYS_SETPGID
|
|
60 CONSTANT SYS_UMASK
|
|
61 CONSTANT SYS_CHROOT
|
|
62 CONSTANT SYS_USTAT
|
|
64 CONSTANT SYS_GETPPID
|
|
65 CONSTANT SYS_GETPGRP
|
|
66 CONSTANT SYS_SETSID
|
|
68 CONSTANT SYS_SGETMASK
|
|
69 CONSTANT SYS_SSETMASK
|
|
74 CONSTANT SYS_SETHOSTNAME
|
|
75 CONSTANT SYS_SETRLIMIT
|
|
76 CONSTANT SYS_GETRLIMIT
|
|
77 CONSTANT SYS_GETRUSAGE
|
|
78 CONSTANT SYS_GETTIMEOFDAY
|
|
79 CONSTANT SYS_SETTIMEOFDAY
|
|
82 CONSTANT SYS_SELECT
|
|
87 CONSTANT SYS_SWAPON
|
|
88 CONSTANT SYS_REBOOT
|
|
89 CONSTANT SYS_READDIR
|
|
91 CONSTANT SYS_MUNMAP
|
|
96 CONSTANT SYS_GETPRIORITY
|
|
97 CONSTANT SYS_SETPRIORITY
|
|
101 CONSTANT SYS_IOPERM
|
|
103 CONSTANT SYS_SYSLOG
|
|
104 CONSTANT SYS_SETITIMER
|
|
105 CONSTANT SYS_GETITIMER
|
|
110 CONSTANT SYS_IOPL
|
|
111 CONSTANT SYS_VHANGUP
|
|
112 CONSTANT SYS_IDLE
|
|
114 CONSTANT SYS_WAIT4
|
|
115 CONSTANT SYS_SWAPOFF
|
|
116 CONSTANT SYS_SYSINFO
|
|
117 CONSTANT SYS_IPC
|
|
118 CONSTANT SYS_FSYNC
|
|
121 CONSTANT SYS_SETDOMAINNAME
|
|
122 CONSTANT SYS_UNAME
|
|
123 CONSTANT SYS_MODIFY_LDT
|
|
124 CONSTANT SYS_ADJTIMEX
|
|
125 CONSTANT SYS_MPROTECT
|
|
128 CONSTANT SYS_INIT_MODULE
|
|
129 CONSTANT SYS_DELETE_MODULE
|
|
131 CONSTANT SYS_QUOTACTL
|
|
132 CONSTANT SYS_GETPGID
|
|
133 CONSTANT SYS_FCHDIR
|
|
135 CONSTANT SYS_SYSFS
|
|
136 CONSTANT SYS_PERSONALITY
|
|
140 CONSTANT SYS__LLSEEK
|
|
142 CONSTANT SYS__NEWSELECT
|
|
143 CONSTANT SYS_FLOCK
|
|
144 CONSTANT SYS_MSYNC
|
|
145 CONSTANT SYS_READV
|
|
146 CONSTANT SYS_WRITEV
|
|
147 CONSTANT SYS_GETSID
|
|
148 CONSTANT SYS_FDATASYNC
|
|
149 CONSTANT SYS__SYSCTL
|
|
151 CONSTANT SYS_MUNLOCK
|
|
152 CONSTANT SYS_MLOCKALL
|
|
153 CONSTANT SYS_MUNLOCKALL
|
|
154 CONSTANT SYS_SCHED_SETPARAM
|
|
155 CONSTANT SYS_SCHED_GETPARAM
|
|
156 CONSTANT SYS_SCHED_SETSCHEDULER
|
|
157 CONSTANT SYS_SCHED_GETSCHEDULER
|
|
158 CONSTANT SYS_SCHED_YIELD
|
|
159 CONSTANT SYS_SCHED_GET_PRIORITY_MAX
|
|
160 CONSTANT SYS_SCHED_GET_PRIORITY_MIN
|
|
162 CONSTANT SYS_NANOSLEEP
|
|
163 CONSTANT SYS_MREMAP
|
|
166 CONSTANT SYS_VM86
|
|
168 CONSTANT SYS_POLL
|
|
172 CONSTANT SYS_PRCTL
|
|
173 CONSTANT SYS_RT_SIGRETURN
|
|
174 CONSTANT SYS_RT_SIGACTION
|
|
175 CONSTANT SYS_RT_SIGPROCMASK
|
|
176 CONSTANT SYS_RT_SIGPENDING
|
|
178 CONSTANT SYS_RT_SIGQUEUEINFO
|
|
179 CONSTANT SYS_RT_SIGSUSPEND
|
|
180 CONSTANT SYS_PREAD64
|
|
181 CONSTANT SYS_PWRITE64
|
|
183 CONSTANT SYS_GETCWD
|
|
184 CONSTANT SYS_CAPGET
|
|
185 CONSTANT SYS_CAPSET
|
|
186 CONSTANT SYS_SIGALTSTACK
|
|
190 CONSTANT SYS_VFORK
|
|
192 CONSTANT SYS_MMAP2
|
|
193 CONSTANT SYS_TRUNCATE64
|
|
194 CONSTANT SYS_FTRUNCATE64
|
|
195 CONSTANT SYS_STAT64
|
|
196 CONSTANT SYS_LSTAT64
|
|
198 CONSTANT SYS_LCHOWN32
|
|
199 CONSTANT SYS_GETUID32
|
|
200 CONSTANT SYS_GETGID32
|
|
201 CONSTANT SYS_GETEUID32
|
|
202 CONSTANT SYS_GETEGID32
|
|
203 CONSTANT SYS_SETREUID32
|
|
204 CONSTANT SYS_SETREGID32
|
|
205 CONSTANT SYS_GETGROUPS32
|
|
206 CONSTANT SYS_SETGROUPS32
|
|
208 CONSTANT SYS_SETRESUID32
|
|
209 CONSTANT SYS_GETRESUID32
|
|
210 CONSTANT SYS_SETRESGID32
|
|
211 CONSTANT SYS_GETRESGID32
|
|
212 CONSTANT SYS_CHOWN32
|
|
213 CONSTANT SYS_SETUID32
|
|
214 CONSTANT SYS_SETGID32
|
|
215 CONSTANT SYS_SETFSUID32
|
|
216 CONSTANT SYS_SETFSGID32
|
|
217 CONSTANT SYS_PIVOT_ROOT
|
|
218 CONSTANT SYS_MINCORE
|
|
219 CONSTANT SYS_MADVISE
|
|
220 CONSTANT SYS_GETDENTS64
|
|
221 CONSTANT SYS_FCNTL64
|
|
224 CONSTANT SYS_GETTID
|
|
225 CONSTANT SYS_READAHEAD
|
|
226 CONSTANT SYS_SETXATTR
|
|
227 CONSTANT SYS_LSETXATTR
|
|
228 CONSTANT SYS_FSETXATTR
|
|
229 CONSTANT SYS_GETXATTR
|
|
230 CONSTANT SYS_LGETXATTR
|
|
231 CONSTANT SYS_FGETXATTR
|
|
232 CONSTANT SYS_LISTXATTR
|
|
233 CONSTANT SYS_LLISTXATTR
|
|
234 CONSTANT SYS_FLISTXATTR
|
|
235 CONSTANT SYS_REMOVEXATTR
|
|
236 CONSTANT SYS_LREMOVEXATTR
|
|
237 CONSTANT SYS_FREMOVEXATTR
|
|
239 CONSTANT SYS_SENDFILE64
|
|
241 CONSTANT SYS_SCHED_SETAFFINITY
|
|
242 CONSTANT SYS_SCHED_GETAFFINITY
|
|
243 CONSTANT SYS_SET_THREAD_AREA
|
|
244 CONSTANT SYS_GET_THREAD_AREA
|
|
245 CONSTANT SYS_IO_SETUP
|
|
246 CONSTANT SYS_IO_DESTROY
|
|
247 CONSTANT SYS_IO_GETEVENTS
|
|
248 CONSTANT SYS_IO_SUBMIT
|
|
249 CONSTANT SYS_IO_CANCEL
|
|
252 CONSTANT SYS_EXIT_GROUP
|
|
253 CONSTANT SYS_LOOKUP_DCOOKIE
|
|
255 CONSTANT SYS_EPOLL_CTL
|
|
256 CONSTANT SYS_EPOLL_WAIT
|
|
257 CONSTANT SYS_REMAP_FILE_PAGES
|
|
258 CONSTANT SYS_SET_TID_ADDRESS
|
|
259 CONSTANT SYS_TIMER_CREATE
|
|
262 CONSTANT SYS_TIMER_GETOVERRUN
|
|
263 CONSTANT SYS_TIMER_DELETE
|
|
268 CONSTANT SYS_STATFS64
|
|
269 CONSTANT SYS_FSTATFS64
|
|
270 CONSTANT SYS_TGKILL
|
|
271 CONSTANT SYS_UTIMES
|
|
272 CONSTANT SYS_FADVISE64_64
|
|
274 CONSTANT SYS_MBIND
|
|
275 CONSTANT SYS_GET_MEMPOLICY
|
|
276 CONSTANT SYS_SET_MEMPOLICY
|
|
277 CONSTANT SYS_MQ_OPEN
|
|
278 CONSTANT SYS_MQ_UNLINK
|
|
281 CONSTANT SYS_MQ_NOTIFY
|
|
282 CONSTANT SYS_MQ_GETSETATTR
|
|
283 CONSTANT SYS_KEXEC_LOAD
|
|
284 CONSTANT SYS_WAITID
|
|
286 CONSTANT SYS_ADD_KEY
|
|
287 CONSTANT SYS_REQUEST_KEY
|
|
288 CONSTANT SYS_KEYCTL
|
|
289 CONSTANT SYS_IOPRIO_SET
|
|
290 CONSTANT SYS_IOPRIO_GET
|
|
292 CONSTANT SYS_INOTIFY_ADD_WATCH
|
|
293 CONSTANT SYS_INOTIFY_RM_WATCH
|
|
294 CONSTANT SYS_MIGRATE_PAGES
|
|
296 CONSTANT SYS_MKDIRAT
|
|
297 CONSTANT SYS_MKNODAT
|
|
298 CONSTANT SYS_FCHOWNAT
|
|
299 CONSTANT SYS_FUTIMESAT
|
|
300 CONSTANT SYS_FSTATAT64
|
|
301 CONSTANT SYS_UNLINKAT
|
|
303 CONSTANT SYS_LINKAT
|
|
304 CONSTANT SYS_SYMLINKAT
|
|
305 CONSTANT SYS_READLINKAT
|
|
306 CONSTANT SYS_FCHMODAT
|
|
310 CONSTANT SYS_UNSHARE
|
|
311 CONSTANT SYS_SET_ROBUST_LIST
|
|
312 CONSTANT SYS_GET_ROBUST_LIST
|
|
313 CONSTANT SYS_SPLICE
|
|
314 CONSTANT SYS_SYNC_FILE_RANGE
|
|
315 CONSTANT SYS_TEE
|
|
316 CONSTANT SYS_VMSPLICE
|
|
317 CONSTANT SYS_MOVE_PAGES
|
|
318 CONSTANT SYS_GETCPU
|
|
319 CONSTANT SYS_EPOLL_PWAIT
|
|
322 CONSTANT SYS_TIMERFD_CREATE
|
|
324 CONSTANT SYS_FALLOCATE
|
|
327 CONSTANT SYS_SIGNALFD4
|
|
328 CONSTANT SYS_EVENTFD2
|
|
329 CONSTANT SYS_EPOLL_CREATE1
|
|
330 CONSTANT SYS_DUP3
|
|
331 CONSTANT SYS_PIPE2
|
|
332 CONSTANT SYS_INOTIFY_INIT1
|
|
335 CONSTANT SYS_RT_TGSIGQUEUEINFO
|
|
336 CONSTANT SYS_PERF_EVENT_OPEN
|
|
338 CONSTANT SYS_FANOTIFY_INIT
|
|
339 CONSTANT SYS_FANOTIFY_MARK
|
|
340 CONSTANT SYS_PRLIMIT64
|
|
341 CONSTANT SYS_NAME_TO_HANDLE_AT
|
|
342 CONSTANT SYS_OPEN_BY_HANDLE_AT
|
|
344 CONSTANT SYS_SYNCFS
|
|
345 CONSTANT SYS_SENDMMSG
|
|
346 CONSTANT SYS_SETNS
|
|
347 CONSTANT SYS_PROCESS_VM_READV
|
|
348 CONSTANT SYS_PROCESS_VM_WRITEV
|
|
349 CONSTANT SYS_KCMP
|
|
350 CONSTANT SYS_FINIT_MODULE
|
|
351 CONSTANT SYS_SCHED_SETATTR
|
|
352 CONSTANT SYS_SCHED_GETATTR
|
|
353 CONSTANT SYS_RENAMEAT2
|
|
354 CONSTANT SYS_SECCOMP
|
|
355 CONSTANT SYS_GETRANDOM
|
|
356 CONSTANT SYS_MEMFD_CREATE
|
|
357 CONSTANT SYS_BPF
|
|
358 CONSTANT SYS_EXECVEAT
|
|
359 CONSTANT SYS_SOCKET
|
|
360 CONSTANT SYS_SOCKETPAIR
|
|
361 CONSTANT SYS_BIND
|
|
362 CONSTANT SYS_CONNECT
|
|
363 CONSTANT SYS_LISTEN
|
|
364 CONSTANT SYS_ACCEPT4
|
|
365 CONSTANT SYS_GETSOCKOPT
|
|
366 CONSTANT SYS_SETSOCKOPT
|
|
367 CONSTANT SYS_GETSOCKNAME
|
|
368 CONSTANT SYS_GETPEERNAME
|
|
369 CONSTANT SYS_SENDTO
|
|
370 CONSTANT SYS_SENDMSG
|
|
371 CONSTANT SYS_RECVFROM
|
|
372 CONSTANT SYS_RECVMSG
|
|
373 CONSTANT SYS_SHUTDOWN
|
|
374 CONSTANT SYS_USERFAULTFD
|
|
375 CONSTANT SYS_MEMBARRIER
|
|
376 CONSTANT SYS_MLOCK2
|
|
377 CONSTANT SYS_COPY_FILE_RANGE
|
|
378 CONSTANT SYS_PREADV2
|
|
379 CONSTANT SYS_PWRITEV2
|
|
380 CONSTANT SYS_PKEY_MPROTECT
|
|
381 CONSTANT SYS_PKEY_ALLOC
|
|
382 CONSTANT SYS_PKEY_FREE
|
|
383 CONSTANT SYS_STATX
|
|
384 CONSTANT SYS_ARCH_PRCTL
|
|
386 CONSTANT SYS_RSEQ
|
|
393 CONSTANT SYS_SEMGET
|
|
394 CONSTANT SYS_SEMCTL
|
|
395 CONSTANT SYS_SHMGET
|
|
396 CONSTANT SYS_SHMCTL
|
|
397 CONSTANT SYS_SHMAT
|
|
398 CONSTANT SYS_SHMDT
|
|
399 CONSTANT SYS_MSGGET
|
|
400 CONSTANT SYS_MSGSND
|
|
401 CONSTANT SYS_MSGRCV
|
|
402 CONSTANT SYS_MSGCTL
|
|
403 CONSTANT SYS_CLOCK_GETTIME64
|
|
404 CONSTANT SYS_CLOCK_SETTIME64
|
|
405 CONSTANT SYS_CLOCK_ADJTIME64
|
|
406 CONSTANT SYS_CLOCK_GETRES_TIME64
|
|
407 CONSTANT SYS_CLOCK_NANOSLEEP_TIME64
|
|
408 CONSTANT SYS_TIMER_GETTIME64
|
|
409 CONSTANT SYS_TIMER_SETTIME64
|
|
410 CONSTANT SYS_TIMERFD_GETTIME64
|
|
411 CONSTANT SYS_TIMERFD_SETTIME64
|
|
412 CONSTANT SYS_UTIMENSAT_TIME64
|
|
413 CONSTANT SYS_PSELECT6_TIME64
|
|
414 CONSTANT SYS_PPOLL_TIME64
|
|
416 CONSTANT SYS_IO_PGETEVENTS_TIME64
|
|
417 CONSTANT SYS_RECVMMSG_TIME64
|
|
418 CONSTANT SYS_MQ_TIMEDSEND_TIME64
|
|
419 CONSTANT SYS_MQ_TIMEDRECEIVE_TIME64
|
|
420 CONSTANT SYS_SEMTIMEDOP_TIME64
|
|
421 CONSTANT SYS_RT_SIGTIMEDWAIT_TIME64
|
|
422 CONSTANT SYS_FUTEX_TIME64
|
|
423 CONSTANT SYS_SCHED_RR_GET_INTERVAL_TIME64
|
|
424 CONSTANT SYS_PIDFD_SEND_SIGNAL
|
|
425 CONSTANT SYS_IO_URING_SETUP
|
|
426 CONSTANT SYS_IO_URING_ENTER
|
|
427 CONSTANT SYS_IO_URING_REGISTER
|
|
428 CONSTANT SYS_OPEN_TREE
|
|
429 CONSTANT SYS_MOVE_MOUNT
|
|
430 CONSTANT SYS_FSOPEN
|
|
431 CONSTANT SYS_FSCONFIG
|
|
432 CONSTANT SYS_FSMOUNT
|
|
433 CONSTANT SYS_FSPICK
|
|
434 CONSTANT SYS_PIDFD_OPEN
|
|
435 CONSTANT SYS_CLONE3
|
|
437 CONSTANT SYS_OPENAT2
|
|
438 CONSTANT SYS_PIDFD_GETFD
|
|
439 CONSTANT SYS_FACCESSAT2
|
|
|
|
\ Special dirfd for *at syscalls to resolve path relative to current directory
|
|
-100 CONSTANT AT_FDCWD
|
|
|
|
\ errno values
|
|
\ System calls return -errno in the range [-4095, -1]
|
|
1 CONSTANT ERRNO_EPERM
|
|
2 CONSTANT ERRNO_ENOENT
|
|
3 CONSTANT ERRNO_ESRCH
|
|
4 CONSTANT ERRNO_EINTR
|
|
5 CONSTANT ERRNO_EIO
|
|
6 CONSTANT ERRNO_ENXIO
|
|
7 CONSTANT ERRNO_E2BIG
|
|
8 CONSTANT ERRNO_ENOEXEC
|
|
9 CONSTANT ERRNO_EBADF
|
|
10 CONSTANT ERRNO_ECHILD
|
|
11 CONSTANT ERRNO_EAGAIN
|
|
12 CONSTANT ERRNO_ENOMEM
|
|
13 CONSTANT ERRNO_EACCES
|
|
14 CONSTANT ERRNO_EFAULT
|
|
15 CONSTANT ERRNO_ENOTBLK
|
|
16 CONSTANT ERRNO_EBUSY
|
|
17 CONSTANT ERRNO_EEXIST
|
|
18 CONSTANT ERRNO_EXDEV
|
|
19 CONSTANT ERRNO_ENODEV
|
|
20 CONSTANT ERRNO_ENOTDIR
|
|
21 CONSTANT ERRNO_EISDIR
|
|
22 CONSTANT ERRNO_EINVAL
|
|
23 CONSTANT ERRNO_ENFILE
|
|
24 CONSTANT ERRNO_EMFILE
|
|
25 CONSTANT ERRNO_ENOTTY
|
|
26 CONSTANT ERRNO_ETXTBSY
|
|
27 CONSTANT ERRNO_EFBIG
|
|
28 CONSTANT ERRNO_ENOSPC
|
|
29 CONSTANT ERRNO_ESPIPE
|
|
30 CONSTANT ERRNO_EROFS
|
|
31 CONSTANT ERRNO_EMLINK
|
|
32 CONSTANT ERRNO_EPIPE
|
|
33 CONSTANT ERRNO_EDOM
|
|
34 CONSTANT ERRNO_ERANGE
|
|
|
|
\ signal numbers
|
|
1 CONSTANT SIGHUP
|
|
2 CONSTANT SIGINT
|
|
3 CONSTANT SIGQUIT
|
|
4 CONSTANT SIGILL
|
|
5 CONSTANT SIGTRAP
|
|
6 CONSTANT SIGABRT
|
|
6 CONSTANT SIGIOT
|
|
7 CONSTANT SIGBUS
|
|
8 CONSTANT SIGFPE
|
|
9 CONSTANT SIGKILL
|
|
10 CONSTANT SIGUSR1
|
|
11 CONSTANT SIGSEGV
|
|
12 CONSTANT SIGUSR2
|
|
13 CONSTANT SIGPIPE
|
|
14 CONSTANT SIGALRM
|
|
15 CONSTANT SIGTERM
|
|
16 CONSTANT SIGSTKFLT
|
|
17 CONSTANT SIGCHLD
|
|
18 CONSTANT SIGCONT
|
|
19 CONSTANT SIGSTOP
|
|
20 CONSTANT SIGTSTP
|
|
21 CONSTANT SIGTTIN
|
|
22 CONSTANT SIGTTOU
|
|
23 CONSTANT SIGURG
|
|
24 CONSTANT SIGXCPU
|
|
25 CONSTANT SIGXFSZ
|
|
26 CONSTANT SIGVTALRM
|
|
27 CONSTANT SIGPROF
|
|
28 CONSTANT SIGWINCH
|
|
29 CONSTANT SIGIO
|
|
29 CONSTANT SIGPOLL
|
|
30 CONSTANT SIGPWR
|
|
31 CONSTANT SIGSYS
|
|
|
|
\ openat2() access modes
|
|
0 CONSTANT O_RDONLY
|
|
1 CONSTANT O_WRONLY
|
|
2 CONSTANT O_RDWR
|
|
|
|
\ openat2() flags
|
|
1 6 LSHIFT CONSTANT O_CREAT
|
|
1 7 LSHIFT CONSTANT O_EXCL
|
|
1 9 LSHIFT CONSTANT O_TRUNC
|
|
1 10 LSHIFT CONSTANT O_APPEND
|
|
1 11 LSHIFT CONSTANT O_NONBLOCK
|
|
|
|
\ Names for the standard file descriptor numbers
|
|
0 CONSTANT STDIN
|
|
1 CONSTANT STDOUT
|
|
2 CONSTANT STDERR
|
|
|
|
>>FORTH
|
|
|
|
\ Write one character to FD 1 (stdout)
|
|
: EMIT ( c -- "c" )
|
|
SP@ 2DUP C! STDOUT SWAP 1 SYS_WRITE SYSCALL3 2DROP ;
|
|
|
|
\ 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 -- "ccc" )
|
|
>R
|
|
BEGIN
|
|
?DUP
|
|
WHILE
|
|
2DUP R@ -ROT SYS_WRITE SYSCALL3
|
|
DUP 0<= IF
|
|
ERRNO_EINTR NEGATE <> IF
|
|
2DROP RDROP EXIT
|
|
THEN
|
|
ELSE
|
|
/STRING
|
|
THEN
|
|
REPEAT
|
|
DROP RDROP ;
|
|
|
|
\ Specializations for output to stdout and stderr
|
|
: TYPE ( c-addr u -- "ccc" ) STDOUT TYPE-FD ;
|
|
: TYPE-ERR ( c-addr u -- "ccc" ) STDERR TYPE-FD ;
|
|
|
|
\ 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 | 0 ) GET-CURRENT @ ;
|
|
>>SYSTEM
|
|
: LATEST! ( xt -- ) GET-CURRENT ! ;
|
|
>>FORTH
|
|
|
|
\ 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 ! ;
|
|
|
|
\ Convert from a double-cell signed number to a single-cell signed number
|
|
: 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 2DUP > IF NIP ELSE DROP THEN ;
|
|
: MAX 2DUP < IF NIP ELSE DROP THEN ;
|
|
|
|
\ Unsigned minimum and maximum
|
|
: UMIN 2DUP U> IF NIP ELSE DROP THEN ;
|
|
: UMAX 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 IF 0< 2 * 1+ THEN ;
|
|
|
|
\ 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 ;
|
|
|
|
\ 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 ;
|
|
|
|
\ Emit an implementation-dependent End-of-Line sequence
|
|
\ Here this is just a LF (Unix convention) but it could be CR (Mac) or CR+LF (DOS)
|
|
: EOL ( -- "<eol>" ) LF EMIT ;
|
|
|
|
\ 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
|
|
|
|
\ 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 ,
|
|
|
|
>>FORTH
|
|
|
|
: <# ( -- ) PNO-BUFFER-END PNO-POINTER ! ;
|
|
: HOLD ( char -- ) PNO-POINTER 1 OVER -! @ C! ;
|
|
: #> ( 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 ;
|
|
|
|
\ Display the unsigned number at the top of the stack
|
|
: DU. ( ud -- "<digits>" ) <# #S #> TYPE ;
|
|
: U. ( u -- "<digits>" ) 0 DU. ;
|
|
|
|
\ Display the signed number at the top of the stack
|
|
: D. ( d -- "<minus?><digits>" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ;
|
|
: . ( n -- "<minus?><digits>" ) S>D D. ;
|
|
|
|
\ 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 / ;
|
|
|
|
CREATE DISPLAY-ITEM-LIMIT 6 ,
|
|
|
|
\ 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 ;
|
|
|
|
\ Return the next address in the compilation/data area
|
|
: HERE ( -- addr ) CP @ ;
|
|
|
|
>>SYSTEM
|
|
|
|
\ When growing the data area, round the end address up to a multiple of this size
|
|
65536 CONSTANT DATA-SEGMENT-ALIGNMENT
|
|
|
|
>>FORTH
|
|
|
|
\ 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
|
|
BEGIN
|
|
DUP SYS_BRK SYSCALL1
|
|
DUP [ ERRNO_EINTR NEGATE ] LITERAL <> DUP IF NIP THEN
|
|
UNTIL
|
|
OVER <> IF EXCP-DICTIONARY-OVERFLOW THROW THEN
|
|
BRK !
|
|
THEN
|
|
CP ! ;
|
|
|
|
\ Allocate one character from the data area and fill it with the value on the stack
|
|
: C, HERE 1 ALLOT C! ;
|
|
|
|
\ Allocate one cell from the data area and fill it with the value on the stack
|
|
: , HERE CELL ALLOT ! ;
|
|
|
|
\ Allocate two cells from the data area and fill them with the values on the stack
|
|
: 2, HERE [ 2 CELLS ] LITERAL ALLOT 2! ;
|
|
|
|
\ Allocate bytes from the data area (less than one cell) to cell-align the address
|
|
: ALIGN HERE ALIGNED HERE - BEGIN ?DUP WHILE 0 C, 1- REPEAT ;
|
|
|
|
: ALIGN-TO ( u -- )
|
|
HERE SWAP ALIGNED-TO HERE - ALLOT ;
|
|
|
|
\ 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 ( Compilation: x -- ) ( Runtime: -- x ) IMMEDIATE
|
|
POSTPONE LIT , ;
|
|
|
|
\ Append the LITSTRING xt and a copy of the string passed on the stack.
|
|
: SLITERAL ( Compilation: c-addr1 u -- ) ( Runtime: -- c-addr2 u ) IMMEDIATE
|
|
POSTPONE LITSTRING DUP C, HERE SWAP DUP ALLOT CMOVE ALIGN ;
|
|
|
|
: 2LITERAL ( Compilation: x1 x2 -- ) ( Runtime: -- 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) ;
|
|
|
|
\ 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 ONWARD-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 zero
|
|
\ in the link field. Example:
|
|
\
|
|
\ \ The IF and ONWARD-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> ONWARD-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 (zero) is ignored
|
|
\ by THEN and marks the end of the list if consumed by ONWARD-IF or ONWARD-AHEAD.
|
|
\ This can be used as a base for control structures with zero or more branches.
|
|
\
|
|
\ The low-level primitives:
|
|
: ALWAYS ( C: -- orig ) IMMEDIATE 0 ;
|
|
: ONWARD-IF ( C: orig1 -- orig2 ) 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 ;
|
|
\ The derived control structures:
|
|
: IF ( C: -- orig ) ( Runtime S: flag -- ) IMMEDIATE
|
|
POSTPONE ALWAYS POSTPONE ONWARD-IF ;
|
|
: AHEAD ( C: -- orig ) IMMEDIATE
|
|
POSTPONE ALWAYS POSTPONE ONWARD-AHEAD ;
|
|
: ELSE ( C: orig1 -- orig2 ) IMMEDIATE
|
|
POSTPONE AHEAD SWAP POSTPONE THEN ;
|
|
|
|
\ Short-circuit logical operators
|
|
\ Examples:
|
|
\ <cond1> AND-THEN <cond2> THEN
|
|
\ <cond1> OR-ELSE <cond2> THEN
|
|
: AND-THEN ( C: -- orig ) ( Runtime S: flag -- FALSE | <dropped> ) IMMEDIATE
|
|
POSTPONE DUP POSTPONE IF POSTPONE DROP ;
|
|
: OR-ELSE ( C: -- orig ) ( Runtime S: flag -- nonzero-flag | <dropped> ) IMMEDIATE
|
|
POSTPONE ?DUP POSTPONE 0= POSTPONE IF ;
|
|
|
|
\ Unbounded loop: BEGIN <body> AGAIN
|
|
\ BEGIN places the offset of the start of <code> on the stack.
|
|
\ AGAIN creates a relative branch back to the start of <code>.
|
|
: BEGIN ( C: -- dest ) IMMEDIATE
|
|
HERE ;
|
|
: AGAIN ( C: dest -- ) IMMEDIATE
|
|
POSTPONE BRANCH HERE - , ;
|
|
|
|
\ Simple conditional loop: BEGIN <body> UNTIL
|
|
\ UNTIL consumes the top of the stack and branches back to BEGIN if the value was zero.
|
|
: UNTIL ( C: dest -- ) ( Runtime S: flag -- ) IMMEDIATE
|
|
POSTPONE 0BRANCH HERE - , ;
|
|
|
|
\ Alternate conditional loop: BEGIN <condition> WHILE <body> REPEAT
|
|
: WHILE ( C: dest -- orig dest ) ( Runtime S: flag -- ) IMMEDIATE
|
|
POSTPONE IF SWAP ;
|
|
: REPEAT ( C: orig dest -- ) IMMEDIATE
|
|
POSTPONE AGAIN POSTPONE THEN ;
|
|
|
|
\ 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: -- 0 ) 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 ) IMMEDIATE
|
|
POSTPONE OVER POSTPONE = POSTPONE IF 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 0 ,
|
|
: DO ( C: -- outer-stack dest S: limit index R: -- limit index ) IMMEDIATE
|
|
POSTPONE 2>R LEAVE-ORIG @
|
|
POSTPONE ALWAYS LEAVE-ORIG !
|
|
POSTPONE BEGIN ;
|
|
: ?DO ( C: -- outer-stack dest S: limit index R: -- limit index ) IMMEDIATE
|
|
POSTPONE 2>R LEAVE-ORIG @
|
|
POSTPONE 2R@ POSTPONE <> POSTPONE IF LEAVE-ORIG !
|
|
POSTPONE BEGIN ;
|
|
: LEAVE ( C: -- S: -- R: limit index -- ) IMMEDIATE
|
|
LEAVE-ORIG @ POSTPONE ONWARD-AHEAD LEAVE-ORIG ! ;
|
|
: UNLOOP ( R: limit index -- ) IMMEDIATE
|
|
POSTPONE 2RDROP ;
|
|
: +LOOP ( C: outer-stack dest -- S: 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 -- S: -- 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 ;
|
|
|
|
\ Remove trailing whitespace from a string (only affects length)
|
|
: -TRAILING ( c-addr u1 -- c-addr u2 )
|
|
BEGIN DUP AND-THEN 2DUP 1- + C@ SPACE? THEN WHILE 1- REPEAT ;
|
|
|
|
\ Return -1, 0, or 1 if the left string is respectively
|
|
\ less than, equal to, or greater than the right string
|
|
: COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 )
|
|
ROT SWAP 2DUP - >R UMIN 0 ?DO
|
|
( S: c-addr1 c-addr2 R: u1-u2 loop-sys )
|
|
OVER I + C@ OVER I + C@
|
|
( S: c-addr1 c-addr2 ch1 ch2 )
|
|
- ?DUP IF NIP NIP SIGNUM UNLOOP RDROP EXIT THEN
|
|
LOOP
|
|
2DROP R> SIGNUM ;
|
|
|
|
\ True if n1 >= n2 && n1 <= n3, false otherwise
|
|
: WITHIN ( n1|u1 n2|u2 n3|u3 -- flag )
|
|
OVER - -ROT - U>= ;
|
|
|
|
\ Convert a character to lowercase or uppercase, respectively
|
|
: TO-LOWER ( ch1 -- ch2 )
|
|
DUP [CHAR] A [CHAR] Z WITHIN IF [ CHAR a CHAR A - ] LITERAL + THEN ;
|
|
: TO-UPPER ( ch1 -- ch2 )
|
|
DUP [CHAR] a [CHAR] z WITHIN IF [ CHAR a CHAR A - ] LITERAL - THEN ;
|
|
|
|
\ If ch is a digit (any base) return the value in range [0, 36) and TRUE
|
|
\ Otherwise just return FALSE
|
|
: >DIGIT ( ch -- u TRUE | FALSE )
|
|
DUP [CHAR] 0 [CHAR] 9 WITHIN IF [CHAR] 0 - TRUE EXIT THEN
|
|
DUP [CHAR] A [CHAR] Z WITHIN IF [ CHAR A 10 - ] LITERAL - TRUE EXIT THEN
|
|
DUP [CHAR] a [CHAR] z WITHIN IF [ CHAR a 10 - ] LITERAL - TRUE EXIT THEN
|
|
DROP FALSE ;
|
|
|
|
\ 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 0= IF RDROP EXIT THEN
|
|
OVER C@ >DIGIT 0= IF RDROP EXIT THEN
|
|
DUP R@ U>= IF RDROP DROP EXIT THEN
|
|
>R 1/STRING 2SWAP 2R@ DROP 0 D* R> 0 D+ 2SWAP
|
|
AGAIN ;
|
|
|
|
: >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 ;
|
|
|
|
\ 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 ,
|
|
|
|
\ 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 ;
|
|
|
|
\ QUIT needs to be deferred so that it can refer to INTERPRET
|
|
DEFER QUIT ( -- <noreturn> )
|
|
' BAILOUT ' QUIT DEFER!
|
|
|
|
>>SYSTEM
|
|
|
|
\ This function defines what happens when THROW is used outside of any CATCH
|
|
: DEFAULT-UNWIND ( k*x n -- i*x <noreturn> )
|
|
CASE
|
|
EXCP-ABORT OF ENDOF
|
|
EXCP-FAIL OF
|
|
THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR
|
|
ENDOF
|
|
EXCP-DICTIONARY-OVERFLOW OF
|
|
"Dictionary overflow\n" TYPE-ERR
|
|
ENDOF
|
|
EXCP-INVALID-ADDRESS OF
|
|
"Invalid memory address\n" TYPE-ERR
|
|
ENDOF
|
|
EXCP-UNDEFINED-WORD OF
|
|
"Undefined word: " TYPE-ERR THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR
|
|
ENDOF
|
|
EXCP-FILE-IO OF
|
|
"I/O error\n" TYPE-ERR
|
|
ENDOF
|
|
"Uncaught exception: " TYPE-ERR
|
|
DUP DUP S>D DABS <# #S ROT SIGN #> TYPE-ERR EOL
|
|
ENDCASE
|
|
S0 SP! QUIT ;
|
|
|
|
' DEFAULT-UNWIND ' THROW-UNWIND DEFER!
|
|
|
|
CREATE EXCEPTION-STACK 0 ,
|
|
|
|
\ 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!
|
|
R> EXCEPTION-STACK !
|
|
R> ['] THROW-UNWIND DEFER!
|
|
R> CURRENT-SOURCE-ID !
|
|
2R> INPUT-BUFFER 2!
|
|
NR> RESTORE-INPUT DROP
|
|
R> SWAP >R SP! R> ;
|
|
|
|
>>FORTH
|
|
|
|
\ 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 )
|
|
\ Get original RSP to be saved on return stack later, after the exception frame
|
|
RSP@
|
|
\ Don't include the xt or RSP when saving the stack pointer
|
|
2>R SP@ 2R> ROT >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
|
|
['] THROW-UNWIND DEFER@ >R
|
|
EXCEPTION-STACK @ >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 DEFER!
|
|
\ Save the original return stack so we can quickly free the exception frame
|
|
( RSP@ from start of CATCH ) >R
|
|
\ Run the function; if THROW is called then EXECUTE won't return
|
|
\ If it does return then push 0 to indicate success
|
|
EXECUTE 0
|
|
R> R> R>
|
|
\ Revert THROW-UNWIND and EXCEPTION-STACK using data from exception frame
|
|
['] THROW-UNWIND DEFER!
|
|
EXCEPTION-STACK !
|
|
\ We don't need the rest so just reset the RSP to where it was on entering CATCH
|
|
RSP! ;
|
|
|
|
: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ;
|
|
|
|
>>SYSTEM
|
|
|
|
: 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? OR-ELSE PEEK-CHAR SPACE? DUP IF SKIP-CHAR THEN 0= THEN UNTIL ;
|
|
|
|
>>FORTH
|
|
|
|
\ Comments; ignore all characters until the next EOL or ) character, respectively
|
|
: \ ( "ccc<eol>" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ;
|
|
: ( ( "ccc<closeparen>" -- ) IMMEDIATE BEGIN NEXT-CHAR [CHAR] ) = UNTIL ;
|
|
|
|
\ Placeholder to be replaced before switching to terminal input
|
|
DEFER REFILL
|
|
' FALSE ' REFILL DEFER!
|
|
|
|
\ Skip whitespace; read and return the next word delimited by whitespace
|
|
\ The delimiting whitespace character is left in the parse area
|
|
: WORD ( "<spaces>ccc" -- c-addr u )
|
|
BEGIN
|
|
SKIP-SPACES
|
|
PARSE-EMPTY?
|
|
WHILE
|
|
REFILL 0= IF 0 0 EXIT THEN
|
|
REPEAT
|
|
PARSE-AREA DROP
|
|
BEGIN
|
|
PARSE-EMPTY? 0= AND-THEN PEEK-CHAR SPACE? 0= THEN
|
|
WHILE
|
|
SKIP-CHAR
|
|
REPEAT
|
|
PARSE-AREA DROP OVER - ;
|
|
|
|
\ Use to create words programmatically without reading the name from the input
|
|
: (CREATE) ( c-addr u -- )
|
|
ALIGN HERE
|
|
DODATA , 0 , LATEST ,
|
|
-ROT DUP C, HERE SWAP DUP ALLOT CMOVE
|
|
ALIGN HERE OVER >DFA !
|
|
LATEST! ;
|
|
|
|
: CREATE ( "<spaces>ccc" -- )
|
|
WORD (CREATE) ;
|
|
|
|
\ 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 ! ;
|
|
|
|
\ 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 0 , POSTPONE (DOES) POSTPONE EXIT
|
|
HERE SWAP ! ;
|
|
|
|
' (DOES) (HIDE)
|
|
|
|
\ Debugging aid; shows a label and the contents of the stacks at runtime
|
|
: (MARK) "-- " TYPE TYPE " --\n" TYPE .S R> .RS >R ;
|
|
: MARK IMMEDIATE WORD POSTPONE SLITERAL POSTPONE (MARK) ;
|
|
' (MARK) (HIDE)
|
|
|
|
\ 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
|
|
: : ( "<spaces>ccc" -- )
|
|
CREATE LATEST DUP (HIDE) DOCOL SWAP >CFA ! POSTPONE ] ;
|
|
|
|
\ 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 ;
|
|
|
|
\ 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 CREATE LATEST >DFA ! ;
|
|
|
|
\ Same for double-cell constants; no DFA trick this time
|
|
: 2CONSTANT : POSTPONE 2LITERAL POSTPONE ; ;
|
|
|
|
\ Define a single-cell named variable which returns its data address when executed.
|
|
\ The initial value is formally undefined. This implementation sets it to zero.
|
|
\ Execution: ( "<spaces>name" -- )
|
|
\ name Execution: ( -- a-addr )
|
|
: VARIABLE CREATE 0 , ;
|
|
|
|
\ Same for double-cell variables (two-variables)
|
|
: 2VARIABLE CREATE [ 0 0 ] 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 CREATE , DOLOAD LATEST >CFA ! ;
|
|
|
|
\ Define an array of n single-cell elements
|
|
\ name Runtime: ( n -- a-addr ) Return the address of the cell at index n
|
|
: ARRAY ( n "<spaces>name" -- )
|
|
CREATE CELLS ALLOT DOES> SWAP [ CELL ] LITERAL * + ;
|
|
|
|
\ Define an array of n double-cell elements
|
|
\ name Runtime: ( n -- a-addr ) Return the address of the double-cell at index n
|
|
: 2ARRAY ( n "<spaces>name" -- )
|
|
CREATE 2* CELLS ALLOT DOES> SWAP [ 2 CELLS ] LITERAL * + ;
|
|
|
|
\ 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%
|
|
|
|
\ 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" -- )
|
|
OVER 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 ;
|
|
|
|
\ Like : but the definition has no name
|
|
\ The zero-length name still included in the word list so LATEST can refer to it
|
|
\ The execution token is left on the stack for use after the definition ends
|
|
: :NONAME ( -- )
|
|
ALIGN HERE DOCOL , HERE 3 CELLS+ , LATEST , F_HIDDEN C,
|
|
DUP LATEST! ALIGN POSTPONE ] ;
|
|
|
|
\ Create a deferred word; the target is stored in the DFA field
|
|
\ The default target throws an exception — replace it using DEFER! or IS
|
|
: (DEFERRED-UNINIT) "Uninitialized deferred word" FAIL ;
|
|
: DEFER ( "<spaces>ccc" -- )
|
|
CREATE ['] (DEFERRED-UNINIT) LATEST DEFER! ;
|
|
' (DEFERRED-UNINIT) (HIDE)
|
|
|
|
\ 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
|
|
DUP >LINK @ LATEST!
|
|
0 OVER >LINK !
|
|
POSTPONE AHEAD
|
|
ROT
|
|
POSTPONE [
|
|
THEN
|
|
:NONAME SWAP ;
|
|
|
|
\ 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
|
|
\ No effect if flag is true, otherwise skips words until matching [ELSE] or [THEN]
|
|
\ Skips over nested [IF] … [THEN] or [IF] … [ELSE] … [THEN] structures
|
|
: [IF] IMMEDIATE
|
|
0= IF
|
|
0 BEGIN
|
|
WORD 2>R
|
|
2R@ "[IF]" COMPARE 0= IF
|
|
1+
|
|
ELSE 2R@ "[THEN]" COMPARE 0= OR-ELSE 2R@ "[ELSE]" COMPARE 0= THEN IF
|
|
?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
|
|
WORD 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 ;
|
|
|
|
\ Read the next word and return the first character
|
|
: CHAR ( "<spaces>name" -- c )
|
|
WORD DROP C@ ;
|
|
|
|
\ Like CHAR but generates a literal at compile-time.
|
|
: [CHAR] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- c ) IMMEDIATE
|
|
CHAR POSTPONE LITERAL ;
|
|
|
|
>>SYSTEM
|
|
|
|
\ 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-FREE ( order a-addr -- )
|
|
OVER BUDDY-ORDERS U>= "order out of bounds" ?FAIL
|
|
2DUP SWAP BUDDY-ORDER-BYTES 1- AND "address is not naturally aligned" ?FAIL
|
|
>R DUP BUDDY-HEADS
|
|
BEGIN
|
|
( S: order head-addr ) ( R: a-addr )
|
|
DUP @
|
|
DUP 0= IF
|
|
\ Append to end of list
|
|
DROP 0 R@ ! R> SWAP !
|
|
DROP EXIT
|
|
THEN
|
|
( S: order head-addr block-addr ) ( R: freed-addr )
|
|
2 PICK 1+ BUDDY-ORDERS < AND-THEN
|
|
DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ =
|
|
THEN AND-THEN
|
|
\ 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 TRUE
|
|
THEN 0= IF
|
|
\ 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-ORDERS U>= "order out of bounds" ?FAIL
|
|
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 + BUDDY-FREE ;
|
|
|
|
: BUDDY-ORDER-FROM-BYTES ( u-bytes -- order )
|
|
DUP 0= OR-ELSE DUP DUP 1- AND 0<> THEN
|
|
"buddy allocator block size is not a power of two" ?FAIL
|
|
DUP BUDDY-MIN-BYTES - [ BUDDY-MAX-BYTES BUDDY-MIN-BYTES - ] LITERAL 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 BUDDY-HEADS @ 0 SWAP BEGIN ?DUP WHILE @ SWAP 1+ SWAP REPEAT ;
|
|
|
|
VARIABLE TOTAL
|
|
: 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
|
|
|
|
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
|
|
|
|
>>SYSTEM
|
|
|
|
: MMAP-ALLOCATE ( size -- a-addr )
|
|
BEGIN
|
|
NULL OVER PROT_READ PROT_WRITE OR
|
|
MAP_PRIVATE MAP_ANONYMOUS OR -1 0 SYS_MMAP2 SYSCALL6
|
|
DUP -4095 U>=
|
|
WHILE
|
|
NEGATE ERRNO_EINTR <> IF EXCP-HEAP-OVERFLOW THROW THEN
|
|
REPEAT NIP ;
|
|
|
|
: MUNMAP ( addr length -- )
|
|
DUP IF BEGIN 2DUP SYS_MUNMAP SYSCALL2 NEGATE ERRNO_EINTR <> UNTIL THEN 2DROP ;
|
|
|
|
: 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@ - MUNMAP
|
|
DUP R> R@ 2* + SWAP R> + TUCK - MUNMAP ;
|
|
|
|
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 ) 3235787545 CONSTANT MEMBLOCK-MAGIC
|
|
|
|
0 MEMBLOCK>DATA CONSTANT MEMBLOCK-DATA-OFFSET
|
|
|
|
: DATA>MEMBLOCK ( obj-addr -- memblock-addr )
|
|
MEMBLOCK-DATA-OFFSET - ;
|
|
|
|
>>FORTH
|
|
|
|
: 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-ORDERS 1- BUDDY-MAX-BYTES MMAP-ALLOCATE-ALIGNED BUDDY-FREE
|
|
BUDDY-ALLOCATE
|
|
THEN
|
|
THEN
|
|
TUCK MEMBLOCK>SIZE !
|
|
MEMBLOCK-MAGIC OVER MEMBLOCK>MAGIC !
|
|
MEMBLOCK>DATA ;
|
|
|
|
: FREE ( obj-addr -- )
|
|
?DUP IF
|
|
DATA>MEMBLOCK
|
|
DUP MEMBLOCK>MAGIC @ MEMBLOCK-MAGIC <> IF EXCP-INVALID-ADDRESS THROW THEN
|
|
0 OVER MEMBLOCK>MAGIC !
|
|
DUP MEMBLOCK>SIZE @
|
|
DUP BUDDY-ORDERS U< IF
|
|
SWAP BUDDY-FREE
|
|
ELSE
|
|
BEGIN
|
|
2DUP SYS_MUNMAP SYSCALL2 ?DUP 0= IF 2DROP EXIT THEN
|
|
NEGATE ERRNO_EINTR <> "munmap failed" ?FAIL
|
|
AGAIN
|
|
THEN
|
|
THEN ;
|
|
|
|
>>SYSTEM
|
|
|
|
: 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
|
|
|
|
\ If size is 0 then free obj-addr1 (which may be zero / NULL) and return 0
|
|
\ Otherwise if obj-addr1 is 0 (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 | 0 )
|
|
DUP 0= IF DROP FREE 0 EXIT THEN
|
|
OVER 0= 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
|
|
|
|
\ 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
|
|
|
|
\ Store xt1 and xu ... x1 in a "closure object" and return an execution token
|
|
\ The execution token is located at the start of the "closure object" and may
|
|
\ be passed to FREE to release the memory when the closure is no longer needed
|
|
\ When executed, the closure object 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 >R
|
|
DODOES OVER ! CELL+ [ ' (CLOSURE) >DFA @ ] LITERAL OVER ! CELL+
|
|
0 OVER ! CELL+ 0 OVER ! CELL+ 2DUP ! CELL+ N! R> ;
|
|
|
|
\ Reserve data or heap space for a data structure given alignment and size
|
|
\ It is assumed that ALLOCATE (but not ALLOT) returns an address suitably
|
|
\ aligned for any primitive data type; %ALLOCATE is not suitable for data
|
|
\ structures with unusually high alignment requirements
|
|
: %ALLOT ( align bytes -- a-addr ) SWAP ALIGN-TO HERE SWAP ALLOT ;
|
|
: %ALLOCATE ( align bytes -- a-addr ) %SIZEOF ALLOCATE ;
|
|
|
|
>>SYSTEM
|
|
|
|
\ 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
|
|
0 CURRENT-ORDER !
|
|
|
|
>>FORTH
|
|
|
|
\ Return the current search order
|
|
: GET-ORDER ( -- widn ... wid1 n )
|
|
0 CURRENT-ORDER @
|
|
\ Traverse the linked list, placing identifiers on the return stack and counting
|
|
BEGIN ?DUP WHILE DUP ORDER>WID @ >R ORDER>LINK @ SWAP 1+ SWAP REPEAT
|
|
( S: n ) ( R: wid1 ... widn )
|
|
\ Shift the search order list from the return stack back to the data stack
|
|
DUP BEGIN ?DUP WHILE 1- R> -ROT REPEAT
|
|
( S: widn ... wid1 n ) ;
|
|
|
|
\ 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 !
|
|
CURRENT-ORDER @ OVER ORDER>LINK !
|
|
CURRENT-ORDER ! ;
|
|
|
|
\ 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 | 0 )
|
|
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 | 0 )
|
|
CURRENT-ORDER @ DUP IF ORDER>WID @ THEN ;
|
|
|
|
\ Set the current search order
|
|
: SET-ORDER ( widn ... wid1 n | -n -- )
|
|
DUP 0< IF DROP FORTH-WORDLIST 1 THEN
|
|
\ Free the previous search order linked list
|
|
0 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 ;
|
|
|
|
\ Prepare the initial search order
|
|
BOOTSTRAP-GET-ORDER SET-ORDER
|
|
|
|
\ Use the real search order as the bootstrap search order from now on
|
|
' GET-ORDER ' BOOTSTRAP-GET-ORDER DEFER!
|
|
|
|
\ Create a new wordlist
|
|
\ In this implementation a word list is just a pointer to the most recent word
|
|
: WORDLIST ( -- wid )
|
|
ALIGN HERE 0 , ;
|
|
|
|
\ 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 wordlist
|
|
\ 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 )
|
|
0 SWAP {
|
|
>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 ;
|
|
|
|
\ Define a new named wordlist
|
|
\ Executing the word will replace the first item in the search order
|
|
: VOCABULARY WORDLIST CREATE , DOES> @ POP-ORDER DROP PUSH-ORDER ;
|
|
|
|
\ Names to select the predefined word lists
|
|
\ FORTH is a Search-Order extension word
|
|
\ SYSTEM-WORDLIST has been deliberately omitted here
|
|
: FORTH ( -- ) FORTH-WORDLIST POP-ORDER DROP PUSH-ORDER ;
|
|
: LINUX ( -- ) LINUX-WORDLIST POP-ORDER DROP PUSH-ORDER ;
|
|
|
|
\ Apply SEARCH-WORDLIST to each word list in the current search order
|
|
: FIND ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
|
|
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 ;
|
|
|
|
>>SYSTEM
|
|
|
|
\ 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
|
|
|
|
\ 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>ccc" -- xt ) WORD FIND-OR-THROW DROP ;
|
|
|
|
\ Like ' but generates a literal at compile-time.
|
|
: ['] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- xt ) IMMEDIATE
|
|
' POSTPONE LITERAL ;
|
|
|
|
\ Read a word and append its compilation semantics to the current definition.
|
|
: POSTPONE ( "<spaces>name" -- ) IMMEDIATE
|
|
WORD 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 ( Compilation: "<spaces>ccc" -- )
|
|
( Runtime: xt -- )
|
|
( Interpreted: xt "<spaces>ccc" -- )
|
|
' STATE @ IF POSTPONE LITERAL POSTPONE DEFER! ELSE DEFER! THEN ; IMMEDIATE
|
|
|
|
\ 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>ccc" -- ) ' (HIDE) ;
|
|
|
|
\ Begin a new colon definition; hide & redirect the previous word
|
|
\ with the same name to the new definition
|
|
: :REPLACE ( "<spaces>ccc" -- )
|
|
: 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 ;
|
|
|
|
\ Product 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 ;
|
|
|
|
>>SYSTEM
|
|
|
|
\ 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
|
|
CREATE TIB-LEFTOVER 0 ,
|
|
CREATE TIB-LEFTOVER-BYTES 0 ,
|
|
|
|
>>FORTH
|
|
|
|
\ 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)
|
|
:REPLACE REFILL ( -- flag )
|
|
SOURCE-ID 0< IF FALSE EXIT THEN
|
|
\ Shift any leftover characters after the previous line to the start of the buffer
|
|
TIB-LEFTOVER @ TERMINAL-BUFFER TIB-LEFTOVER-BYTES @ CMOVE
|
|
\ Look for the linefeed character which marks the end of the first line
|
|
TIB-LEFTOVER-BYTES @ 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
|
|
\ SOURCE-ID is the file descriptor number to read from
|
|
SOURCE-ID OVER TERMINAL-BUFFER TERMINAL-BUFFER-BYTES ROT /STRING
|
|
( S: length idx src-id buff buff-size )
|
|
\ Repeat read if interrupted by a signal (returns -EINTR)
|
|
BEGIN
|
|
SYS_READ SYSCALL3
|
|
DUP ERRNO_EINTR NEGATE <>
|
|
UNTIL
|
|
\ Any other negative (error) return value is fatal
|
|
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 = OR-ELSE
|
|
\ Check if the next character is a linefeed
|
|
1+ DUP 1- TERMINAL-BUFFER + C@ LF =
|
|
THEN
|
|
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
|
|
DUP TERMINAL-BUFFER + TIB-LEFTOVER !
|
|
TUCK - TIB-LEFTOVER-BYTES !
|
|
( 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<> ;
|
|
|
|
>>SYSTEM
|
|
|
|
: ESCAPED-CHAR ( "<escapeseq>" | "c" -- c )
|
|
NEXT-CHAR DUP [CHAR] \ = IF
|
|
DROP NEXT-CHAR CASE
|
|
[CHAR] 0 OF 0 ENDOF
|
|
[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] " OF [CHAR] " ENDOF
|
|
[CHAR] ' OF [CHAR] ' ENDOF
|
|
[CHAR] \ OF [CHAR] \ ENDOF
|
|
"Unknown escape sequence" FAIL
|
|
ENDCASE
|
|
THEN ;
|
|
|
|
2VARIABLE STRING-BUFFER
|
|
0 0 STRING-BUFFER 2!
|
|
|
|
\ 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
|
|
PEEK-CHAR [CHAR] " <>
|
|
WHILE
|
|
2DUP <= IF
|
|
\ Grow the buffer by at least 50% + 16 bytes
|
|
\ Store the actual allocated object size, not the requested size
|
|
-ROT DUP 2/ + 16 + RESIZE DUP OBJECT-SIZE
|
|
2DUP STRING-BUFFER 2! ROT
|
|
THEN
|
|
ROT 2DUP + ESCAPED-CHAR SWAP C! -ROT 1+
|
|
REPEAT
|
|
SKIP-CHAR NIP ;
|
|
|
|
: PARSENUMBER ( c-addr u -- n TRUE | c-addr u FALSE )
|
|
DUP 0= IF FALSE EXIT THEN
|
|
2DUP OVER C@ [CHAR] - = DUP >R IF
|
|
1/STRING DUP 0= IF 2DROP RDROP FALSE EXIT THEN
|
|
THEN
|
|
>NUMBER DUP 0<> IF 2DROP 2DROP RDROP FALSE EXIT THEN
|
|
2DROP 2NIP DROP R> IF NEGATE THEN TRUE ;
|
|
|
|
\ Read a word, number, or string and either execute it or compile it
|
|
\ 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
|
|
WORD
|
|
PARSENUMBER IF
|
|
STATE @ IF
|
|
POSTPONE LITERAL
|
|
THEN
|
|
ELSE
|
|
FIND-OR-THROW
|
|
\ -1 => immediate word; execute regardless of STATE
|
|
\ 1 => read STATE; compile if true, execute if false
|
|
0< OR-ELSE STATE @ 0= THEN IF EXECUTE ELSE COMPILE, THEN
|
|
THEN
|
|
THEN
|
|
REPEAT ;
|
|
|
|
>>FORTH
|
|
|
|
: EVALUATE ( i*x c-addr u -- j*x )
|
|
SAVE-INPUT N>R
|
|
SOURCE 2>R
|
|
SOURCE-ID >R
|
|
INPUT-BUFFER 2!
|
|
0 >IN !
|
|
-1 CURRENT-SOURCE-ID !
|
|
INTERPRET
|
|
R> CURRENT-SOURCE-ID !
|
|
2R> INPUT-BUFFER 2!
|
|
NR> RESTORE-INPUT DROP ;
|
|
|
|
>>LINUX
|
|
|
|
: TYPEDEF 2CONSTANT ;
|
|
|
|
CHAR% TYPEDEF unsigned-char%
|
|
CHAR% TYPEDEF signed-char%
|
|
CELL% TYPEDEF unsigned-int%
|
|
CELL% TYPEDEF signed-int%
|
|
|
|
unsigned-char% TYPEDEF cc_t%
|
|
unsigned-int% TYPEDEF speed_t%
|
|
unsigned-int% TYPEDEF tcflag_t%
|
|
|
|
19 CONSTANT NCCS
|
|
|
|
STRUCT
|
|
tcflag_t% FIELD termios-c_iflag
|
|
tcflag_t% FIELD termios-c_oflag
|
|
tcflag_t% FIELD termios-c_cflag
|
|
tcflag_t% FIELD termios-c_lflag
|
|
cc_t% FIELD termios-c_line
|
|
cc_t% NCCS * FIELD termios-c_cc
|
|
ENDSTRUCT termios%
|
|
|
|
21505 CONSTANT IOCTL_TCGETS
|
|
|
|
>>SYSTEM
|
|
|
|
termios% %ALLOT CONSTANT SCRATCH-TERMIOS
|
|
|
|
>>FORTH
|
|
|
|
: TTY? ( fd -- flag )
|
|
IOCTL_TCGETS SCRATCH-TERMIOS SYS_IOCTL SYSCALL3 0= ;
|
|
|
|
STDIN TTY? CONSTANT INTERACTIVE?
|
|
|
|
\ Redefine QUIT as a non-deferred word; update deferred references to point here
|
|
\ Empty the return stack, make stdin the input source, and enter interpretation state
|
|
:REPLACE QUIT ( -- <noreturn> )
|
|
R0 RSP!
|
|
0 CURRENT-SOURCE-ID !
|
|
FALSE STATE !
|
|
BEGIN
|
|
[ INTERACTIVE? ] [IF] "> " TYPE [THEN]
|
|
REFILL 0= IF BYE THEN
|
|
INTERPRET
|
|
[ INTERACTIVE? ] [IF]
|
|
STATE @ 0= IF "OK\n" TYPE THEN
|
|
[THEN]
|
|
AGAIN ;
|
|
|
|
HIDE BOOTSTRAP-WORDLIST
|
|
|
|
\ 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
|
|
\ *****************************************************************************
|
|
|
|
\ Define a threaded word which also displays its name and the data stack when called
|
|
: (TRACE) >NAME TYPE SPACE .S ;
|
|
: :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ;
|
|
' (TRACE) (HIDE)
|
|
|
|
\ 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
|
|
1+ GET-CURRENT SWAP
|
|
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>" )
|
|
DUP WORD? IF
|
|
\ Some kind of word; is the name zero-length (:NONAME)?
|
|
DUP >NAME DUP IF
|
|
\ Is the name hidden?
|
|
2 PICK HIDDEN? IF
|
|
"⌀" TYPE
|
|
ELSE
|
|
\ Does FIND with the same name fail to return the same word?
|
|
2DUP FIND AND-THEN 3 PICK = ELSE NIP NIP THEN 0= IF
|
|
"¤" TYPE
|
|
THEN
|
|
THEN
|
|
TYPE
|
|
DROP
|
|
ELSE
|
|
2DROP "∷" TYPE U.
|
|
THEN
|
|
ELSE
|
|
\ Not a word in the current search order or compilation word list
|
|
.
|
|
THEN ;
|
|
|
|
\ Read one cell and increment
|
|
: @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ;
|
|
|
|
\ Display a string in escaped (double-quoted) format, without the delimiters
|
|
: TYPE-ESCAPED ( c-addr u -- "<escapeseq*>" )
|
|
0 ?DO DUP 1+ SWAP C@ CASE
|
|
0 OF "\\0" TYPE ENDOF
|
|
7 OF "\\a" TYPE ENDOF
|
|
8 OF "\\b" TYPE ENDOF
|
|
9 OF "\\t" TYPE ENDOF
|
|
10 OF "\\n" TYPE ENDOF
|
|
11 OF "\\v" TYPE ENDOF
|
|
12 OF "\\f" TYPE ENDOF
|
|
13 OF "\\r" TYPE ENDOF
|
|
[CHAR] " OF "\\\"" TYPE ENDOF
|
|
\ escape sequence not needed in strings
|
|
\ [CHAR] ' OF "\\\'" TYPE ENDOF
|
|
[CHAR] \ OF "\\\\" TYPE ENDOF
|
|
DUP 32 < OR-ELSE DUP 127 = THEN IF
|
|
"⌷" TYPE
|
|
ELSE
|
|
DUP EMIT
|
|
THEN
|
|
ENDCASE LOOP DROP ;
|
|
|
|
\ Recognize the pattern BRANCH a:{c-a} b:{word} {code…} c:LIT d:{b}
|
|
\ This pattern is generated by the { … } inline :NONAME syntax
|
|
: NONAME-LITERAL? ( a-addr -- flag )
|
|
@(+) ['] BRANCH = AND-THEN
|
|
@(+) DUP 0> AND-THEN
|
|
( S: addr-b offset-c-a )
|
|
OVER CELL- + @(+) ['] LIT = AND-THEN
|
|
( S: addr-b addr-d )
|
|
@ OVER = AND-THEN
|
|
DUP WORD?
|
|
THEN
|
|
ELSE NIP THEN
|
|
ELSE NIP THEN
|
|
THEN NIP ;
|
|
|
|
\ 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 = AND-THEN OVER R@ U> THEN IF
|
|
2DROP RDROP EXIT
|
|
THEN
|
|
CASE
|
|
['] LIT OF
|
|
@(+) DUP WORD? IF "['] " TYPE .W ELSE . THEN SPACE
|
|
ENDOF
|
|
['] 2LIT OF
|
|
"[ " TYPE @(+) >R @(+) U. SPACE R> . " ] 2LITERAL " TYPE
|
|
ENDOF
|
|
['] LITSTRING OF
|
|
DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED
|
|
ENDOF
|
|
OVER CELL- NONAME-LITERAL? IF
|
|
DROP DUP @ OVER + 2 CELLS+ DUP R> UMAX >R SWAP
|
|
"{ " TYPE CELL+ >DFA @ UNTHREAD "} " TYPE
|
|
ELSE
|
|
DUP ['] BRANCH = OR-ELSE DUP ['] 0BRANCH = THEN IF
|
|
>NAME TYPE SPACE
|
|
@(+) DUP "{" TYPE DUP 0> IF "+" TYPE THEN . "} " TYPE
|
|
OVER CELL- + R> UMAX >R
|
|
ELSE
|
|
DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF
|
|
"POSTPONE " TYPE
|
|
THEN
|
|
.W SPACE
|
|
THEN
|
|
THEN
|
|
DUP \ placeholder to be dropped by ENDCASE since we consumed the xt
|
|
ENDCASE
|
|
AGAIN ;
|
|
|
|
HIDE NONAME-LITERAL?
|
|
|
|
: (SEE) ( xt -- )
|
|
DUP >CFA @ CASE
|
|
DOCOL OF
|
|
": " TYPE DUP >NAME TYPE " " TYPE
|
|
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 ;
|
|
|
|
: SEE ( "<spaces>name" -- ) ' (SEE) ;
|
|
|
|
HIDE UNTHREAD
|
|
|
|
: WORDS ( -- )
|
|
GET-ORDER ?DUP IF 1- SWAP >R NDROP R> SHOW-WORDLIST THEN ;
|
|
|
|
\ In the next few definitions link-xt is a function that takes a node address
|
|
\ and returns a pointer to its link field (holding 0 or the address of the next
|
|
\ node); compare-xt takes two node addresses and returns a negative, zero, or
|
|
\ positive value if the left node is less than, equal to, or greater than the
|
|
\ right node, respectively. The term "head" refers to the address of the node
|
|
\ at the beginning of a list, or 0 if the list is empty. &link is the address
|
|
\ of a node's link field.
|
|
|
|
\ Put the even items from head into head1 and the odd items into head2
|
|
: SPLIT ( head link-xt -- head1 head2 )
|
|
>R 0 0 ROT BEGIN ?DUP WHILE TUCK R@ EXECUTE XCHG >R SWAP R> REPEAT RDROP SWAP ;
|
|
|
|
\ Merge two sorted lists into a single sorted list
|
|
: MERGE ( head1 head2 link-xt compare-xt -- head )
|
|
2>R 0 >R RSP@ BEGIN
|
|
( S: head1 head2 &link R: link-xt compare-xt head )
|
|
\ If either list is empty we're done; append the other to the result and exit
|
|
OVER 0= IF NIP ! R> 2RDROP EXIT THEN
|
|
2 PICK 0= IF ! DROP R> 2RDROP EXIT THEN
|
|
\ Otherwise compare the two nodes
|
|
\ If head1 is greater than head2 then move head2 to the output, else head1
|
|
>R 2DUP R> -ROT 1 RPICK EXECUTE 0< IF >R SWAP R> THEN
|
|
>R DUP 3 RPICK EXECUTE @ SWAP R>
|
|
( S: head1 head2' head2 &link R: link-xt compare-xt head )
|
|
\ Store 0 in head2's link field; save &link2 under head2 on the stack
|
|
\ Store head2 at &link
|
|
OVER 0 SWAP 2 RPICK EXECUTE DUP >R ! R> -ROT !
|
|
( S: head1 head2' &link2 R: link-xt compare-xt head )
|
|
AGAIN ;
|
|
|
|
\ Return TRUE if the given list is sorted, or FALSE otherwise
|
|
: SORTED? ( head link-xt compare-xt -- flag )
|
|
\ An empty list is trivially sorted
|
|
2>R ?DUP 0= IF 2RDROP TRUE EXIT THEN
|
|
BEGIN
|
|
\ Get the next node
|
|
DUP 1 RPICK EXECUTE @
|
|
\ If there is no next node then the list is sorted
|
|
?DUP 0= IF DROP 2RDROP TRUE EXIT THEN
|
|
\ If the current node is greater than the next node then the list is not sorted
|
|
TUCK R@ EXECUTE 0> IF DROP 2RDROP FALSE EXIT THEN
|
|
\ Otherwise repeat for the next pair of adjacent nodes
|
|
AGAIN ;
|
|
|
|
\ Sort the given list using the recursive merge sort algorithm:
|
|
\ 1. If the list is already sorted, return it unchanged.
|
|
\ 2. Otherwise, split the list into two approximately equal sublists.
|
|
\ 3. Sort both sublists recursively.
|
|
\ 4. Merge the sorted sublists into a single sorted list.
|
|
: MERGE-SORT ( head1 link-xt compare-xt -- head2 ) RECURSIVE
|
|
2>R DUP 2R@ SORTED? 0= IF
|
|
1 RPICK SPLIT 2R@ MERGE-SORT SWAP 2R@ MERGE-SORT 2R@ MERGE
|
|
THEN 2RDROP ;
|
|
|
|
: NEGATED ( xt1 -- xt2 )
|
|
{ EXECUTE NEGATE } 1 CLOSURE ;
|
|
|
|
: MERGE-SORT-DESCENDING ( head1 link-xt compare-xt -- head2 )
|
|
NEGATED DUP >R MERGE-SORT R> FREE ;
|
|
|
|
HIDE SPLIT
|
|
HIDE MERGE
|
|
|
|
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ;
|
|
|
|
INTERACTIVE? [IF] BANNER [THEN]
|
|
QUIT
|