\ 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 ) >>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 ) ?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 ) THROWN-STRING 2! RETHROW ; \ Basic THROW without any string (store an empty string) : THROW ( k*x n -- k*x | i*x n ) 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 -- | ) 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 -- | ) 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 ( -- "" ) BL EMIT ; \ Emit a horizontal tab character : 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 ( -- "" ) LF EMIT ; \ Emit n blank (space) characters : SPACES ( n -- "" ) BEGIN ?DUP WHILE 1- SPACE REPEAT ; \ Terminate the program, successfully \ This will never return, even if the system call does : BYE ( -- ) 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 -- "" ) <# #S #> TYPE ; : U. ( u -- "" ) 0 DU. ; \ Display the signed number at the top of the stack : D. ( d -- "" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ; : . ( n -- "" ) 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 ( -- "" ) "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 ( -- "" ) \ 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: IF {ELSE } 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 if the condition is false \ \ This is functionally a short-circuit AND condition \ \ Without the ELSE they would both branch to \ IF ONWARD-IF ELSE THEN \ \ 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: \ AND-THEN THEN \ OR-ELSE THEN : AND-THEN ( C: -- orig ) ( Runtime S: flag -- FALSE | ) IMMEDIATE POSTPONE DUP POSTPONE IF POSTPONE DROP ; : OR-ELSE ( C: -- orig ) ( Runtime S: flag -- nonzero-flag | ) IMMEDIATE POSTPONE ?DUP POSTPONE 0= POSTPONE IF ; \ Unbounded loop: BEGIN AGAIN \ BEGIN places the offset of the start of on the stack. \ AGAIN creates a relative branch back to the start of . : BEGIN ( C: -- dest ) IMMEDIATE HERE ; : AGAIN ( C: dest -- ) IMMEDIATE POSTPONE BRANCH HERE - , ; \ Simple conditional loop: BEGIN 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 WHILE 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: \ CASE \ OF ENDOF \ OF ENDOF \ ... \ ENDCASE \ \ When equals execute , when equals execute , 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 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: DO LOOP \ DO +LOOP \ ?DO LOOP \ ?DO +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 ( -- ) ' BAILOUT ' QUIT DEFER! >>SYSTEM \ This function defines what happens when THROW is used outside of any CATCH : DEFAULT-UNWIND ( k*x n -- i*x ) 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 ) 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 ( "" -- ) 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" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ; : ( ( "ccc" -- ) 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 ( "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 ( "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 " (DOES) EXIT" to the current definition \ where 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 : : ( "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 "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: ( "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 "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 "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 "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 ( "ccc" -- ) CREATE ['] (DEFERRED-UNINIT) LATEST DEFER! ; ' (DEFERRED-UNINIT) (HIDE) \ Inline :NONAME-style function literals. "{ }" has the runtime effect \ of placing the execution token for an anonymous function with the runtime \ effect of 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 \ 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 ( "name" -- c ) WORD DROP C@ ; \ Like CHAR but generates a literal at compile-time. : [CHAR] ( Compilation: "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 ) DUP 0= IF EXIT THEN 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 -- ) ?DUP IF 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 THEN ; >>SYSTEM : OBJECT-SIZE ( obj-addr -- size ) CELL- @ DUP BUDDY-ORDERS U< IF BUDDY-ORDER-BYTES THEN CELL- ; >>FORTH \ If size is 0 then free obj-addr1 (which may be zero / NULL) and return 0 \ Otherwise if obj-addr1 is 0 (NULL) then allocate size bytes \ If neither obj-addr1 nor size is 0 then return an object with allocated size \ greater than or equal to size containing the same bytes as obj-addr1 up to \ size or the original object size, whichever is less \ The returned address may be equal to obj-addr1; if it is not, the original \ obj-addr1 is freed and no longer valid : RESIZE ( obj-addr1 size -- obj-addr1 | obj-addr2 | 0 ) DUP 0= IF DROP FREE 0 EXIT THEN OVER 0= IF NIP ALLOCATE EXIT THEN OVER OBJECT-SIZE 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 "name" -- ) OVER ALIGNED-TO 2CONSTANT ; \ Accessors for type descriptors : %SIZEOF ( align size -- size ) NIP ; : %ALIGNOF ( align size -- align ) DROP ; \ Reserve data or heap space for a data structure given alignment and size \ It is assumed that ALLOCATE (but not ALLOT) returns an address suitably \ aligned for any primitive data type; %ALLOCATE is not suitable for data \ structures with unusually high alignment requirements : %ALLOT ( align bytes -- a-addr ) SWAP ALIGN-TO HERE SWAP ALLOT ; : %ALLOCATE ( align bytes -- a-addr ) %SIZEOF ALLOCATE ; >>SYSTEM \ This structure describes one entry in the search order linked list STRUCT CELL% FIELD ORDER>LINK CELL% FIELD ORDER>WID ENDSTRUCT ORDER% VARIABLE CURRENT-ORDER 0 CURRENT-ORDER ! >>FORTH \ Return the current search order : GET-ORDER ( -- widn ... wid1 n ) 0 CURRENT-ORDER @ \ Traverse the linked list, placing identifiers on the return stack and counting BEGIN ?DUP WHILE DUP ORDER>WID @ >R ORDER>LINK @ SWAP 1+ SWAP REPEAT ( S: n ) ( R: wid1 ... widn ) \ Shift the search order list from the return stack back to the data stack DUP BEGIN ?DUP WHILE 1- R> -ROT REPEAT ( S: widn ... wid1 n ) ; \ Add the word list wid as the first word list in the search order \ Semantically equivalent to: \ : PUSH-ORDER ( wid -- ) >R GET-ORDER R> SWAP 1+ SET-ORDER ; : PUSH-ORDER ( wid -- ) ORDER% %ALLOCATE TUCK ORDER>WID ! CURRENT-ORDER @ OVER ORDER>LINK ! CURRENT-ORDER ! ; \ Remove and return the first word list in the search order \ Semantically equivalent to: \ : POP-ORDER ( -- wid ) GET-ORDER 1- SWAP >R SET-ORDER R> ; : POP-ORDER ( -- wid | 0 ) CURRENT-ORDER @ DUP IF DUP ORDER>LINK @ CURRENT-ORDER ! DUP ORDER>WID @ SWAP FREE THEN ; \ Return the first word list in the search order : PEEK-ORDER ( -- wid | 0 ) CURRENT-ORDER @ DUP IF ORDER>WID @ THEN ; \ Set the current search order : SET-ORDER ( widn ... wid1 n | -n -- ) DUP 0< IF DROP FORTH-WORDLIST 1 THEN \ Free the previous search order linked list 0 CURRENT-ORDER XCHG BEGIN ?DUP WHILE DUP ORDER>LINK @ SWAP FREE REPEAT \ Build the new search order linked list 0 OVER ?DO I PICK PUSH-ORDER -1 +LOOP NDROP ; \ Prepare the initial search order BOOTSTRAP-GET-ORDER SET-ORDER \ Use the real search order as the bootstrap search order from now on ' GET-ORDER ' BOOTSTRAP-GET-ORDER DEFER! \ Create a new wordlist \ In this implementation a word list is just a pointer to the most recent word : WORDLIST ( -- wid ) ALIGN HERE 0 , ; \ Make the first list in the search order the current compilation word list : DEFINITIONS ( -- ) PEEK-ORDER SET-CURRENT ; \ Run a function for each word in the given wordlist \ xt Execution: ( i*x word-xt -- stop-flag j*x ) : WITH-WORDLIST ( i*x wid xt -- j*x ) >R @ BEGIN ?DUP WHILE >R 2R@ SWAP EXECUTE IF RDROP 0 ELSE R> >LINK @ THEN REPEAT RDROP ; \ Like WITH-WORDLIST but only runs the function for visible (non-hidden) words : WITH-VISIBLE ( x*i wid xt -- x*j ) SWAP { DUP HIDDEN? IF DROP FALSE ELSE SWAP DUP >R EXECUTE R> SWAP THEN } WITH-WORDLIST DROP ; \ Display the name of each visible word in the given word list : SHOW-WORDLIST ( wid -- ) { >NAME TYPE SPACE FALSE } WITH-VISIBLE EOL ; \ Return the number of visible words in the given word list : COUNT-WORDLIST ( wid -- n ) 0 SWAP { DROP 1+ FALSE } WITH-VISIBLE ; \ Look up a name in a word list and return the execution token and immediate flag \ If the name is not found return the name with the status value 0 \ If the name is an immediate word return the execution token with status -1 \ Otherwise return the execution token with status 1 : SEARCH-WORDLIST ( c-addr u wid -- c-addr u 0 | xt 1 | xt -1 ) 0 SWAP { >R DROP 2DUP R@ >NAME COMPARE 0= IF 2DROP R> DUP IMMEDIATE? 1 OR TRUE ELSE RDROP 0 FALSE THEN } WITH-VISIBLE ; \ Search-Order extension words : ALSO ( -- ) PEEK-ORDER PUSH-ORDER ; : ONLY ( -- ) -1 SET-ORDER ; : ORDER ( -- ) "ORDER:" TYPE GET-ORDER 0 ?DO SPACE U. LOOP EOL "CURRENT: " TYPE GET-CURRENT U. EOL ; : PREVIOUS ( -- ) POP-ORDER DROP ; \ Define a new named wordlist \ Executing the word will replace the first item in the search order : VOCABULARY WORDLIST CREATE , DOES> @ POP-ORDER DROP PUSH-ORDER ; \ Names to select the predefined word lists \ FORTH is a Search-Order extension word \ SYSTEM-WORDLIST has been deliberately omitted here : FORTH ( -- ) FORTH-WORDLIST POP-ORDER DROP PUSH-ORDER ; : LINUX ( -- ) LINUX-WORDLIST POP-ORDER DROP PUSH-ORDER ; \ Apply SEARCH-WORDLIST to each word list in the current search order : FIND ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) 2>R GET-ORDER BEGIN ?DUP WHILE 1- SWAP 2R> ROT SEARCH-WORDLIST ?DUP IF 2>R NDROP 2R> EXIT THEN 2>R REPEAT 2R> 0 ; >>SYSTEM \ Same as FIND except that unknown words are reported and result in a call to THROW : FIND-OR-THROW ( c-addr u -- xt 1 | xt -1 ) FIND ?DUP 0= IF EXCP-UNDEFINED-WORD -ROT THROW-STRING THEN ; >>FORTH \ Read a word from the input (during runtime) and return its execution token \ Aborts if the word is not found in the current (runtime) search order list : ' ( "ccc" -- xt ) WORD FIND-OR-THROW DROP ; \ Like ' but generates a literal at compile-time. : ['] ( Compilation: "ccc" -- ) ( Runtime: -- xt ) IMMEDIATE ' POSTPONE LITERAL ; \ Read a word and append its compilation semantics to the current definition. : POSTPONE ( "name" -- ) IMMEDIATE WORD FIND-OR-THROW 0< IF COMPILE, ELSE POSTPONE LITERAL POSTPONE COMPILE, THEN ; \ Shorthand for { ' DEFER! } or { ['] DEFER! } depending on STATE \ If used during compilation, capture the name immediately but set target at runtime : IS ( Compilation: "ccc" -- ) ( Runtime: xt -- ) ( Interpreted: xt "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 "name" -- ) IMMEDIATE ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ; \ Hide the named word: HIDE : HIDE ( "ccc" -- ) ' (HIDE) ; \ Begin a new colon definition; hide & redirect the previous word \ with the same name to the new definition : :REPLACE ( "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 ( "" | "c" -- c ) NEXT-CHAR DUP [CHAR] \ = IF DROP NEXT-CHAR CASE [CHAR] 0 OF 0 ENDOF [CHAR] a OF 7 ENDOF [CHAR] b OF 8 ENDOF [CHAR] t OF 9 ENDOF [CHAR] n OF 10 ENDOF [CHAR] v OF 11 ENDOF [CHAR] f OF 12 ENDOF [CHAR] r OF 13 ENDOF [CHAR] " OF [CHAR] " ENDOF [CHAR] ' OF [CHAR] ' ENDOF [CHAR] \ OF [CHAR] \ ENDOF "Unknown escape sequence" FAIL ENDCASE THEN ; 2VARIABLE STRING-BUFFER 0 0 STRING-BUFFER 2! \ Read a literal character string up to the next double-quote character \ The string is stored in a transient buffer and will become invalid when \ the next string is read; both the address and content may change \ The delimiting double-quote character is removed from the input buffer \ Double-quote and backslash characters can be escaped with a backslash : READSTRING ( "ccc" -- c-addr u ) STRING-BUFFER 2@ 0 ( S: addr length index ) BEGIN PEEK-CHAR [CHAR] " <> WHILE 2DUP <= IF \ Grow the buffer by at least 50% + 16 bytes \ Store the actual allocated object size, not the requested size -ROT DUP 2/ + 16 + RESIZE DUP OBJECT-SIZE 2DUP STRING-BUFFER 2! ROT THEN ROT 2DUP + ESCAPED-CHAR SWAP C! -ROT 1+ REPEAT SKIP-CHAR NIP ; : PARSENUMBER ( c-addr u -- n TRUE | c-addr u FALSE ) DUP 0= IF FALSE EXIT THEN 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 "ccc" -- j*x ) BEGIN SKIP-SPACES PARSE-EMPTY? 0= WHILE PEEK-CHAR [CHAR] " = IF SKIP-CHAR READSTRING STATE @ IF POSTPONE LITSTRING 255 UMIN DUP C, HERE SWAP DUP ALLOT CMOVE ALIGN THEN ELSE WORD PARSENUMBER IF STATE @ IF POSTPONE LITERAL THEN ELSE FIND-OR-THROW \ -1 => immediate word; execute regardless of STATE \ 1 => read STATE; compile if true, execute if false 0< OR-ELSE STATE @ 0= THEN IF EXECUTE ELSE COMPILE, THEN THEN THEN REPEAT ; >>FORTH : EVALUATE ( i*x c-addr u -- j*x ) SAVE-INPUT N>R SOURCE 2>R SOURCE-ID >R INPUT-BUFFER 2! 0 >IN ! -1 CURRENT-SOURCE-ID ! INTERPRET R> CURRENT-SOURCE-ID ! 2R> INPUT-BUFFER 2! NR> RESTORE-INPUT DROP ; >>LINUX : TYPEDEF 2CONSTANT ; CHAR% TYPEDEF unsigned-char% CHAR% TYPEDEF signed-char% CELL% TYPEDEF unsigned-int% CELL% TYPEDEF signed-int% unsigned-char% TYPEDEF cc_t% unsigned-int% TYPEDEF speed_t% unsigned-int% TYPEDEF tcflag_t% 19 CONSTANT NCCS STRUCT tcflag_t% FIELD termios-c_iflag tcflag_t% FIELD termios-c_oflag tcflag_t% FIELD termios-c_cflag tcflag_t% FIELD termios-c_lflag cc_t% FIELD termios-c_line cc_t% NCCS * FIELD termios-c_cc ENDSTRUCT termios% 21505 CONSTANT IOCTL_TCGETS >>SYSTEM termios% %ALLOT CONSTANT SCRATCH-TERMIOS >>FORTH : TTY? ( fd -- flag ) IOCTL_TCGETS SCRATCH-TERMIOS SYS_IOCTL SYSCALL3 0= ; STDIN TTY? CONSTANT INTERACTIVE? \ Redefine QUIT as a non-deferred word; update deferred references to point here \ Empty the return stack, make stdin the input source, and enter interpretation state :REPLACE QUIT ( -- ) 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 -- "" | "" ) 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 -- "" ) 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 ( "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