nybble
/
jumpforth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
jumpforth/startup.4th

2286 lines
72 KiB
Forth
Raw Blame History

\ 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
\ Keep internal system definitions and ABI constants out of the main word list
CREATE SYSTEM-WORDLIST NULL ,
CREATE UTILITY-WORDLIST NULL ,
CREATE LINUX-WORDLIST NULL ,
SYSTEM-WORDLIST SET-CURRENT
\ Use this list until we get around to defining the real GET-ORDER
: STARTUP-ORDER ( -- widn ... wid1 n )
BOOTSTRAP-WORDLIST
LINUX-WORDLIST
UTILITY-WORDLIST
SYSTEM-WORDLIST
FORTH-WORDLIST
5 ;
LATEST ' BOOTSTRAP-GET-ORDER DEFER!
\ Shorthand for selecting the current compilation word list
: >>SYSTEM SYSTEM-WORDLIST SET-CURRENT ;
: >>UTILITY UTILITY-WORDLIST SET-CURRENT ;
: >>FORTH FORTH-WORDLIST SET-CURRENT ;
: >>LINUX LINUX-WORDLIST SET-CURRENT ;
>>FORTH
\ Unit suffixes, e.g. 4 KB ≡ 4096 (bytes)
: 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 * - ;
\ 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 ;
>>UTILITY
\ 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 ;
>>SYSTEM
\ 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
-17 CONSTANT EXCP-PNO-OVERFLOW
-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
NULL 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> )
NULL 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 ;
\ 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
\ 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
\ 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+ ;
>>SYSTEM
\ Use the latest word to replace the same name in the bootstrap word list
: REPLACE-BOOTSTRAP ( -- )
LATEST DUP >NAME BOOTSTRAP-WORDLIST [ ' SEARCH-WORDLIST , ]
0= IF >NAME EXCP-UNDEFINED-WORD THROW-STRING ELSE DEFER! THEN ;
>>LINUX
\ 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
19 ⇒ SYS_LSEEK
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
\ 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 9 LSHIFT ⇒ O_TRUNC
1 10 LSHIFT ⇒ O_APPEND
1 11 LSHIFT ⇒ O_NONBLOCK
\ 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 0 SYSCALL-RETRY ;
: SYSCALL1-RETRY ['] SYSCALL1 1 SYSCALL-RETRY ;
: SYSCALL2-RETRY ['] SYSCALL2 2 SYSCALL-RETRY ;
: SYSCALL3-RETRY ['] SYSCALL3 3 SYSCALL-RETRY ;
: SYSCALL4-RETRY ['] SYSCALL4 4 SYSCALL-RETRY ;
: SYSCALL5-RETRY ['] SYSCALL5 5 SYSCALL-RETRY ;
: SYSCALL6-RETRY ['] SYSCALL6 6 SYSCALL-RETRY ;
>>FORTH
\ 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-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 -- "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 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 0<= SWAP 0>= - ;
\ 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 ,
\ THROW if there are less than u bytes remaining in the PNO buffer
: PNO-CHECK ( u -- )
PNO-POINTER @ PNO-BUFFER - U> IF EXCP-PNO-OVERFLOW THROW THEN ;
>>FORTH
: <# ( -- ) 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 ;
: #> ( 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 ;
\ 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 / ;
>>UTILITY
CREATE DISPLAY-ITEM-LIMIT 6 ,
>>FORTH
\ 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
DUP SYS_BRK SYSCALL1-RETRY OVER <> IF EXCP-DICTIONARY-OVERFLOW THROW THEN
BRK !
THEN
CP ! ;
\ Only use this version of ALLOT from here on
REPLACE-BOOTSTRAP
\ 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 >= 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 ;
\ 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) ;
\ 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 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 NULL
\ 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 (NULL) 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.
: ALWAYS ( C: -- null-orig ) IMMEDIATE
NULL ;
: ONWARD-IF ( C: orig1 -- orig2 ) ( Runtime: 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 ) ( Runtime: 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: flag -- FALSE | <dropped> ) IMMEDIATE
POSTPONE ?0DUP POSTPONE IF ;
: OR-ELSE ( C: -- orig ) ( Runtime: flag -- nonzero-flag | <dropped> ) IMMEDIATE
POSTPONE ?DUP POSTPONE 0= POSTPONE IF ;
\ 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> 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 ONWARD-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 ) 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 NULL ,
: 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 - -ROT 2>R -ROT 2R> ▪ UMIN 0 ?DO
( S: u1-u2 c-addr1 c-addr2 R: loop-sys )
OVER I + C@ OVER I + C@
( S: u1-u2 c-addr1 c-addr2 ch1 ch2 )
- ?DUP IF -ROT 2>R NIP 2R> LEAVE THEN
LOOP ▪ 2DROP 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 - ]] + THEN ;
: TO-UPPER ( ch1 -- ch2 )
DUP [CHAR] a [CHAR] z WITHIN IF [[ CHAR a CHAR A - ]] - 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 - ]] - TRUE EXIT THEN
DUP [CHAR] a [CHAR] z WITHIN IF [[ CHAR a 10 - ]] - 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 ;
\ Parse a signed number; to succeed the entire input string must be consumed
: PARSENUMBER ( c-addr u -- n TRUE | FALSE )
DUP 0= IF NIP EXIT THEN ▪ OVER C@ [CHAR] - =
DUP >R IF 1/STRING DUP 0= IF RDROP NIP EXIT THEN THEN
>NUMBER R> 2NIP SWAP 0= DUP >R IF IF NEGATE THEN ELSE 2DROP THEN R> ;
REPLACE-BOOTSTRAP
>>SYSTEM
\ 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
\ 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-PNO-OVERFLOW OF
"Pictured numeric output string overflow\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 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!
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 ;
>>UTILITY
: 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
: PARSE-NAME ( "<spaces?>ccc<space>" -- c-addr u )
BEGIN
SKIP-SPACES
PARSE-EMPTY?
WHILE
REFILL 0= IF NULL 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 - ;
>>SYSTEM
\ 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 )
ALIGN HERE >R , , , DUP F_LENMASK UMIN C, HERE SWAP DUP ALLOT CMOVE ALIGN R> ;
\ 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 ! ;
>>UTILITY
\ 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! ;
>>FORTH
: CREATE ( "<spaces>ccc" -- )
PARSE-NAME (CREATE) ;
\ 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 ! ;
\ Debugging aid; shows a label and the contents of the stacks at runtime
: (MARK) "-- " TYPE TYPE " --\n" TYPE .S R> .RS >R ;
: MARK IMMEDIATE PARSE-NAME 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 ;
\ 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 "<spaces>ccc" -- )
CREATE 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 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 single-cell named variable which returns its data address when executed.
\ The initial value is formally undefined. This implementation sets it to NULL.
\ Execution: ( "<spaces>name" -- )
\ name Execution: ( -- a-addr )
: VARIABLE CREATE NULL , ;
\ Same for double-cell variables (two-variables)
: 2VARIABLE 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 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 * + ;
\ 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 ]] * + ;
\ 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
\ Extra field type descriptors for FFI structs
\ Each type is naturally aligned (contrast int64% vs 2CELL%)
\ 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%
8 DUP 2CONSTANT int64% LATEST
▪ DUP ALIAS uint64%
▪ DUP ALIAS signed-long-long%
▪ ALIAS unsigned-long-long%
>>FORTH
\ 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 ;
\ Like : but the definition has no name
\ The zero-length name is 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 ( -- )
"" (CREATE) LATEST ▪ DUP (HIDE) ▪ DOCOL OVER >CFA ! ▪ POSTPONE ] ;
\ 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 ;
\ 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 ;
\ 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 ( "<spaces>ccc" -- ) { "Uninitialized deferred word" FAIL } ALIAS ;
\ 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] IMMEDIATE
0= IF
0 BEGIN
PARSE-NAME 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
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 ;
\ Read the next word and return the first character
: CHAR ( "<spaces>name" -- c )
PARSE-NAME 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 ( a-addr order -- )
TUCK 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 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 < 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 + SWAP BUDDY-FREE ;
: BUDDY-ORDER-FROM-BYTES ( u-bytes -- order )
DUP 0= OR-ELSE 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 BUDDY-HEADS @ 0 SWAP BEGIN ?DUP WHILE @ SWAP 1+ SWAP REPEAT ;
VARIABLE TOTAL
>>UTILITY
: 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
>>UTILITY
\ 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
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
: 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
: 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 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
\ 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
\ 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 >R
DODOES !(+) [[ ' (CLOSURE) >DFA @ ]] !(+) NULL !(+) 0 !(+) OVER !(+) N! R> ;
\ Return a closure which executes xt1 followed by xt2
: COMPOSE ( xt1 xt2 -- xt3 )
{ >R EXECUTE R> EXECUTE } 2 CLOSURE ;
\ In the future the closure object and its xt may not share the same address
' FREE ALIAS FREE-CLOSURE
\ 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 ;
\ 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
\ 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 !
>>FORTH
\ 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 FORTH-WORDLIST 1 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 ;
\ 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 NULL , ;
\ 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 ;
: UTILITY ( -- ) UTILITY-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 ;
>>UTILITY
\ 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 ) PARSE-NAME 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
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 ( 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
2VARIABLE TIB-LEFTOVER
NULL 0 TIB-LEFTOVER 2!
>>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 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
\ 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 )
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 = 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
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
: 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 ;
>>SYSTEM
2VARIABLE STRING-BUFFER
NULL 0 STRING-BUFFER 2!
>>UTILITY
\ 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? OR-ELSE PEEK-CHAR [CHAR] " = DUP IF SKIP-CHAR THEN THEN 0=
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 ▪ NIP ;
>>SYSTEM
\ 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
PARSE-NAME
2DUP PARSENUMBER IF
STATE @ 2NIP 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
0 >IN ! ▪ INPUT-BUFFER 2! ▪ -1 CURRENT-SOURCE-ID ! ▪ INTERPRET
R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP ;
>>LINUX
' 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
termios% %VARIABLE 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 ;
' BOOTSTRAP-WORDLIST HIDE BOOTSTRAP-WORDLIST
>>SYSTEM
ALIAS BOOTSTRAP-WORDLIST
>>FORTH
\ 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
FORTH-WORDLIST 1 SET-ORDER
DEFINITIONS
\ *****************************************************************************
\ Bootstrapping is complete
\ From this point on we only execute threaded FORTH words defined in this file
\ *****************************************************************************
ALSO UTILITY
' >NAME ALIAS >NAME
PREVIOUS
\ 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) ;
HIDE (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
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>" )
\ Is it some kind of word, and if so, is the name zero-length (:NONAME)?
DUP WORD? AND-THEN DUP >NAME DUP ?DUP 0= IF NIP THEN THEN 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
\ Not a named word in the current search order or compilation word list
"∷" TYPE U.
THEN ;
\ 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 ;
ALSO UTILITY
\ 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 ;
PREVIOUS
: 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 NULL 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 NULL if the list is empty. &link is the
\ address of either a cell holding the head of the list or 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 NULL NULL 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 NULL >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 NULL= IF NIP ! R> 2RDROP EXIT THEN
2 PICK NULL= 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 NULL in head2's link field; save &link2 under head2 on the stack
\ Store head2 at &link
OVER NULL 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 NULL= 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 NULL= 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 ;
\ Sort in descending order by negating the result of compare-xt
: MERGE-SORT> ( head1 link-xt compare-xt -- head2 )
['] NEGATE COMPOSE DUP >R MERGE-SORT R> FREE-CLOSURE ;
HIDE SPLIT
HIDE MERGE
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ;
INTERACTIVE? [IF] BANNER [THEN]
QUIT
Reference in New Issue View Git Blame Copy Permalink