From 67bb06dd8f75c546c375a54432b90d90ab6d4b7a Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Mon, 26 Oct 2020 05:05:06 -0500 Subject: [PATCH] refactor & reorganize --- jumpforth.S | 16 +- startup.4th | 1471 +++++++++++++++++++++++++---------------------- test/resize.4th | 6 +- 3 files changed, 788 insertions(+), 705 deletions(-) diff --git a/jumpforth.S b/jumpforth.S index 4bab12a..42acc3f 100644 --- a/jumpforth.S +++ b/jumpforth.S @@ -1270,7 +1270,7 @@ defword ISBOOTSTRAP,"BOOTSTRAP?" /* ( -- widn ... wid1 n ) Return the current search order */ /* Redefining this word with DEFER! will change the bootstrap search order */ -defword GET_ORDER,"BOOTSTRAP-GET-ORDER" +defword BOOTSTRAP_GET_ORDER,"BOOTSTRAP-GET-ORDER" .int BOOTSTRAP_WORDLIST,FORTH_WORDLIST,LIT,2,EXIT /* ( c-addr u wid -- 0 | xt 1 | xt -1 ) */ @@ -1288,7 +1288,7 @@ defword SEARCH_WORDLIST,"SEARCH-WORDLIST" /* ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) */ defword FIND - .int TWOTOR,GET_ORDER + .int TWOTOR,BOOTSTRAP_GET_ORDER 0: .int DUP,ZBRANCH,(1f - .) .int SUB1,SWAP,TWORFETCH,ROT,SEARCH_WORDLIST,QDUP,ZBRANCH,(0b - .) .int TWORDROP,TWOTOR,NDROP,TWOFROMR,EXIT @@ -1336,6 +1336,7 @@ defword ESCAPED_CHAR 0: litstring "Unknown escape sequence: \\" .int TYPE,EMIT,EOL,BAILOUT,EXIT +/* ( "ccc" -- c-addr u ) */ defword READSTRING .int HERE 0: .int PEEK_CHAR,LIT,34,NEQU,ZBRANCH,(1f - .) @@ -1343,17 +1344,17 @@ defword READSTRING 1: .int LIT,1,IN,INCREMENT,HERE,OVER,SUB,ALIGN,EXIT defword PARSENUMBER - .int DUP,LIT,0,GT,ZBRANCH,(6f - .) + .int DUP,LIT,0,GT,ZBRANCH,(7f - .) .int OVER,FETCHBYTE,LIT,'-',EQU,DUP,TOR,LIT,0,TOR,ZBRANCH,(0f - .) .int DUP,LIT,1,GT,ZBRANCH,(6f - .),BRANCH,(1f - .) 0: .int OVER,FETCHBYTE,LIT,'0',SUB - .int DUP,LIT,0,GE,ZBRANCH,(5f - .) - .int DUP,LIT,9,LE,ZBRANCH,(5f - .) + .int DUP,LIT,9,ULE,ZBRANCH,(5f - .) .int FROMR,LIT,10,MUL,ADD,TOR 1: .int SUB1,QDUP,ZBRANCH,(8f - .) .int SWAP,ADD1,SWAP,BRANCH,(0b - .) 5: .int DROP -6: .int TWODROP,RDROP,RDROP,FALSE,EXIT +6: .int RDROP,RDROP +7: .int TWODROP,FALSE,EXIT 8: .int DROP,FROMR,FROMR,ZBRANCH,(9f - .) .int NEGATE 9: .int TRUE,EXIT @@ -1370,8 +1371,7 @@ defword INTERPRET .int TYPE,BAILOUT /* ELSE */ 1: .int WORD,TWODUP,PARSENUMBER,ZBRANCH,(3f - .) - .int NROT,TWODROP - .int STATE,FETCH,ZBRANCH,(2f - .) + .int STATE,FETCH,TWONIP,ZBRANCH,(2f - .) .int LIT,LIT,COMMA,COMMA 2: .int EXIT /* ELSE */ diff --git a/startup.4th b/startup.4th index 33fe448..15eabb7 100644 --- a/startup.4th +++ b/startup.4th @@ -2,25 +2,36 @@ : 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 0 , -CREATE LINUX-WORDLIST 0 , +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 BOOTSTRAP-WORDLIST LINUX-WORDLIST SYSTEM-WORDLIST FORTH-WORDLIST 4 ; +: 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 -0 CONSTANT NULL - +\ Unit suffixes, e.g. 4 KB ≡ 4096 (bytes) : KB 10 LSHIFT ; : MB 20 LSHIFT ; @@ -31,18 +42,15 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER! : CELLS+ ( addr1 n -- addr2 ) CELL * + ; : CELLS- ( addr1 n -- addr2 ) CELL * - ; -\ Round up to the next cell-aligned address -: ALIGNED ( addr -- a-addr ) - [ CELL 1- ] LITERAL + [ CELL NEGATE ] LITERAL AND ; - -\ Returns the least power of two greater than or equal to u1 -: NATURALLY-ALIGNED ( u1 -- u2 ) - 1- DUP U2/ OR DUP 2 RSHIFT OR DUP 4 RSHIFT OR DUP 8 RSHIFT OR DUP 16 RSHIFT OR 1+ ; - +\ Returns the least multiple of u >= the aligned u +\ The alignment u must be a power of two : ALIGNED-TO ( addr1 u -- addr2 ) - NATURALLY-ALIGNED TUCK 1- + SWAP NEGATE AND ; + TUCK 1- + SWAP NEGATE AND ; ->>SYSTEM +\ 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 ) ; @@ -52,6 +60,8 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER! : >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! ; @@ -87,6 +97,7 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER! -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 @@ -98,7 +109,7 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER! \ THROWN-STRING holds the address and size of the string passed to FAIL \ It may also be used to hold context strings for other system exception codes CREATE THROWN-STRING 2 CELLS ALLOT -0 0 THROWN-STRING 2! +NULL 0 THROWN-STRING 2! \ This is called by THROW when n is nonzero \ The initial value (DEFAULT-UNWIND) performs the function of ABORT @@ -122,7 +133,7 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) THROWN-STRING 2! RETHROW ; \ Basic THROW without any string (store an empty string) : THROW ( k*x n -- k*x | i*x n ) - 0 0 THROW-STRING ; + NULL 0 THROW-STRING ; \ By default, clear the data stack and QUIT without any message \ This behavior can be overridden with CATCH @@ -138,452 +149,17 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) : ?FAIL ( flag c-addr u -- | ) ROT IF FAIL ELSE 2DROP THEN ; ->>LINUX - -\ x86 system call numbers - 1 CONSTANT SYS_EXIT - 2 CONSTANT SYS_FORK - 3 CONSTANT SYS_READ - 4 CONSTANT SYS_WRITE - 6 CONSTANT SYS_CLOSE - 7 CONSTANT SYS_WAITPID - 12 CONSTANT SYS_CHDIR - 13 CONSTANT SYS_TIME - 15 CONSTANT SYS_CHMOD - 19 CONSTANT SYS_LSEEK - 20 CONSTANT SYS_GETPID - 21 CONSTANT SYS_MOUNT - 25 CONSTANT SYS_STIME - 26 CONSTANT SYS_PTRACE - 27 CONSTANT SYS_ALARM - 29 CONSTANT SYS_PAUSE - 30 CONSTANT SYS_UTIME - 33 CONSTANT SYS_ACCESS - 34 CONSTANT SYS_NICE - 36 CONSTANT SYS_SYNC - 37 CONSTANT SYS_KILL - 40 CONSTANT SYS_RMDIR - 41 CONSTANT SYS_DUP - 43 CONSTANT SYS_TIMES - 45 CONSTANT SYS_BRK - 48 CONSTANT SYS_SIGNAL - 52 CONSTANT SYS_UMOUNT2 - 54 CONSTANT SYS_IOCTL - 57 CONSTANT SYS_SETPGID - 60 CONSTANT SYS_UMASK - 61 CONSTANT SYS_CHROOT - 62 CONSTANT SYS_USTAT - 64 CONSTANT SYS_GETPPID - 65 CONSTANT SYS_GETPGRP - 66 CONSTANT SYS_SETSID - 68 CONSTANT SYS_SGETMASK - 69 CONSTANT SYS_SSETMASK - 74 CONSTANT SYS_SETHOSTNAME - 75 CONSTANT SYS_SETRLIMIT - 76 CONSTANT SYS_GETRLIMIT - 77 CONSTANT SYS_GETRUSAGE - 78 CONSTANT SYS_GETTIMEOFDAY - 79 CONSTANT SYS_SETTIMEOFDAY - 82 CONSTANT SYS_SELECT - 87 CONSTANT SYS_SWAPON - 88 CONSTANT SYS_REBOOT - 89 CONSTANT SYS_READDIR - 91 CONSTANT SYS_MUNMAP - 96 CONSTANT SYS_GETPRIORITY - 97 CONSTANT SYS_SETPRIORITY -101 CONSTANT SYS_IOPERM -103 CONSTANT SYS_SYSLOG -104 CONSTANT SYS_SETITIMER -105 CONSTANT SYS_GETITIMER -110 CONSTANT SYS_IOPL -111 CONSTANT SYS_VHANGUP -112 CONSTANT SYS_IDLE -114 CONSTANT SYS_WAIT4 -115 CONSTANT SYS_SWAPOFF -116 CONSTANT SYS_SYSINFO -117 CONSTANT SYS_IPC -118 CONSTANT SYS_FSYNC -121 CONSTANT SYS_SETDOMAINNAME -122 CONSTANT SYS_UNAME -123 CONSTANT SYS_MODIFY_LDT -124 CONSTANT SYS_ADJTIMEX -125 CONSTANT SYS_MPROTECT -128 CONSTANT SYS_INIT_MODULE -129 CONSTANT SYS_DELETE_MODULE -131 CONSTANT SYS_QUOTACTL -132 CONSTANT SYS_GETPGID -133 CONSTANT SYS_FCHDIR -135 CONSTANT SYS_SYSFS -136 CONSTANT SYS_PERSONALITY -140 CONSTANT SYS__LLSEEK -142 CONSTANT SYS__NEWSELECT -143 CONSTANT SYS_FLOCK -144 CONSTANT SYS_MSYNC -145 CONSTANT SYS_READV -146 CONSTANT SYS_WRITEV -147 CONSTANT SYS_GETSID -148 CONSTANT SYS_FDATASYNC -149 CONSTANT SYS__SYSCTL -151 CONSTANT SYS_MUNLOCK -152 CONSTANT SYS_MLOCKALL -153 CONSTANT SYS_MUNLOCKALL -154 CONSTANT SYS_SCHED_SETPARAM -155 CONSTANT SYS_SCHED_GETPARAM -156 CONSTANT SYS_SCHED_SETSCHEDULER -157 CONSTANT SYS_SCHED_GETSCHEDULER -158 CONSTANT SYS_SCHED_YIELD -159 CONSTANT SYS_SCHED_GET_PRIORITY_MAX -160 CONSTANT SYS_SCHED_GET_PRIORITY_MIN -162 CONSTANT SYS_NANOSLEEP -163 CONSTANT SYS_MREMAP -166 CONSTANT SYS_VM86 -168 CONSTANT SYS_POLL -172 CONSTANT SYS_PRCTL -173 CONSTANT SYS_RT_SIGRETURN -174 CONSTANT SYS_RT_SIGACTION -175 CONSTANT SYS_RT_SIGPROCMASK -176 CONSTANT SYS_RT_SIGPENDING -178 CONSTANT SYS_RT_SIGQUEUEINFO -179 CONSTANT SYS_RT_SIGSUSPEND -180 CONSTANT SYS_PREAD64 -181 CONSTANT SYS_PWRITE64 -183 CONSTANT SYS_GETCWD -184 CONSTANT SYS_CAPGET -185 CONSTANT SYS_CAPSET -186 CONSTANT SYS_SIGALTSTACK -190 CONSTANT SYS_VFORK -192 CONSTANT SYS_MMAP2 -193 CONSTANT SYS_TRUNCATE64 -194 CONSTANT SYS_FTRUNCATE64 -195 CONSTANT SYS_STAT64 -196 CONSTANT SYS_LSTAT64 -198 CONSTANT SYS_LCHOWN32 -199 CONSTANT SYS_GETUID32 -200 CONSTANT SYS_GETGID32 -201 CONSTANT SYS_GETEUID32 -202 CONSTANT SYS_GETEGID32 -203 CONSTANT SYS_SETREUID32 -204 CONSTANT SYS_SETREGID32 -205 CONSTANT SYS_GETGROUPS32 -206 CONSTANT SYS_SETGROUPS32 -208 CONSTANT SYS_SETRESUID32 -209 CONSTANT SYS_GETRESUID32 -210 CONSTANT SYS_SETRESGID32 -211 CONSTANT SYS_GETRESGID32 -212 CONSTANT SYS_CHOWN32 -213 CONSTANT SYS_SETUID32 -214 CONSTANT SYS_SETGID32 -215 CONSTANT SYS_SETFSUID32 -216 CONSTANT SYS_SETFSGID32 -217 CONSTANT SYS_PIVOT_ROOT -218 CONSTANT SYS_MINCORE -219 CONSTANT SYS_MADVISE -220 CONSTANT SYS_GETDENTS64 -221 CONSTANT SYS_FCNTL64 -224 CONSTANT SYS_GETTID -225 CONSTANT SYS_READAHEAD -226 CONSTANT SYS_SETXATTR -227 CONSTANT SYS_LSETXATTR -228 CONSTANT SYS_FSETXATTR -229 CONSTANT SYS_GETXATTR -230 CONSTANT SYS_LGETXATTR -231 CONSTANT SYS_FGETXATTR -232 CONSTANT SYS_LISTXATTR -233 CONSTANT SYS_LLISTXATTR -234 CONSTANT SYS_FLISTXATTR -235 CONSTANT SYS_REMOVEXATTR -236 CONSTANT SYS_LREMOVEXATTR -237 CONSTANT SYS_FREMOVEXATTR -239 CONSTANT SYS_SENDFILE64 -241 CONSTANT SYS_SCHED_SETAFFINITY -242 CONSTANT SYS_SCHED_GETAFFINITY -243 CONSTANT SYS_SET_THREAD_AREA -244 CONSTANT SYS_GET_THREAD_AREA -245 CONSTANT SYS_IO_SETUP -246 CONSTANT SYS_IO_DESTROY -247 CONSTANT SYS_IO_GETEVENTS -248 CONSTANT SYS_IO_SUBMIT -249 CONSTANT SYS_IO_CANCEL -252 CONSTANT SYS_EXIT_GROUP -253 CONSTANT SYS_LOOKUP_DCOOKIE -255 CONSTANT SYS_EPOLL_CTL -256 CONSTANT SYS_EPOLL_WAIT -257 CONSTANT SYS_REMAP_FILE_PAGES -258 CONSTANT SYS_SET_TID_ADDRESS -259 CONSTANT SYS_TIMER_CREATE -262 CONSTANT SYS_TIMER_GETOVERRUN -263 CONSTANT SYS_TIMER_DELETE -268 CONSTANT SYS_STATFS64 -269 CONSTANT SYS_FSTATFS64 -270 CONSTANT SYS_TGKILL -271 CONSTANT SYS_UTIMES -272 CONSTANT SYS_FADVISE64_64 -274 CONSTANT SYS_MBIND -275 CONSTANT SYS_GET_MEMPOLICY -276 CONSTANT SYS_SET_MEMPOLICY -277 CONSTANT SYS_MQ_OPEN -278 CONSTANT SYS_MQ_UNLINK -281 CONSTANT SYS_MQ_NOTIFY -282 CONSTANT SYS_MQ_GETSETATTR -283 CONSTANT SYS_KEXEC_LOAD -284 CONSTANT SYS_WAITID -286 CONSTANT SYS_ADD_KEY -287 CONSTANT SYS_REQUEST_KEY -288 CONSTANT SYS_KEYCTL -289 CONSTANT SYS_IOPRIO_SET -290 CONSTANT SYS_IOPRIO_GET -292 CONSTANT SYS_INOTIFY_ADD_WATCH -293 CONSTANT SYS_INOTIFY_RM_WATCH -294 CONSTANT SYS_MIGRATE_PAGES -296 CONSTANT SYS_MKDIRAT -297 CONSTANT SYS_MKNODAT -298 CONSTANT SYS_FCHOWNAT -299 CONSTANT SYS_FUTIMESAT -300 CONSTANT SYS_FSTATAT64 -301 CONSTANT SYS_UNLINKAT -303 CONSTANT SYS_LINKAT -304 CONSTANT SYS_SYMLINKAT -305 CONSTANT SYS_READLINKAT -306 CONSTANT SYS_FCHMODAT -310 CONSTANT SYS_UNSHARE -311 CONSTANT SYS_SET_ROBUST_LIST -312 CONSTANT SYS_GET_ROBUST_LIST -313 CONSTANT SYS_SPLICE -314 CONSTANT SYS_SYNC_FILE_RANGE -315 CONSTANT SYS_TEE -316 CONSTANT SYS_VMSPLICE -317 CONSTANT SYS_MOVE_PAGES -318 CONSTANT SYS_GETCPU -319 CONSTANT SYS_EPOLL_PWAIT -322 CONSTANT SYS_TIMERFD_CREATE -324 CONSTANT SYS_FALLOCATE -327 CONSTANT SYS_SIGNALFD4 -328 CONSTANT SYS_EVENTFD2 -329 CONSTANT SYS_EPOLL_CREATE1 -330 CONSTANT SYS_DUP3 -331 CONSTANT SYS_PIPE2 -332 CONSTANT SYS_INOTIFY_INIT1 -335 CONSTANT SYS_RT_TGSIGQUEUEINFO -336 CONSTANT SYS_PERF_EVENT_OPEN -338 CONSTANT SYS_FANOTIFY_INIT -339 CONSTANT SYS_FANOTIFY_MARK -340 CONSTANT SYS_PRLIMIT64 -341 CONSTANT SYS_NAME_TO_HANDLE_AT -342 CONSTANT SYS_OPEN_BY_HANDLE_AT -344 CONSTANT SYS_SYNCFS -345 CONSTANT SYS_SENDMMSG -346 CONSTANT SYS_SETNS -347 CONSTANT SYS_PROCESS_VM_READV -348 CONSTANT SYS_PROCESS_VM_WRITEV -349 CONSTANT SYS_KCMP -350 CONSTANT SYS_FINIT_MODULE -351 CONSTANT SYS_SCHED_SETATTR -352 CONSTANT SYS_SCHED_GETATTR -353 CONSTANT SYS_RENAMEAT2 -354 CONSTANT SYS_SECCOMP -355 CONSTANT SYS_GETRANDOM -356 CONSTANT SYS_MEMFD_CREATE -357 CONSTANT SYS_BPF -358 CONSTANT SYS_EXECVEAT -359 CONSTANT SYS_SOCKET -360 CONSTANT SYS_SOCKETPAIR -361 CONSTANT SYS_BIND -362 CONSTANT SYS_CONNECT -363 CONSTANT SYS_LISTEN -364 CONSTANT SYS_ACCEPT4 -365 CONSTANT SYS_GETSOCKOPT -366 CONSTANT SYS_SETSOCKOPT -367 CONSTANT SYS_GETSOCKNAME -368 CONSTANT SYS_GETPEERNAME -369 CONSTANT SYS_SENDTO -370 CONSTANT SYS_SENDMSG -371 CONSTANT SYS_RECVFROM -372 CONSTANT SYS_RECVMSG -373 CONSTANT SYS_SHUTDOWN -374 CONSTANT SYS_USERFAULTFD -375 CONSTANT SYS_MEMBARRIER -376 CONSTANT SYS_MLOCK2 -377 CONSTANT SYS_COPY_FILE_RANGE -378 CONSTANT SYS_PREADV2 -379 CONSTANT SYS_PWRITEV2 -380 CONSTANT SYS_PKEY_MPROTECT -381 CONSTANT SYS_PKEY_ALLOC -382 CONSTANT SYS_PKEY_FREE -383 CONSTANT SYS_STATX -384 CONSTANT SYS_ARCH_PRCTL -386 CONSTANT SYS_RSEQ -393 CONSTANT SYS_SEMGET -394 CONSTANT SYS_SEMCTL -395 CONSTANT SYS_SHMGET -396 CONSTANT SYS_SHMCTL -397 CONSTANT SYS_SHMAT -398 CONSTANT SYS_SHMDT -399 CONSTANT SYS_MSGGET -400 CONSTANT SYS_MSGSND -401 CONSTANT SYS_MSGRCV -402 CONSTANT SYS_MSGCTL -403 CONSTANT SYS_CLOCK_GETTIME64 -404 CONSTANT SYS_CLOCK_SETTIME64 -405 CONSTANT SYS_CLOCK_ADJTIME64 -406 CONSTANT SYS_CLOCK_GETRES_TIME64 -407 CONSTANT SYS_CLOCK_NANOSLEEP_TIME64 -408 CONSTANT SYS_TIMER_GETTIME64 -409 CONSTANT SYS_TIMER_SETTIME64 -410 CONSTANT SYS_TIMERFD_GETTIME64 -411 CONSTANT SYS_TIMERFD_SETTIME64 -412 CONSTANT SYS_UTIMENSAT_TIME64 -413 CONSTANT SYS_PSELECT6_TIME64 -414 CONSTANT SYS_PPOLL_TIME64 -416 CONSTANT SYS_IO_PGETEVENTS_TIME64 -417 CONSTANT SYS_RECVMMSG_TIME64 -418 CONSTANT SYS_MQ_TIMEDSEND_TIME64 -419 CONSTANT SYS_MQ_TIMEDRECEIVE_TIME64 -420 CONSTANT SYS_SEMTIMEDOP_TIME64 -421 CONSTANT SYS_RT_SIGTIMEDWAIT_TIME64 -422 CONSTANT SYS_FUTEX_TIME64 -423 CONSTANT SYS_SCHED_RR_GET_INTERVAL_TIME64 -424 CONSTANT SYS_PIDFD_SEND_SIGNAL -425 CONSTANT SYS_IO_URING_SETUP -426 CONSTANT SYS_IO_URING_ENTER -427 CONSTANT SYS_IO_URING_REGISTER -428 CONSTANT SYS_OPEN_TREE -429 CONSTANT SYS_MOVE_MOUNT -430 CONSTANT SYS_FSOPEN -431 CONSTANT SYS_FSCONFIG -432 CONSTANT SYS_FSMOUNT -433 CONSTANT SYS_FSPICK -434 CONSTANT SYS_PIDFD_OPEN -435 CONSTANT SYS_CLONE3 -437 CONSTANT SYS_OPENAT2 -438 CONSTANT SYS_PIDFD_GETFD -439 CONSTANT SYS_FACCESSAT2 - -\ Special dirfd for *at syscalls to resolve path relative to current directory --100 CONSTANT AT_FDCWD - -\ errno values -\ System calls return -errno in the range [-4095, -1] - 1 CONSTANT ERRNO_EPERM - 2 CONSTANT ERRNO_ENOENT - 3 CONSTANT ERRNO_ESRCH - 4 CONSTANT ERRNO_EINTR - 5 CONSTANT ERRNO_EIO - 6 CONSTANT ERRNO_ENXIO - 7 CONSTANT ERRNO_E2BIG - 8 CONSTANT ERRNO_ENOEXEC - 9 CONSTANT ERRNO_EBADF -10 CONSTANT ERRNO_ECHILD -11 CONSTANT ERRNO_EAGAIN -12 CONSTANT ERRNO_ENOMEM -13 CONSTANT ERRNO_EACCES -14 CONSTANT ERRNO_EFAULT -15 CONSTANT ERRNO_ENOTBLK -16 CONSTANT ERRNO_EBUSY -17 CONSTANT ERRNO_EEXIST -18 CONSTANT ERRNO_EXDEV -19 CONSTANT ERRNO_ENODEV -20 CONSTANT ERRNO_ENOTDIR -21 CONSTANT ERRNO_EISDIR -22 CONSTANT ERRNO_EINVAL -23 CONSTANT ERRNO_ENFILE -24 CONSTANT ERRNO_EMFILE -25 CONSTANT ERRNO_ENOTTY -26 CONSTANT ERRNO_ETXTBSY -27 CONSTANT ERRNO_EFBIG -28 CONSTANT ERRNO_ENOSPC -29 CONSTANT ERRNO_ESPIPE -30 CONSTANT ERRNO_EROFS -31 CONSTANT ERRNO_EMLINK -32 CONSTANT ERRNO_EPIPE -33 CONSTANT ERRNO_EDOM -34 CONSTANT ERRNO_ERANGE - -\ signal numbers - 1 CONSTANT SIGHUP - 2 CONSTANT SIGINT - 3 CONSTANT SIGQUIT - 4 CONSTANT SIGILL - 5 CONSTANT SIGTRAP - 6 CONSTANT SIGABRT - 6 CONSTANT SIGIOT - 7 CONSTANT SIGBUS - 8 CONSTANT SIGFPE - 9 CONSTANT SIGKILL -10 CONSTANT SIGUSR1 -11 CONSTANT SIGSEGV -12 CONSTANT SIGUSR2 -13 CONSTANT SIGPIPE -14 CONSTANT SIGALRM -15 CONSTANT SIGTERM -16 CONSTANT SIGSTKFLT -17 CONSTANT SIGCHLD -18 CONSTANT SIGCONT -19 CONSTANT SIGSTOP -20 CONSTANT SIGTSTP -21 CONSTANT SIGTTIN -22 CONSTANT SIGTTOU -23 CONSTANT SIGURG -24 CONSTANT SIGXCPU -25 CONSTANT SIGXFSZ -26 CONSTANT SIGVTALRM -27 CONSTANT SIGPROF -28 CONSTANT SIGWINCH -29 CONSTANT SIGIO -29 CONSTANT SIGPOLL -30 CONSTANT SIGPWR -31 CONSTANT SIGSYS - -\ openat2() access modes -0 CONSTANT O_RDONLY -1 CONSTANT O_WRONLY -2 CONSTANT O_RDWR - -\ openat2() flags -1 6 LSHIFT CONSTANT O_CREAT -1 7 LSHIFT CONSTANT O_EXCL -1 9 LSHIFT CONSTANT O_TRUNC -1 10 LSHIFT CONSTANT O_APPEND -1 11 LSHIFT CONSTANT O_NONBLOCK - -\ Names for the standard file descriptor numbers -0 CONSTANT STDIN -1 CONSTANT STDOUT -2 CONSTANT STDERR - ->>FORTH - -\ Write one character to FD 1 (stdout) -: EMIT ( c -- "c" ) - SP@ 2DUP C! STDOUT SWAP 1 SYS_WRITE SYSCALL3 2DROP ; - -\ Write a character array to the given file descriptor -\ Repeat write syscall until entire string is written -\ Abandon output on any error other than EINTR -: TYPE-FD ( c-addr u fd -- "ccc" ) - >R - BEGIN - ?DUP - WHILE - 2DUP R@ -ROT SYS_WRITE SYSCALL3 - DUP 0<= IF - ERRNO_EINTR NEGATE <> IF - 2DROP RDROP EXIT - THEN - ELSE - /STRING - THEN - REPEAT - DROP RDROP ; - -\ Specializations for output to stdout and stderr -: TYPE ( c-addr u -- "ccc" ) STDOUT TYPE-FD ; -: TYPE-ERR ( c-addr u -- "ccc" ) STDERR TYPE-FD ; - \ Get the execution token of the most recent word in the compilation word list \ If the word list is empty the result will be zero -: LATEST ( -- xt | 0 ) GET-CURRENT @ ; ->>SYSTEM +: LATEST ( -- xt | 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 @@ -594,7 +170,473 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) : [ ( -- ) 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 @@ -620,7 +662,7 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) : UMAX 2DUP U< IF NIP ELSE DROP THEN ; \ Return -1, 0, or 1 if n is respectively negative, zero, or positive -: SIGNUM ( n -- -1 | 0 | 1 ) DUP IF 0< 2 * 1+ THEN ; +: SIGNUM ( n -- -1 | 0 | 1 ) DUP 0<= SWAP 0>= - ; \ Double-cell versions of standard numeric words : DABS ( d -- +d ) 2DUP D0< IF DNEGATE THEN ; @@ -674,12 +716,18 @@ 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 OVER -! @ C! ; +: 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 ) @@ -704,8 +752,12 @@ CREATE PNO-POINTER PNO-BUFFER-END , : 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 @@ -742,14 +794,12 @@ CREATE DISPLAY-ITEM-LIMIT 6 , THEN HERE + DUP BRK @ U> IF [ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND - BEGIN - DUP SYS_BRK SYSCALL1 - DUP [ ERRNO_EINTR NEGATE ] LITERAL <> DUP IF NIP THEN - UNTIL - OVER <> IF EXCP-DICTIONARY-OVERFLOW THROW THEN + 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! ; @@ -760,11 +810,12 @@ CREATE DISPLAY-ITEM-LIMIT 6 , \ Allocate two cells from the data area and fill them with the values on the stack : 2, HERE [ 2 CELLS ] LITERAL ALLOT 2! ; -\ Allocate bytes from the data area (less than one cell) to cell-align the address -: ALIGN HERE ALIGNED HERE - BEGIN ?DUP WHILE 0 C, 1- REPEAT ; +\ 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 ; -: 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. @@ -790,6 +841,14 @@ CREATE DISPLAY-ITEM-LIMIT 6 , : 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. @@ -804,7 +863,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 , \ Via ONWARD-IF and ONWARD-AHEAD the unresolve branch offset cell may be used \ as the link field of a linked list to connect multiple forward branches to \ the same THEN. When THEN is executed it will follow the links and update all -\ the connected branches to the same location. The list is terminated with zero +\ 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 @@ -813,12 +872,12 @@ CREATE DISPLAY-ITEM-LIMIT 6 , \ IF ONWARD-IF ELSE THEN \ \ ALWAYS is provided as a placeholder; it has the same effect as TRUE IF but -\ includes no branch. The "orig" value it leaves on the stack (zero) is ignored +\ 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. \ \ The low-level primitives: -: ALWAYS ( C: -- orig ) IMMEDIATE 0 ; +: ALWAYS ( C: -- orig ) IMMEDIATE NULL ; : ONWARD-IF ( C: orig1 -- orig2 ) IMMEDIATE POSTPONE 0BRANCH HERE SWAP , ; : ONWARD-AHEAD ( C: orig1 -- orig2 ) IMMEDIATE @@ -851,7 +910,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 , POSTPONE BRANCH HERE - , ; \ Simple conditional loop: BEGIN UNTIL -\ UNTIL consumes the top of the stack and branches back to BEGIN if the value was zero. +\ UNTIL consumes the top of the stack and branches back to BEGIN if the value was FALSE. : UNTIL ( C: dest -- ) ( Runtime S: flag -- ) IMMEDIATE POSTPONE 0BRANCH HERE - , ; @@ -874,7 +933,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 , \ a forward reference to the ENDOF (as with IF ... THEN) above the ENDCASE counter. \ \ Begin by creating a placeholder for the unresolved ENDOF forward references -: CASE ( C: -- 0 ) IMMEDIATE +: 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 @@ -892,7 +951,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 , \ DO +LOOP \ ?DO LOOP \ ?DO +LOOP -CREATE LEAVE-ORIG 0 , +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 ! @@ -924,13 +983,12 @@ CREATE LEAVE-ORIG 0 , \ Return -1, 0, or 1 if the left string is respectively \ less than, equal to, or greater than the right string : COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 ) - ROT SWAP 2DUP - >R UMIN 0 ?DO - ( S: c-addr1 c-addr2 R: u1-u2 loop-sys ) + 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: c-addr1 c-addr2 ch1 ch2 ) - - ?DUP IF NIP NIP SIGNUM UNLOOP RDROP EXIT THEN - LOOP - 2DROP R> SIGNUM ; + ( 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 ) @@ -938,16 +996,16 @@ CREATE LEAVE-ORIG 0 , \ Convert a character to lowercase or uppercase, respectively : TO-LOWER ( ch1 -- ch2 ) - DUP [CHAR] A [CHAR] Z WITHIN IF [ CHAR a CHAR A - ] LITERAL + THEN ; + 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 - ] LITERAL - THEN ; + 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 - ] LITERAL - TRUE EXIT THEN - DUP [CHAR] a [CHAR] z WITHIN IF [ CHAR a 10 - ] LITERAL - 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 @@ -977,6 +1035,15 @@ CREATE LEAVE-ORIG 0 , 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, @@ -984,6 +1051,8 @@ CREATE INPUT-BUFFER SOURCE 2, \ 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 @ ; @@ -1015,6 +1084,9 @@ DEFER QUIT ( -- ) 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 @@ -1025,7 +1097,7 @@ DEFER QUIT ( -- ) ' DEFAULT-UNWIND ' THROW-UNWIND DEFER! -CREATE EXCEPTION-STACK 0 , +CREATE EXCEPTION-STACK NULL , \ Called when THROW is called inside of CATCH \ Restore the input source specification, stack point, and return stack pointer @@ -1075,7 +1147,7 @@ CREATE EXCEPTION-STACK 0 , : PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ; ->>SYSTEM +>>UTILITY : PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ; @@ -1106,7 +1178,7 @@ DEFER REFILL SKIP-SPACES PARSE-EMPTY? WHILE - REFILL 0= IF 0 0 EXIT THEN + REFILL 0= IF NULL 0 EXIT THEN REPEAT PARSE-AREA DROP BEGIN @@ -1116,29 +1188,34 @@ DEFER REFILL REPEAT PARSE-AREA DROP OVER - ; -\ Use to create words programmatically without reading the name from the input -: (CREATE) ( c-addr u -- ) - ALIGN HERE - DODATA , 0 , LATEST , - -ROT DUP C, HERE SWAP DUP ALLOT CMOVE - ALIGN HERE OVER >DFA ! - LATEST! ; +>>SYSTEM -: CREATE ( "ccc" -- ) - WORD (CREATE) ; +\ 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" -- ) + WORD (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 0 , POSTPONE (DOES) POSTPONE EXIT - HERE SWAP ! ; - -' (DOES) (HIDE) + 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 ; @@ -1149,13 +1226,19 @@ DEFER REFILL \ 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 ] ; + 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 ) @@ -1171,13 +1254,13 @@ DEFER REFILL : 2CONSTANT : POSTPONE 2LITERAL POSTPONE ; ; \ Define a single-cell named variable which returns its data address when executed. -\ The initial value is formally undefined. This implementation sets it to zero. +\ The initial value is formally undefined. This implementation sets it to NULL. \ Execution: ( "name" -- ) \ name Execution: ( -- a-addr ) -: VARIABLE CREATE 0 , ; +: VARIABLE CREATE NULL , ; \ Same for double-cell variables (two-variables) -: 2VARIABLE CREATE [ 0 0 ] 2LITERAL 2, ; +: 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. @@ -1188,12 +1271,12 @@ DEFER REFILL \ Define an array of n single-cell elements \ name Runtime: ( n -- a-addr ) Return the address of the cell at index n : ARRAY ( n "name" -- ) - CREATE CELLS ALLOT DOES> SWAP [ CELL ] LITERAL * + ; + 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 ] LITERAL * + ; + CREATE 2* CELLS ALLOT DOES> SWAP [[ 2 CELLS ]] * + ; \ Structures begin with byte alignment and an offset of zero 1 0 2CONSTANT STRUCT @@ -1203,17 +1286,44 @@ DEFER REFILL 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 ; + : -ROT NATURALLY-ALIGNED ▪ DUP >R ▪ ALIGNED-TO DUP + ?DUP IF POSTPONE LITERAL POSTPONE + ELSE POSTPONE IMMEDIATE THEN + POSTPONE ; ▪ + SWAP R> UMAX SWAP ; \ Consume the final alignment and offset and define a type descriptor for the struct : ENDSTRUCT ( align offset "name" -- ) - OVER ALIGNED-TO 2CONSTANT ; + SWAP NATURALLY-ALIGNED TUCK ALIGNED-TO 2CONSTANT ; \ Accessors for type descriptors : %SIZEOF ( align size -- size ) IMMEDIATE @@ -1222,17 +1332,10 @@ DEFER REFILL STATE @ IF POSTPONE DROP ELSE DROP THEN ; \ Like : but the definition has no name -\ The zero-length name still included in the word list so LATEST can refer to it +\ 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 ( -- ) - ALIGN HERE DOCOL , HERE 3 CELLS+ , LATEST , F_HIDDEN C, - DUP LATEST! ALIGN POSTPONE ] ; - -\ Use the deferred-word mechanism to create an alternate name for the given xt -\ A deferred word, while indirect, is faster than a single-word colon definition -\ and avoids the creation of a redundant return stack frame -: ALIAS ( xt "ccc" -- ) - CREATE LATEST DEFER! ; + "" (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 @@ -1257,8 +1360,7 @@ DEFER REFILL STATE @ DUP IF LATEST - DUP >LINK @ LATEST! - 0 OVER >LINK ! + NULL OVER >LINK XCHG LATEST! POSTPONE AHEAD ROT POSTPONE [ @@ -1290,9 +1392,10 @@ DEFER REFILL \ The default target throws an exception — replace it using DEFER! or IS : DEFER ( "ccc" -- ) { "Uninitialized deferred word" FAIL } ALIAS ; -\ Conditional compilation +\ 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 @@ -1345,16 +1448,16 @@ BUDDY-ORDERS 1- BUDDY-ORDER-BYTES CONSTANT BUDDY-MAX-BYTES BUDDY-ORDERS ARRAY BUDDY-HEADS { BUDDY-ORDERS 0 ?DO 0 I BUDDY-HEADS ! LOOP } EXECUTE -: BUDDY-FREE ( order a-addr -- ) - OVER BUDDY-ORDERS U>= "order out of bounds" ?FAIL +: 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 0= IF + DUP NULL= IF \ Append to end of list - DROP 0 R@ ! R> SWAP ! + DROP NULL R@ ! R> SWAP ! DROP EXIT THEN ( S: order head-addr block-addr ) ( R: freed-addr ) @@ -1379,18 +1482,21 @@ BUDDY-ORDERS ARRAY BUDDY-HEADS DUP BUDDY-ORDERS U>= "order out of bounds" ?FAIL DUP BUDDY-HEADS @ ?DUP IF DUP @ ROT BUDDY-HEADS ! EXIT THEN DUP 1+ BUDDY-ORDERS >= IF EXCP-HEAP-OVERFLOW THROW THEN - DUP 1+ BUDDY-ALLOCATE SWAP 2DUP BUDDY-ORDER-BYTES + BUDDY-FREE ; + 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 0<> THEN + 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 - ] LITERAL U> + 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 @@ -1399,6 +1505,7 @@ VARIABLE TOTAL . "x" TYPE I BUDDY-ORDER-BYTES . SPACE THEN LOOP "total " TYPE TOTAL @ . EOL ; + ' TOTAL (HIDE) >>LINUX @@ -1413,19 +1520,16 @@ VARIABLE TOTAL 2 CONSTANT MAP_PRIVATE 32 CONSTANT MAP_ANONYMOUS ->>SYSTEM +>>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 ) - BEGIN - NULL OVER PROT_READ PROT_WRITE OR - MAP_PRIVATE MAP_ANONYMOUS OR -1 0 SYS_MMAP2 SYSCALL6 - DUP -4095 U>= - WHILE - NEGATE ERRNO_EINTR <> IF EXCP-HEAP-OVERFLOW THROW THEN - REPEAT NIP ; - -: MUNMAP ( addr length -- ) - DUP IF BEGIN 2DUP SYS_MUNMAP SYSCALL2 NEGATE ERRNO_EINTR <> UNTIL THEN 2DROP ; + 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 @@ -1435,22 +1539,27 @@ VARIABLE TOTAL ( S: addr size a-addr ) -ROT >R >R ( S: a-addr R: size addr ) - R@ OVER R@ - MUNMAP - DUP R> R@ 2* + SWAP R> + TUCK - MUNMAP ; + 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 + 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 ) 3235787545 CONSTANT MEMBLOCK-MAGIC +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 - ; + MEMBLOCK-DATA-OFFSET - DUP MEMBLOCK-CHECK-MAGIC ; >>FORTH @@ -1462,7 +1571,7 @@ ENDSTRUCT MEMBLOCK% NATURALLY-ALIGNED DUP BUDDY-MIN-BYTES U< IF DROP BUDDY-MIN-BYTES THEN BUDDY-ORDER-FROM-BYTES DUP ['] BUDDY-ALLOCATE CATCH ?DUP IF DUP EXCP-HEAP-OVERFLOW <> IF RETHROW THEN DROP - BUDDY-ORDERS 1- BUDDY-MAX-BYTES MMAP-ALLOCATE-ALIGNED BUDDY-FREE + BUDDY-MAX-BYTES MMAP-ALLOCATE-ALIGNED BUDDY-ORDERS 1- BUDDY-FREE BUDDY-ALLOCATE THEN THEN @@ -1472,21 +1581,11 @@ ENDSTRUCT MEMBLOCK% : FREE ( obj-addr -- ) ?DUP IF - DATA>MEMBLOCK - DUP MEMBLOCK>MAGIC @ MEMBLOCK-MAGIC <> IF EXCP-INVALID-ADDRESS THROW THEN - 0 OVER MEMBLOCK>MAGIC ! - DUP MEMBLOCK>SIZE @ - DUP BUDDY-ORDERS U< IF - SWAP BUDDY-FREE - ELSE - BEGIN - 2DUP SYS_MUNMAP SYSCALL2 ?DUP 0= IF 2DROP EXIT THEN - NEGATE ERRNO_EINTR <> "munmap failed" ?FAIL - AGAIN - THEN + DATA>MEMBLOCK ▪ 0 OVER MEMBLOCK>MAGIC ! ▪ DUP MEMBLOCK>SIZE @ + DUP BUDDY-ORDERS U< IF BUDDY-FREE ELSE MMAP-UNMAP THEN THEN ; ->>SYSTEM +>>UTILITY : OBJECT-SIZE ( obj-addr -- size ) DUP IF @@ -1498,16 +1597,16 @@ ENDSTRUCT MEMBLOCK% >>FORTH -\ If size is 0 then free obj-addr1 (which may be zero / NULL) and return 0 -\ Otherwise if obj-addr1 is 0 (NULL) then allocate size bytes +\ If 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 | 0 ) - DUP 0= IF DROP FREE 0 EXIT THEN - OVER 0= IF NIP ALLOCATE EXIT THEN +: 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 @@ -1543,14 +1642,23 @@ ENDSTRUCT MEMBLOCK% >>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 OVER ! CELL+ [ ' (CLOSURE) >DFA @ ] LITERAL OVER ! CELL+ - 0 OVER ! CELL+ 0 OVER ! CELL+ 2DUP ! CELL+ N! 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 @@ -1562,56 +1670,53 @@ ENDSTRUCT MEMBLOCK% : %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 + CELL% FIELD ORDER>LINK + CELL% FIELD ORDER>WID ENDSTRUCT ORDER% VARIABLE CURRENT-ORDER -0 CURRENT-ORDER ! +NULL CURRENT-ORDER ! >>FORTH \ Return the current search order : GET-ORDER ( -- widn ... wid1 n ) - 0 CURRENT-ORDER @ - \ Traverse the linked list, placing identifiers on the return stack and counting - BEGIN ?DUP WHILE DUP ORDER>WID @ >R ORDER>LINK @ SWAP 1+ SWAP REPEAT - ( S: n ) ( R: wid1 ... widn ) - \ Shift the search order list from the return stack back to the data stack - DUP BEGIN ?DUP WHILE 1- R> -ROT REPEAT - ( S: widn ... wid1 n ) ; + { ?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 ! - CURRENT-ORDER @ OVER ORDER>LINK ! - CURRENT-ORDER ! ; + 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 | 0 ) +: 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 | 0 ) +: 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 - 0 CURRENT-ORDER XCHG BEGIN ?DUP WHILE DUP ORDER>LINK @ SWAP FREE REPEAT + 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 ; @@ -1624,7 +1729,7 @@ BOOTSTRAP-GET-ORDER SET-ORDER \ Create a new wordlist \ In this implementation a word list is just a pointer to the most recent word : WORDLIST ( -- wid ) - ALIGN HERE 0 , ; + ALIGN HERE NULL , ; \ Make the first list in the search order the current compilation word list : DEFINITIONS ( -- ) PEEK-ORDER SET-CURRENT ; @@ -1632,17 +1737,9 @@ BOOTSTRAP-GET-ORDER SET-ORDER \ 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 ; + >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 ) @@ -1685,6 +1782,7 @@ BOOTSTRAP-GET-ORDER SET-ORDER \ 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 ) @@ -1699,7 +1797,7 @@ BOOTSTRAP-GET-ORDER SET-ORDER REPEAT 2R> 0 ; ->>SYSTEM +>>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 ) @@ -1764,8 +1862,8 @@ BOOTSTRAP-GET-ORDER SET-ORDER TERMINAL-BUFFER-BYTES ALLOCATE CONSTANT TERMINAL-BUFFER \ If we read more than one line then these will refer to the rest of the data -CREATE TIB-LEFTOVER 0 , -CREATE TIB-LEFTOVER-BYTES 0 , +2VARIABLE TIB-LEFTOVER +NULL 0 TIB-LEFTOVER 2! >>FORTH @@ -1775,22 +1873,16 @@ CREATE TIB-LEFTOVER-BYTES 0 , :REPLACE REFILL ( -- flag ) SOURCE-ID 0< IF FALSE EXIT THEN \ Shift any leftover characters after the previous line to the start of the buffer - TIB-LEFTOVER @ TERMINAL-BUFFER TIB-LEFTOVER-BYTES @ CMOVE + TIB-LEFTOVER 2@ TERMINAL-BUFFER SWAP DUP >R CMOVE \ Look for the linefeed character which marks the end of the first line - TIB-LEFTOVER-BYTES @ 0 BEGIN + 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 ) - \ Repeat read if interrupted by a signal (returns -EINTR) - BEGIN - SYS_READ SYSCALL3 - DUP ERRNO_EINTR NEGATE <> - UNTIL - \ Any other negative (error) return value is fatal - DUP 0< IF EXCP-FILE-IO THROW THEN + 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 @@ -1806,15 +1898,14 @@ CREATE TIB-LEFTOVER-BYTES 0 , ( S: length idx ) \ idx is the next location after the linefeed, if found, or else equal to length \ Save the rest, if any, for the next REFILL - DUP TERMINAL-BUFFER + TIB-LEFTOVER ! - TUCK - TIB-LEFTOVER-BYTES ! + 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<> ; ->>SYSTEM +>>UTILITY : ESCAPED-CHAR ( "" | "c" -- c ) NEXT-CHAR DUP [CHAR] \ = IF @@ -1834,8 +1925,12 @@ CREATE TIB-LEFTOVER-BYTES 0 , ENDCASE THEN ; +>>SYSTEM + 2VARIABLE STRING-BUFFER -0 0 STRING-BUFFER 2! +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 @@ -1846,7 +1941,7 @@ CREATE TIB-LEFTOVER-BYTES 0 , STRING-BUFFER 2@ 0 ( S: addr length index ) BEGIN - PEEK-CHAR [CHAR] " <> + 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 @@ -1855,16 +1950,9 @@ CREATE TIB-LEFTOVER-BYTES 0 , 2DUP STRING-BUFFER 2! ROT THEN ROT 2DUP + ESCAPED-CHAR SWAP C! -ROT 1+ - REPEAT - SKIP-CHAR NIP ; + REPEAT ▪ NIP ; -: PARSENUMBER ( c-addr u -- n TRUE | c-addr u FALSE ) - DUP 0= IF FALSE EXIT THEN - 2DUP OVER C@ [CHAR] - = DUP >R IF - 1/STRING DUP 0= IF 2DROP RDROP FALSE EXIT THEN - THEN - >NUMBER DUP 0<> IF 2DROP 2DROP RDROP FALSE EXIT THEN - 2DROP 2NIP DROP R> IF NEGATE THEN TRUE ; +>>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 @@ -1883,8 +1971,8 @@ CREATE TIB-LEFTOVER-BYTES 0 , THEN ELSE WORD - PARSENUMBER IF - STATE @ IF + 2DUP PARSENUMBER IF + STATE @ 2NIP IF POSTPONE LITERAL THEN ELSE @@ -1899,46 +1987,32 @@ CREATE TIB-LEFTOVER-BYTES 0 , >>FORTH : EVALUATE ( i*x c-addr u -- j*x ) - SAVE-INPUT N>R - SOURCE 2>R - SOURCE-ID >R - INPUT-BUFFER 2! - 0 >IN ! - -1 CURRENT-SOURCE-ID ! - INTERPRET - R> CURRENT-SOURCE-ID ! - 2R> INPUT-BUFFER 2! - NR> RESTORE-INPUT DROP ; + 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 -: TYPEDEF 2CONSTANT ; - -CHAR% TYPEDEF unsigned-char% -CHAR% TYPEDEF signed-char% -CELL% TYPEDEF unsigned-int% -CELL% TYPEDEF signed-int% - -unsigned-char% TYPEDEF cc_t% -unsigned-int% TYPEDEF speed_t% -unsigned-int% TYPEDEF tcflag_t% +' unsigned-char% ALIAS cc% +' unsigned-int% ALIAS speed% +' unsigned-int% ALIAS tcflag% 19 CONSTANT NCCS STRUCT -tcflag_t% FIELD termios-c_iflag -tcflag_t% FIELD termios-c_oflag -tcflag_t% FIELD termios-c_cflag -tcflag_t% FIELD termios-c_lflag -cc_t% FIELD termios-c_line -cc_t% NCCS * FIELD termios-c_cc + 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% -21505 CONSTANT IOCTL_TCGETS +0x5401 CONSTANT IOCTL_TCGETS >>SYSTEM -termios% %ALLOT CONSTANT SCRATCH-TERMIOS +termios% %VARIABLE SCRATCH-TERMIOS >>FORTH @@ -1962,21 +2036,31 @@ STDIN TTY? CONSTANT INTERACTIVE? [THEN] AGAIN ; -HIDE BOOTSTRAP-WORDLIST +' 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) ; -' (TRACE) (HIDE) +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 @@ -1999,31 +2083,24 @@ HIDE BOOTSTRAP-WORDLIST \ Display the top of the stack as a word name if possible, or a number otherwise \ Words with zero-length names (e.g. from :NONAME) are displayed as numbers : .W ( addr -- "" | "" ) - DUP WORD? IF - \ Some kind of word; is the name zero-length (:NONAME)? - DUP >NAME DUP IF - \ Is the name hidden? - 2 PICK HIDDEN? IF - "⌀" TYPE - ELSE - \ Does FIND with the same name fail to return the same word? - 2DUP FIND AND-THEN 3 PICK = ELSE NIP NIP THEN 0= IF - "¤" TYPE - THEN - THEN - TYPE - DROP + \ 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 - 2DROP "∷" TYPE U. + \ 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 word in the current search order or compilation word list - . + \ Not a named word in the current search order or compilation word list + "∷" TYPE U. THEN ; -\ Read one cell and increment -: @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ; - \ Display a string in escaped (double-quoted) format, without the delimiters : TYPE-ESCAPED ( c-addr u -- "" ) 0 ?DO DUP 1+ SWAP C@ CASE @@ -2061,6 +2138,8 @@ HIDE BOOTSTRAP-WORDLIST 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 @@ -2127,6 +2206,8 @@ HIDE NONAME-LITERAL? SWAP "CREATE " TYPE >NAME TYPE " … ;CODE … END-CODE\n" TYPE ENDCASE ; +PREVIOUS + : SEE ( "name" -- ) ' (SEE) ; HIDE UNTHREAD @@ -2135,44 +2216,46 @@ HIDE UNTHREAD 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 0 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 0 if the list is empty. &link is the address -\ of a node's link field. +\ 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 0 0 ROT BEGIN ?DUP WHILE TUCK R@ EXECUTE XCHG >R SWAP R> REPEAT RDROP SWAP ; + >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 0 >R RSP@ BEGIN + 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 0= IF NIP ! R> 2RDROP EXIT THEN - 2 PICK 0= IF ! DROP R> 2RDROP EXIT THEN + 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 0 in head2's link field; save &link2 under head2 on the stack + \ Store NULL in head2's link field; save &link2 under head2 on the stack \ Store head2 at &link - OVER 0 SWAP 2 RPICK EXECUTE DUP >R ! R> -ROT ! + 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 0= IF 2RDROP TRUE EXIT THEN + 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 0= IF DROP 2RDROP TRUE EXIT THEN + ?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 @@ -2188,10 +2271,6 @@ HIDE UNTHREAD 1 RPICK SPLIT 2R@ MERGE-SORT SWAP 2R@ MERGE-SORT 2R@ MERGE THEN 2RDROP ; -\ Return a closure which executes xt1 followed by xt2 -: COMPOSE ( xt1 xt2 -- xt3 ) - { >R EXECUTE R> EXECUTE } 2 CLOSURE ; - \ 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 ; diff --git a/test/resize.4th b/test/resize.4th index 2db2610..a4ad8c4 100644 --- a/test/resize.4th +++ b/test/resize.4th @@ -1,14 +1,18 @@ +ALSO UTILITY : STATUS ( obj-addr c-addr u -- obj-addr ) TYPE ":\n Value: " TYPE DUP @ . "\n Object size: " TYPE DUP OBJECT-SIZE U. EOL EOL ; +PREVIOUS SYSTEM-WORDLIST PUSH-ORDER +256 KB SIZEOF MEMBLOCK% - CONSTANT 256-KB-BLOCK +PREVIOUS : TEST 24 ALLOCATE 1234 OVER ! "Allocated 24 bytes" STATUS 33 RESIZE "Resized to 33 bytes" STATUS 24 RESIZE "Resized to 24 bytes" STATUS - 256 KB MEMBLOCK-DATA-OFFSET - RESIZE "Resized to 256 KiB - header" STATUS + 256-KB-BLOCK RESIZE "Resized to 256 KiB - header" STATUS 32 RESIZE "Resized to 32 bytes" STATUS 24 RESIZE "Resized to 24 bytes" STATUS 4 RESIZE "Resized to 4 bytes" STATUS