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