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