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

2019 lines
63 KiB
Forth
Raw Blame History

\ 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 ;
\ 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
-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 ;
\ 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-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 * + ;
\ 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)
\ 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 ;
>>FORTH
: ALLOCATE ( size -- obj-addr )
CELL+ DUP BUDDY-MAX-BYTES U> IF
PAGESIZE ALIGNED-TO DUP MMAP-ALLOCATE TUCK ! CELL+ EXIT
THEN
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
SWAP OVER ! CELL+ ;
: FREE ( obj-addr -- )
CELL- DUP @
DUP BUDDY-ORDERS U< IF SWAP BUDDY-FREE EXIT THEN
BEGIN
2DUP SYS_MUNMAP SYSCALL2 ?DUP 0= IF 2DROP EXIT THEN
NEGATE ERRNO_EINTR <> "munmap failed" ?FAIL
AGAIN ;
>>SYSTEM
: OBJECT-SIZE ( obj-addr -- size )
CELL- @ DUP BUDDY-ORDERS U< IF BUDDY-ORDER-BYTES THEN CELL- ;
>>FORTH
: RESIZE ( obj-addr1 size -- obj-addr1 | obj-addr2 )
OVER OBJECT-SIZE CELL+ OVER CELL+ 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 ;
>>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> ;
\ 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%
\ Structures begin with byte alignment and an offset of zero
1 0 2CONSTANT STRUCT
\ 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 ;
\ Reserve data or heap space for a data structure given alignment and size
: %ALLOT ( align bytes -- a-addr ) SWAP ALIGN-TO ALLOT ;
: %ALLOCATE ( align bytes -- a-addr ) NIP 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! ;
>>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 ;
\ Read a literal character string up to the next double-quote character
\ Unlike WORD the string is stored in contiguous *allocated* data space
\ 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 )
HERE
BEGIN
PEEK-CHAR [CHAR] " <>
WHILE
ESCAPED-CHAR C,
REPEAT
SKIP-CHAR
HERE OVER - ;
: PARSENUMBER ( c-addr u -- n TRUE | c-addr u FALSE )
DUP 0= IF FALSE EXIT THEN
2>R 2R@ DROP C@ [CHAR] - = 0
( S: neg-flag accum ) ( R: c-addr u )
OVER IF R@ 1 = IF 2DROP 2R> FALSE EXIT THEN THEN
OVER 2R@ ROT IF 1- SWAP 1+ SWAP THEN
( S: neg-flag accum c-addr' u' ) ( R: c-addr u )
BEGIN ?DUP WHILE
OVER -ROT 2>R C@ [CHAR] 0 -
( S: neg-flag accum digit ) ( R: c-addr u c-addr' u' )
DUP 9 U> IF DROP 2DROP 2RDROP 2R> FALSE EXIT THEN
SWAP 10 * + 2R>
( S: neg-flag accum' c-addr' u' ) ( R: c-addr u )
1- SWAP 1+ SWAP
REPEAT
( S: neg-flag accum c-addr' ) ( R: c-addr u )
2RDROP DROP SWAP 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
STATE @ IF
POSTPONE LITSTRING
HERE 0 C,
READSTRING NIP SWAP C! ALIGN
ELSE
READSTRING
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
CREATE SCRATCH-TERMIOS termios% %ALLOT
>>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
\ *****************************************************************************
\ 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 ;
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ;
INTERACTIVE? [IF] BANNER [THEN]
QUIT
Reference in New Issue View Git Blame Copy Permalink