1939 lines
48 KiB
ArmAsm
1939 lines
48 KiB
ArmAsm
/* gcc -m32 -nostdlib -static -o jumpforth jumpforth.S */
|
|
|
|
#include <asm/unistd.h>
|
|
|
|
.code32
|
|
|
|
.set JUMPFORTH_VERSION,1
|
|
|
|
.set RETURN_STACK_SIZE,8192
|
|
|
|
.set DATA_SEGMENT_INITIAL_SIZE,65536
|
|
|
|
.set F_IMMED,0x80
|
|
.set F_HIDDEN,0x40
|
|
.set F_LENMASK,0x3f
|
|
|
|
.set link,0
|
|
|
|
.macro NEXT
|
|
lodsl
|
|
jmp *(%eax)
|
|
.endm
|
|
|
|
.macro PUSHRSP reg
|
|
lea -4(%ebp),%ebp
|
|
movl \reg ,(%ebp)
|
|
.endm
|
|
|
|
.macro POPRSP reg
|
|
mov (%ebp),\reg
|
|
lea 4(%ebp),%ebp
|
|
.endm
|
|
|
|
.text
|
|
.align 4
|
|
.globl _start
|
|
_start:
|
|
cld
|
|
mov %esp,data_S0
|
|
mov $return_stack_top,%ebp
|
|
xor %ebx,%ebx
|
|
movl $__NR_brk,%eax
|
|
int $0x80
|
|
movl %eax,data_C0
|
|
movl %eax,data_CP
|
|
movl %eax,%ebx
|
|
addl $DATA_SEGMENT_INITIAL_SIZE + 4096 - 1,%ebx
|
|
andl $-4096,%ebx
|
|
movl %ebx,data_BRK
|
|
movl $__NR_brk,%eax
|
|
int $0x80
|
|
cmpl %eax,(data_BRK)
|
|
jne 0f
|
|
mov $cold_start,%esi
|
|
NEXT
|
|
0: movl $254,%ebx
|
|
movl $__NR_exit,%eax
|
|
int $0x80
|
|
jmp 0b
|
|
|
|
/* The entry point for threaded FORTH words */
|
|
/* Push the return address (%esi) on the return stack */
|
|
/* Load the address of the body of the definition from the DFA field at %eax+4 */
|
|
.text
|
|
.align 4
|
|
.globl DOCOL
|
|
DOCOL:
|
|
PUSHRSP %esi
|
|
movl 4(%eax),%esi
|
|
NEXT
|
|
|
|
/* The entry point for deferred words */
|
|
/* The real execution token is in the DFA field */
|
|
/* Load the target xt and branch to the address in the target's codeword field */
|
|
.text
|
|
.align 4
|
|
.globl DODEFER
|
|
DODEFER:
|
|
movl 4(%eax),%eax
|
|
jmp *(%eax)
|
|
|
|
/* The default behavior for words defined with CREATE, VARIABLE, or CONSTANT */
|
|
/* Place the value of the DFA field on the top of the stack */
|
|
.text
|
|
.align 4
|
|
.globl DODATA
|
|
DODATA:
|
|
pushl 4(%eax)
|
|
NEXT
|
|
|
|
/* The default behavior for words defined with VALUE (or defvalue) */
|
|
/* Load the word at the address in the DFA field and place it on the stack */
|
|
.text
|
|
.align 4
|
|
.globl DOLOAD
|
|
DOLOAD:
|
|
movl 4(%eax),%eax
|
|
pushl (%eax)
|
|
NEXT
|
|
|
|
/* The entry point for threaded FORTH words defined with CREATE DOES> */
|
|
/* Push the return address (%esi) on the return stack */
|
|
/* Load the address of the DOES> code body from the DFA field at %eax+4 */
|
|
/* Push the address of the body of the word (not the DFA field) onto the stack */
|
|
.text
|
|
.align 4
|
|
.globl DODOES
|
|
DODOES:
|
|
/* Save threaded return address */
|
|
PUSHRSP %esi
|
|
/* Load address of DOES> body from DFA into %esi */
|
|
movl 4(%eax),%esi
|
|
/* Load name length byte into %eax and mask out flag bits */
|
|
xor %ebx,%ebx
|
|
movb 12(%eax),%bl
|
|
andb $F_LENMASK,%bl
|
|
/* Calculate %eax + 13 + %ebx and round up to next cell for address of body */
|
|
lea 16(%eax,%ebx),%eax
|
|
andl $-4,%eax
|
|
/* Push body address on the data stack */
|
|
push %eax
|
|
/* Execute the DOES> code */
|
|
NEXT
|
|
|
|
.macro litstring text:req
|
|
.int LITSTRING
|
|
.byte (9f - 8f)
|
|
8: .ascii "\text"
|
|
9: .align 4
|
|
.endm
|
|
|
|
.macro defname label:req,codeword:req,dataword:req,name="",flags=0
|
|
.section .data
|
|
.align 4
|
|
.globl \label
|
|
\label :
|
|
.int \codeword
|
|
.int \dataword
|
|
.int link
|
|
.set link,\label
|
|
.byte \flags+(9f-8f)
|
|
.ifeqs "\name",""
|
|
8: .ascii "\label"
|
|
.else
|
|
8: .ascii "\name"
|
|
.endif
|
|
9: .align 4
|
|
.endm
|
|
|
|
.macro defword label:req,name="",flags=0
|
|
defname \label,DOCOL,thread_\label,"\name",\flags
|
|
.section .rodata
|
|
.align 4
|
|
.globl thread_\label
|
|
thread_\label :
|
|
.endm
|
|
|
|
.macro defcode label:req,name="",dataword=0,flags=0
|
|
defname \label,code_\label,\dataword,"\name",\flags
|
|
.text
|
|
.globl code_\label
|
|
code_\label :
|
|
.endm
|
|
|
|
.macro defdata label:req,name="",flags=0
|
|
defname \label,DODATA,data_\label,"\name",\flags
|
|
.data
|
|
.align 4
|
|
data_\label :
|
|
.endm
|
|
|
|
.macro defvar label:req,initial=0,name="",flags=0
|
|
defdata \label,"\name",\flags
|
|
.int \initial
|
|
.endm
|
|
|
|
.macro defconst label:req,value,name="",flags=0
|
|
defname \label,DODATA,\value,"\name",\flags
|
|
.endm
|
|
|
|
/* Parameters are stored like variables but produce a value, not an address. */
|
|
/* Use this for data which is read-only after initialization. */
|
|
.macro defvalue label:req,initial=0,name="",flags=0
|
|
defname \label,DOLOAD,data_\label,"\name",\flags
|
|
.data
|
|
.align 4
|
|
data_\label :
|
|
.int \initial
|
|
.endm
|
|
|
|
defconst VERSION,JUMPFORTH_VERSION
|
|
|
|
defconst R0,return_stack_top
|
|
|
|
defconst __DOCOL,DOCOL,"DOCOL"
|
|
defconst __DODEFER,DODEFER,"DODEFER"
|
|
defconst __DODATA,DODATA,"DODATA"
|
|
defconst __DOLOAD,DOLOAD,"DOLOAD"
|
|
defconst __DODOES,DODOES,"DODOES"
|
|
|
|
defconst FALSE,0
|
|
defconst TRUE,-1
|
|
|
|
defconst CELL,4
|
|
|
|
defconst __F_IMMED,F_IMMED,"F_IMMED"
|
|
defconst __F_HIDDEN,F_HIDDEN,"F_HIDDEN"
|
|
defconst __F_LENMASK,F_LENMASK,"F_LENMASK"
|
|
|
|
/*
|
|
** x86 system call numbers
|
|
*/
|
|
defconst SYS_EXIT,__NR_exit
|
|
/* defconst SYS_FORK,__NR_fork */
|
|
defconst SYS_READ,__NR_read
|
|
defconst SYS_WRITE,__NR_write
|
|
/* defconst SYS_CLOSE,__NR_close */
|
|
/* defconst SYS_WAITPID,__NR_waitpid */
|
|
/* defconst SYS_CHDIR,__NR_chdir */
|
|
/* defconst SYS_TIME,__NR_time */
|
|
/* defconst SYS_CHMOD,__NR_chmod */
|
|
/* defconst SYS_LSEEK,__NR_lseek */
|
|
defconst SYS_GETPID,__NR_getpid
|
|
/* defconst SYS_MOUNT,__NR_mount */
|
|
/* defconst SYS_STIME,__NR_stime */
|
|
/* defconst SYS_PTRACE,__NR_ptrace */
|
|
/* defconst SYS_ALARM,__NR_alarm */
|
|
/* defconst SYS_PAUSE,__NR_pause */
|
|
/* defconst SYS_UTIME,__NR_utime */
|
|
/* defconst SYS_ACCESS,__NR_access */
|
|
/* defconst SYS_NICE,__NR_nice */
|
|
/* defconst SYS_SYNC,__NR_sync */
|
|
/* defconst SYS_KILL,__NR_kill */
|
|
/* defconst SYS_RMDIR,__NR_rmdir */
|
|
/* defconst SYS_DUP,__NR_dup */
|
|
/* defconst SYS_TIMES,__NR_times */
|
|
defconst SYS_BRK,__NR_brk
|
|
/* defconst SYS_SIGNAL,__NR_signal */
|
|
/* defconst SYS_UMOUNT2,__NR_umount2 */
|
|
defconst SYS_IOCTL,__NR_ioctl
|
|
/* defconst SYS_SETPGID,__NR_setpgid */
|
|
/* defconst SYS_UMASK,__NR_umask */
|
|
/* defconst SYS_CHROOT,__NR_chroot */
|
|
/* defconst SYS_USTAT,__NR_ustat */
|
|
/* defconst SYS_GETPPID,__NR_getppid */
|
|
/* defconst SYS_GETPGRP,__NR_getpgrp */
|
|
/* defconst SYS_SETSID,__NR_setsid */
|
|
/* defconst SYS_SGETMASK,__NR_sgetmask */
|
|
/* defconst SYS_SSETMASK,__NR_ssetmask */
|
|
/* defconst SYS_SETHOSTNAME,__NR_sethostname */
|
|
/* defconst SYS_SETRLIMIT,__NR_setrlimit */
|
|
/* defconst SYS_GETRLIMIT,__NR_getrlimit */
|
|
/* defconst SYS_GETRUSAGE,__NR_getrusage */
|
|
/* defconst SYS_GETTIMEOFDAY,__NR_gettimeofday */
|
|
/* defconst SYS_SETTIMEOFDAY,__NR_settimeofday */
|
|
/* defconst SYS_SELECT,__NR_select */
|
|
/* defconst SYS_SWAPON,__NR_swapon */
|
|
/* defconst SYS_REBOOT,__NR_reboot */
|
|
/* defconst SYS_READDIR,__NR_readdir */
|
|
defconst SYS_MUNMAP,__NR_munmap
|
|
/* defconst SYS_GETPRIORITY,__NR_getpriority */
|
|
/* defconst SYS_SETPRIORITY,__NR_setpriority */
|
|
/* defconst SYS_IOPERM,__NR_ioperm */
|
|
/* defconst SYS_SYSLOG,__NR_syslog */
|
|
/* defconst SYS_SETITIMER,__NR_setitimer */
|
|
/* defconst SYS_GETITIMER,__NR_getitimer */
|
|
/* defconst SYS_IOPL,__NR_iopl */
|
|
/* defconst SYS_VHANGUP,__NR_vhangup */
|
|
/* defconst SYS_IDLE,__NR_idle */
|
|
/* defconst SYS_WAIT4,__NR_wait4 */
|
|
/* defconst SYS_SWAPOFF,__NR_swapoff */
|
|
/* defconst SYS_SYSINFO,__NR_sysinfo */
|
|
/* defconst SYS_IPC,__NR_ipc */
|
|
/* defconst SYS_FSYNC,__NR_fsync */
|
|
/* defconst SYS_SETDOMAINNAME,__NR_setdomainname */
|
|
/* defconst SYS_UNAME,__NR_uname */
|
|
/* defconst SYS_MODIFY_LDT,__NR_modify_ldt */
|
|
/* defconst SYS_ADJTIMEX,__NR_adjtimex */
|
|
/* defconst SYS_MPROTECT,__NR_mprotect */
|
|
/* defconst SYS_INIT_MODULE,__NR_init_module */
|
|
/* defconst SYS_DELETE_MODULE,__NR_delete_module */
|
|
/* defconst SYS_QUOTACTL,__NR_quotactl */
|
|
/* defconst SYS_GETPGID,__NR_getpgid */
|
|
/* defconst SYS_FCHDIR,__NR_fchdir */
|
|
/* defconst SYS_SYSFS,__NR_sysfs */
|
|
/* defconst SYS_PERSONALITY,__NR_personality */
|
|
/* defconst SYS__LLSEEK,__NR__llseek */
|
|
/* defconst SYS__NEWSELECT,__NR__newselect */
|
|
/* defconst SYS_FLOCK,__NR_flock */
|
|
/* defconst SYS_MSYNC,__NR_msync */
|
|
/* defconst SYS_READV,__NR_readv */
|
|
/* defconst SYS_WRITEV,__NR_writev */
|
|
/* defconst SYS_GETSID,__NR_getsid */
|
|
/* defconst SYS_FDATASYNC,__NR_fdatasync */
|
|
/* defconst SYS__SYSCTL,__NR__sysctl */
|
|
/* defconst SYS_MUNLOCK,__NR_munlock */
|
|
/* defconst SYS_MLOCKALL,__NR_mlockall */
|
|
/* defconst SYS_MUNLOCKALL,__NR_munlockall */
|
|
/* defconst SYS_SCHED_SETPARAM,__NR_sched_setparam */
|
|
/* defconst SYS_SCHED_GETPARAM,__NR_sched_getparam */
|
|
/* defconst SYS_SCHED_SETSCHEDULER,__NR_sched_setscheduler */
|
|
/* defconst SYS_SCHED_GETSCHEDULER,__NR_sched_getscheduler */
|
|
/* defconst SYS_SCHED_YIELD,__NR_sched_yield */
|
|
/* defconst SYS_SCHED_GET_PRIORITY_MAX,__NR_sched_get_priority_max */
|
|
/* defconst SYS_SCHED_GET_PRIORITY_MIN,__NR_sched_get_priority_min */
|
|
/* defconst SYS_NANOSLEEP,__NR_nanosleep */
|
|
/* defconst SYS_MREMAP,__NR_mremap */
|
|
/* defconst SYS_VM86,__NR_vm86 */
|
|
/* defconst SYS_POLL,__NR_poll */
|
|
/* defconst SYS_PRCTL,__NR_prctl */
|
|
/* defconst SYS_RT_SIGRETURN,__NR_rt_sigreturn */
|
|
/* defconst SYS_RT_SIGACTION,__NR_rt_sigaction */
|
|
/* defconst SYS_RT_SIGPROCMASK,__NR_rt_sigprocmask */
|
|
/* defconst SYS_RT_SIGPENDING,__NR_rt_sigpending */
|
|
/* defconst SYS_RT_SIGQUEUEINFO,__NR_rt_sigqueueinfo */
|
|
/* defconst SYS_RT_SIGSUSPEND,__NR_rt_sigsuspend */
|
|
/* defconst SYS_PREAD64,__NR_pread64 */
|
|
/* defconst SYS_PWRITE64,__NR_pwrite64 */
|
|
/* defconst SYS_GETCWD,__NR_getcwd */
|
|
/* defconst SYS_CAPGET,__NR_capget */
|
|
/* defconst SYS_CAPSET,__NR_capset */
|
|
/* defconst SYS_SIGALTSTACK,__NR_sigaltstack */
|
|
/* defconst SYS_VFORK,__NR_vfork */
|
|
defconst SYS_MMAP2,__NR_mmap2
|
|
/* defconst SYS_TRUNCATE64,__NR_truncate64 */
|
|
/* defconst SYS_FTRUNCATE64,__NR_ftruncate64 */
|
|
/* defconst SYS_STAT64,__NR_stat64 */
|
|
/* defconst SYS_LSTAT64,__NR_lstat64 */
|
|
/* defconst SYS_LCHOWN32,__NR_lchown32 */
|
|
/* defconst SYS_GETUID32,__NR_getuid32 */
|
|
/* defconst SYS_GETGID32,__NR_getgid32 */
|
|
/* defconst SYS_GETEUID32,__NR_geteuid32 */
|
|
/* defconst SYS_GETEGID32,__NR_getegid32 */
|
|
/* defconst SYS_SETREUID32,__NR_setreuid32 */
|
|
/* defconst SYS_SETREGID32,__NR_setregid32 */
|
|
/* defconst SYS_GETGROUPS32,__NR_getgroups32 */
|
|
/* defconst SYS_SETGROUPS32,__NR_setgroups32 */
|
|
/* defconst SYS_SETRESUID32,__NR_setresuid32 */
|
|
/* defconst SYS_GETRESUID32,__NR_getresuid32 */
|
|
/* defconst SYS_SETRESGID32,__NR_setresgid32 */
|
|
/* defconst SYS_GETRESGID32,__NR_getresgid32 */
|
|
/* defconst SYS_CHOWN32,__NR_chown32 */
|
|
/* defconst SYS_SETUID32,__NR_setuid32 */
|
|
/* defconst SYS_SETGID32,__NR_setgid32 */
|
|
/* defconst SYS_SETFSUID32,__NR_setfsuid32 */
|
|
/* defconst SYS_SETFSGID32,__NR_setfsgid32 */
|
|
/* defconst SYS_PIVOT_ROOT,__NR_pivot_root */
|
|
/* defconst SYS_MINCORE,__NR_mincore */
|
|
/* defconst SYS_MADVISE,__NR_madvise */
|
|
/* defconst SYS_GETDENTS64,__NR_getdents64 */
|
|
/* defconst SYS_FCNTL64,__NR_fcntl64 */
|
|
defconst SYS_GETTID,__NR_gettid
|
|
/* defconst SYS_READAHEAD,__NR_readahead */
|
|
/* defconst SYS_SETXATTR,__NR_setxattr */
|
|
/* defconst SYS_LSETXATTR,__NR_lsetxattr */
|
|
/* defconst SYS_FSETXATTR,__NR_fsetxattr */
|
|
/* defconst SYS_GETXATTR,__NR_getxattr */
|
|
/* defconst SYS_LGETXATTR,__NR_lgetxattr */
|
|
/* defconst SYS_FGETXATTR,__NR_fgetxattr */
|
|
/* defconst SYS_LISTXATTR,__NR_listxattr */
|
|
/* defconst SYS_LLISTXATTR,__NR_llistxattr */
|
|
/* defconst SYS_FLISTXATTR,__NR_flistxattr */
|
|
/* defconst SYS_REMOVEXATTR,__NR_removexattr */
|
|
/* defconst SYS_LREMOVEXATTR,__NR_lremovexattr */
|
|
/* defconst SYS_FREMOVEXATTR,__NR_fremovexattr */
|
|
/* defconst SYS_SENDFILE64,__NR_sendfile64 */
|
|
/* defconst SYS_SCHED_SETAFFINITY,__NR_sched_setaffinity */
|
|
/* defconst SYS_SCHED_GETAFFINITY,__NR_sched_getaffinity */
|
|
/* defconst SYS_SET_THREAD_AREA,__NR_set_thread_area */
|
|
/* defconst SYS_GET_THREAD_AREA,__NR_get_thread_area */
|
|
/* defconst SYS_IO_SETUP,__NR_io_setup */
|
|
/* defconst SYS_IO_DESTROY,__NR_io_destroy */
|
|
/* defconst SYS_IO_GETEVENTS,__NR_io_getevents */
|
|
/* defconst SYS_IO_SUBMIT,__NR_io_submit */
|
|
/* defconst SYS_IO_CANCEL,__NR_io_cancel */
|
|
/* defconst SYS_EXIT_GROUP,__NR_exit_group */
|
|
/* defconst SYS_LOOKUP_DCOOKIE,__NR_lookup_dcookie */
|
|
/* defconst SYS_EPOLL_CTL,__NR_epoll_ctl */
|
|
/* defconst SYS_EPOLL_WAIT,__NR_epoll_wait */
|
|
/* defconst SYS_REMAP_FILE_PAGES,__NR_remap_file_pages */
|
|
/* defconst SYS_SET_TID_ADDRESS,__NR_set_tid_address */
|
|
/* defconst SYS_TIMER_CREATE,__NR_timer_create */
|
|
/* defconst SYS_TIMER_GETOVERRUN,__NR_timer_getoverrun */
|
|
/* defconst SYS_TIMER_DELETE,__NR_timer_delete */
|
|
/* defconst SYS_STATFS64,__NR_statfs64 */
|
|
/* defconst SYS_FSTATFS64,__NR_fstatfs64 */
|
|
defconst SYS_TGKILL,__NR_tgkill
|
|
/* defconst SYS_UTIMES,__NR_utimes */
|
|
/* defconst SYS_FADVISE64_64,__NR_fadvise64_64 */
|
|
/* defconst SYS_MBIND,__NR_mbind */
|
|
/* defconst SYS_GET_MEMPOLICY,__NR_get_mempolicy */
|
|
/* defconst SYS_SET_MEMPOLICY,__NR_set_mempolicy */
|
|
/* defconst SYS_MQ_OPEN,__NR_mq_open */
|
|
/* defconst SYS_MQ_UNLINK,__NR_mq_unlink */
|
|
/* defconst SYS_MQ_NOTIFY,__NR_mq_notify */
|
|
/* defconst SYS_MQ_GETSETATTR,__NR_mq_getsetattr */
|
|
/* defconst SYS_KEXEC_LOAD,__NR_kexec_load */
|
|
/* defconst SYS_WAITID,__NR_waitid */
|
|
/* defconst SYS_ADD_KEY,__NR_add_key */
|
|
/* defconst SYS_REQUEST_KEY,__NR_request_key */
|
|
/* defconst SYS_KEYCTL,__NR_keyctl */
|
|
/* defconst SYS_IOPRIO_SET,__NR_ioprio_set */
|
|
/* defconst SYS_IOPRIO_GET,__NR_ioprio_get */
|
|
/* defconst SYS_INOTIFY_ADD_WATCH,__NR_inotify_add_watch */
|
|
/* defconst SYS_INOTIFY_RM_WATCH,__NR_inotify_rm_watch */
|
|
/* defconst SYS_MIGRATE_PAGES,__NR_migrate_pages */
|
|
/* defconst SYS_MKDIRAT,__NR_mkdirat */
|
|
/* defconst SYS_MKNODAT,__NR_mknodat */
|
|
/* defconst SYS_FCHOWNAT,__NR_fchownat */
|
|
/* defconst SYS_FUTIMESAT,__NR_futimesat */
|
|
/* defconst SYS_FSTATAT64,__NR_fstatat64 */
|
|
/* defconst SYS_UNLINKAT,__NR_unlinkat */
|
|
/* defconst SYS_LINKAT,__NR_linkat */
|
|
/* defconst SYS_SYMLINKAT,__NR_symlinkat */
|
|
/* defconst SYS_READLINKAT,__NR_readlinkat */
|
|
/* defconst SYS_FCHMODAT,__NR_fchmodat */
|
|
/* defconst SYS_UNSHARE,__NR_unshare */
|
|
/* defconst SYS_SET_ROBUST_LIST,__NR_set_robust_list */
|
|
/* defconst SYS_GET_ROBUST_LIST,__NR_get_robust_list */
|
|
/* defconst SYS_SPLICE,__NR_splice */
|
|
/* defconst SYS_SYNC_FILE_RANGE,__NR_sync_file_range */
|
|
/* defconst SYS_TEE,__NR_tee */
|
|
/* defconst SYS_VMSPLICE,__NR_vmsplice */
|
|
/* defconst SYS_MOVE_PAGES,__NR_move_pages */
|
|
/* defconst SYS_GETCPU,__NR_getcpu */
|
|
/* defconst SYS_EPOLL_PWAIT,__NR_epoll_pwait */
|
|
/* defconst SYS_TIMERFD_CREATE,__NR_timerfd_create */
|
|
/* defconst SYS_FALLOCATE,__NR_fallocate */
|
|
/* defconst SYS_SIGNALFD4,__NR_signalfd4 */
|
|
/* defconst SYS_EVENTFD2,__NR_eventfd2 */
|
|
/* defconst SYS_EPOLL_CREATE1,__NR_epoll_create1 */
|
|
/* defconst SYS_DUP3,__NR_dup3 */
|
|
/* defconst SYS_PIPE2,__NR_pipe2 */
|
|
/* defconst SYS_INOTIFY_INIT1,__NR_inotify_init1 */
|
|
/* defconst SYS_RT_TGSIGQUEUEINFO,__NR_rt_tgsigqueueinfo */
|
|
/* defconst SYS_PERF_EVENT_OPEN,__NR_perf_event_open */
|
|
/* defconst SYS_FANOTIFY_INIT,__NR_fanotify_init */
|
|
/* defconst SYS_FANOTIFY_MARK,__NR_fanotify_mark */
|
|
/* defconst SYS_PRLIMIT64,__NR_prlimit64 */
|
|
/* defconst SYS_NAME_TO_HANDLE_AT,__NR_name_to_handle_at */
|
|
/* defconst SYS_OPEN_BY_HANDLE_AT,__NR_open_by_handle_at */
|
|
/* defconst SYS_SYNCFS,__NR_syncfs */
|
|
/* defconst SYS_SENDMMSG,__NR_sendmmsg */
|
|
/* defconst SYS_SETNS,__NR_setns */
|
|
/* defconst SYS_PROCESS_VM_READV,__NR_process_vm_readv */
|
|
/* defconst SYS_PROCESS_VM_WRITEV,__NR_process_vm_writev */
|
|
/* defconst SYS_KCMP,__NR_kcmp */
|
|
/* defconst SYS_FINIT_MODULE,__NR_finit_module */
|
|
/* defconst SYS_SCHED_SETATTR,__NR_sched_setattr */
|
|
/* defconst SYS_SCHED_GETATTR,__NR_sched_getattr */
|
|
/* defconst SYS_RENAMEAT2,__NR_renameat2 */
|
|
/* defconst SYS_SECCOMP,__NR_seccomp */
|
|
/* defconst SYS_GETRANDOM,__NR_getrandom */
|
|
/* defconst SYS_MEMFD_CREATE,__NR_memfd_create */
|
|
/* defconst SYS_BPF,__NR_bpf */
|
|
/* defconst SYS_EXECVEAT,__NR_execveat */
|
|
/* defconst SYS_SOCKET,__NR_socket */
|
|
/* defconst SYS_SOCKETPAIR,__NR_socketpair */
|
|
/* defconst SYS_BIND,__NR_bind */
|
|
/* defconst SYS_CONNECT,__NR_connect */
|
|
/* defconst SYS_LISTEN,__NR_listen */
|
|
/* defconst SYS_ACCEPT4,__NR_accept4 */
|
|
/* defconst SYS_GETSOCKOPT,__NR_getsockopt */
|
|
/* defconst SYS_SETSOCKOPT,__NR_setsockopt */
|
|
/* defconst SYS_GETSOCKNAME,__NR_getsockname */
|
|
/* defconst SYS_GETPEERNAME,__NR_getpeername */
|
|
/* defconst SYS_SENDTO,__NR_sendto */
|
|
/* defconst SYS_SENDMSG,__NR_sendmsg */
|
|
/* defconst SYS_RECVFROM,__NR_recvfrom */
|
|
/* defconst SYS_RECVMSG,__NR_recvmsg */
|
|
/* defconst SYS_SHUTDOWN,__NR_shutdown */
|
|
/* defconst SYS_USERFAULTFD,__NR_userfaultfd */
|
|
/* defconst SYS_MEMBARRIER,__NR_membarrier */
|
|
/* defconst SYS_MLOCK2,__NR_mlock2 */
|
|
/* defconst SYS_COPY_FILE_RANGE,__NR_copy_file_range */
|
|
/* defconst SYS_PREADV2,__NR_preadv2 */
|
|
/* defconst SYS_PWRITEV2,__NR_pwritev2 */
|
|
/* defconst SYS_PKEY_MPROTECT,__NR_pkey_mprotect */
|
|
/* defconst SYS_PKEY_ALLOC,__NR_pkey_alloc */
|
|
/* defconst SYS_PKEY_FREE,__NR_pkey_free */
|
|
/* defconst SYS_STATX,__NR_statx */
|
|
/* defconst SYS_ARCH_PRCTL,__NR_arch_prctl */
|
|
/* defconst SYS_RSEQ,__NR_rseq */
|
|
/* defconst SYS_SEMGET,__NR_semget */
|
|
/* defconst SYS_SEMCTL,__NR_semctl */
|
|
/* defconst SYS_SHMGET,__NR_shmget */
|
|
/* defconst SYS_SHMCTL,__NR_shmctl */
|
|
/* defconst SYS_SHMAT,__NR_shmat */
|
|
/* defconst SYS_SHMDT,__NR_shmdt */
|
|
/* defconst SYS_MSGGET,__NR_msgget */
|
|
/* defconst SYS_MSGSND,__NR_msgsnd */
|
|
/* defconst SYS_MSGRCV,__NR_msgrcv */
|
|
/* defconst SYS_MSGCTL,__NR_msgctl */
|
|
/* defconst SYS_CLOCK_GETTIME64,__NR_clock_gettime64 */
|
|
/* defconst SYS_CLOCK_SETTIME64,__NR_clock_settime64 */
|
|
/* defconst SYS_CLOCK_ADJTIME64,__NR_clock_adjtime64 */
|
|
/* defconst SYS_CLOCK_GETRES_TIME64,__NR_clock_getres_time64 */
|
|
/* defconst SYS_CLOCK_NANOSLEEP_TIME64,__NR_clock_nanosleep_time64 */
|
|
/* defconst SYS_TIMER_GETTIME64,__NR_timer_gettime64 */
|
|
/* defconst SYS_TIMER_SETTIME64,__NR_timer_settime64 */
|
|
/* defconst SYS_TIMERFD_GETTIME64,__NR_timerfd_gettime64 */
|
|
/* defconst SYS_TIMERFD_SETTIME64,__NR_timerfd_settime64 */
|
|
/* defconst SYS_UTIMENSAT_TIME64,__NR_utimensat_time64 */
|
|
/* defconst SYS_PSELECT6_TIME64,__NR_pselect6_time64 */
|
|
/* defconst SYS_PPOLL_TIME64,__NR_ppoll_time64 */
|
|
/* defconst SYS_IO_PGETEVENTS_TIME64,__NR_io_pgetevents_time64 */
|
|
/* defconst SYS_RECVMMSG_TIME64,__NR_recvmmsg_time64 */
|
|
/* defconst SYS_MQ_TIMEDSEND_TIME64,__NR_mq_timedsend_time64 */
|
|
/* defconst SYS_MQ_TIMEDRECEIVE_TIME64,__NR_mq_timedreceive_time64 */
|
|
/* defconst SYS_SEMTIMEDOP_TIME64,__NR_semtimedop_time64 */
|
|
/* defconst SYS_RT_SIGTIMEDWAIT_TIME64,__NR_rt_sigtimedwait_time64 */
|
|
/* defconst SYS_FUTEX_TIME64,__NR_futex_time64 */
|
|
/* defconst SYS_SCHED_RR_GET_INTERVAL_TIME64,__NR_sched_rr_get_interval_time64 */
|
|
/* defconst SYS_PIDFD_SEND_SIGNAL,__NR_pidfd_send_signal */
|
|
/* defconst SYS_IO_URING_SETUP,__NR_io_uring_setup */
|
|
/* defconst SYS_IO_URING_ENTER,__NR_io_uring_enter */
|
|
/* defconst SYS_IO_URING_REGISTER,__NR_io_uring_register */
|
|
/* defconst SYS_OPEN_TREE,__NR_open_tree */
|
|
/* defconst SYS_MOVE_MOUNT,__NR_move_mount */
|
|
/* defconst SYS_FSOPEN,__NR_fsopen */
|
|
/* defconst SYS_FSCONFIG,__NR_fsconfig */
|
|
/* defconst SYS_FSMOUNT,__NR_fsmount */
|
|
/* defconst SYS_FSPICK,__NR_fspick */
|
|
/* defconst SYS_PIDFD_OPEN,__NR_pidfd_open */
|
|
/* defconst SYS_CLONE3,__NR_clone3 */
|
|
/* defconst SYS_OPENAT2,__NR_openat2 */
|
|
/* defconst SYS_PIDFD_GETFD,__NR_pidfd_getfd */
|
|
/* defconst SYS_FACCESSAT2,__NR_faccessat2 */
|
|
|
|
/* Special dirfd for *at syscalls to resolve path relative to current directory */
|
|
/* defconst AT_FDCWD,-100 */
|
|
|
|
/*
|
|
** errno values
|
|
*/
|
|
/* defconst ERRNO_EPERM,1 */
|
|
/* defconst ERRNO_ENOENT,2 */
|
|
/* defconst ERRNO_ESRCH,3 */
|
|
defconst ERRNO_EINTR,4
|
|
/* defconst ERRNO_EIO,5 */
|
|
/* defconst ERRNO_ENXIO,6 */
|
|
/* defconst ERRNO_E2BIG,7 */
|
|
/* defconst ERRNO_ENOEXEC,8 */
|
|
/* defconst ERRNO_EBADF,9 */
|
|
/* defconst ERRNO_ECHILD,10 */
|
|
/* defconst ERRNO_EAGAIN,11 */
|
|
/* defconst ERRNO_ENOMEM,12 */
|
|
/* defconst ERRNO_EACCES,13 */
|
|
/* defconst ERRNO_EFAULT,14 */
|
|
/* defconst ERRNO_ENOTBLK,15 */
|
|
/* defconst ERRNO_EBUSY,16 */
|
|
/* defconst ERRNO_EEXIST,17 */
|
|
/* defconst ERRNO_EXDEV,18 */
|
|
/* defconst ERRNO_ENODEV,19 */
|
|
/* defconst ERRNO_ENOTDIR,20 */
|
|
/* defconst ERRNO_EISDIR,21 */
|
|
/* defconst ERRNO_EINVAL,22 */
|
|
/* defconst ERRNO_ENFILE,23 */
|
|
/* defconst ERRNO_EMFILE,24 */
|
|
/* defconst ERRNO_ENOTTY,25 */
|
|
/* defconst ERRNO_ETXTBSY,26 */
|
|
/* defconst ERRNO_EFBIG,27 */
|
|
/* defconst ERRNO_ENOSPC,28 */
|
|
/* defconst ERRNO_ESPIPE,29 */
|
|
/* defconst ERRNO_EROFS,30 */
|
|
/* defconst ERRNO_EMLINK,31 */
|
|
/* defconst ERRNO_EPIPE,32 */
|
|
/* defconst ERRNO_EDOM,33 */
|
|
/* defconst ERRNO_ERANGE,34 */
|
|
|
|
/*
|
|
** signal numbers
|
|
*/
|
|
/* defconst SIGHUP,1 */
|
|
/* defconst SIGINT,2 */
|
|
/* defconst SIGQUIT,3 */
|
|
/* defconst SIGILL,4 */
|
|
/* defconst SIGTRAP,5 */
|
|
defconst SIGABRT,6
|
|
/* defconst SIGIOT,6 */
|
|
/* defconst SIGBUS,7 */
|
|
/* defconst SIGFPE,8 */
|
|
/* defconst SIGKILL,9 */
|
|
/* defconst SIGUSR1,10 */
|
|
/* defconst SIGSEGV,11 */
|
|
/* defconst SIGUSR2,12 */
|
|
/* defconst SIGPIPE,13 */
|
|
/* defconst SIGALRM,14 */
|
|
/* defconst SIGTERM,15 */
|
|
/* defconst SIGSTKFLT,16 */
|
|
/* defconst SIGCHLD,17 */
|
|
/* defconst SIGCONT,18 */
|
|
/* defconst SIGSTOP,19 */
|
|
/* defconst SIGTSTP,20 */
|
|
/* defconst SIGTTIN,21 */
|
|
/* defconst SIGTTOU,22 */
|
|
/* defconst SIGURG,23 */
|
|
/* defconst SIGXCPU,24 */
|
|
/* defconst SIGXFSZ,25 */
|
|
/* defconst SIGVTALRM,26 */
|
|
/* defconst SIGPROF,27 */
|
|
/* defconst SIGWINCH,28 */
|
|
/* defconst SIGIO,29 */
|
|
/* defconst SIGPOLL,29 */
|
|
/* defconst SIGPWR,30 */
|
|
/* defconst SIGSYS,31 */
|
|
|
|
/*
|
|
** openat2() flags
|
|
*/
|
|
/* defconst __O_RDONLY,0,"O_RDONLY" */
|
|
/* defconst __O_WRONLY,1,"O_WRONLY" */
|
|
/* defconst __O_RDWR,2,"O_RDWR" */
|
|
/* defconst __O_CREAT,0100,"O_CREAT" */
|
|
/* defconst __O_EXCL,0200,"O_EXCL" */
|
|
/* defconst __O_TRUNC,01000,"O_TRUNC" */
|
|
/* defconst __O_APPEND,02000,"O_APPEND" */
|
|
/* defconst __O_NONBLOCK,04000,"O_NONBLOCK" */
|
|
|
|
/* NOTE: These are initialized in _start and read-only thereafter. */
|
|
defvalue C0 /* first byte of the heap */
|
|
defvalue S0 /* initial (empty) data stack pointer */
|
|
|
|
/* STATE controls whether we are currently interpreting (0) or compiling (1) */
|
|
defvar STATE,0 /* default to interpreting */
|
|
|
|
/* >IN gives the current offset of the parse area within the input buffer */
|
|
defvar IN,0,">IN"
|
|
|
|
/* NOTE: These are initialized in _start but vary during runtime. */
|
|
defvar CP /* "compilation pointer", next free byte in the heap */
|
|
defvar BRK /* the (current) end of the heap */
|
|
|
|
/* The list of primitive (native code) words provided by this file */
|
|
defvar PRIMITIVE_WORDLIST,last_primitive,"PRIMITIVE-WORDLIST"
|
|
|
|
/* The list of basic non-primitive words used to bootstrap the startup.4th file */
|
|
defvar BOOTSTRAP_WORDLIST,last_word,"BOOTSTRAP-WORDLIST"
|
|
|
|
/* The word list containing all the standard FORTH words */
|
|
/* Initially it just mirrors the primitive list */
|
|
/* The rest will be populated by the startup.4th script */
|
|
defvar FORTH_WORDLIST,last_primitive,"FORTH-WORDLIST"
|
|
|
|
/* The current compilation word list, initially FORTH-WORDLIST */
|
|
defvar CURRENT,data_FORTH_WORDLIST
|
|
|
|
.section .data
|
|
.align 4
|
|
/* This is a linked list; initial_order points to the head of the list */
|
|
0: .int 0,data_BOOTSTRAP_WORDLIST
|
|
initial_order:
|
|
.int 0b,data_FORTH_WORDLIST
|
|
|
|
/* Head of the linked list representing the current search order */
|
|
defvar CURRENT_ORDER,initial_order,"CURRENT-ORDER"
|
|
|
|
/* ( a -- ) */
|
|
defcode DROP
|
|
pop %eax
|
|
NEXT
|
|
|
|
/* ( a b -- b a ) */
|
|
defcode SWAP
|
|
pop %ebx
|
|
pop %eax
|
|
push %ebx
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( a -- a a ) */
|
|
defcode DUP
|
|
pop %eax
|
|
push %eax
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( a b -- a b a ) */
|
|
defcode OVER
|
|
pushl 4(%esp)
|
|
NEXT
|
|
|
|
/* ( a b -- b ) */
|
|
defcode NIP
|
|
pop %ebx
|
|
pop %eax
|
|
push %ebx
|
|
NEXT
|
|
|
|
/* ( a b -- b a b ) */
|
|
defcode TUCK
|
|
pop %ebx
|
|
pop %eax
|
|
push %ebx
|
|
push %eax
|
|
push %ebx
|
|
NEXT
|
|
|
|
/* ( a b c -- b c a ) */
|
|
defcode ROT
|
|
pop %ecx
|
|
pop %ebx
|
|
pop %eax
|
|
push %ebx
|
|
push %ecx
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( a b c -- c a b ) */
|
|
defcode NROT,"-ROT"
|
|
pop %ecx
|
|
pop %ebx
|
|
pop %eax
|
|
push %ecx
|
|
push %eax
|
|
push %ebx
|
|
NEXT
|
|
|
|
/* ( a b -- ) */
|
|
defcode TWODROP,"2DROP"
|
|
pop %ebx
|
|
pop %eax
|
|
NEXT
|
|
|
|
/* ( a b c d -- c d a b ) */
|
|
defcode TWOSWAP,"2SWAP"
|
|
pop %edx
|
|
pop %ecx
|
|
pop %ebx
|
|
pop %eax
|
|
push %ecx
|
|
push %edx
|
|
push %eax
|
|
push %ebx
|
|
NEXT
|
|
|
|
/* ( a b -- a b a b ) */
|
|
defcode TWODUP,"2DUP"
|
|
pop %ebx
|
|
pop %eax
|
|
push %eax
|
|
push %ebx
|
|
push %eax
|
|
push %ebx
|
|
NEXT
|
|
|
|
/* ( a b c d -- a b c d a b ) */
|
|
defcode TWOOVER,"2OVER"
|
|
pushl 12(%esp)
|
|
pushl 12(%esp)
|
|
NEXT
|
|
|
|
/* ( a b c d -- c d ) */
|
|
defcode TWONIP,"2NIP"
|
|
pop %edx
|
|
pop %ecx
|
|
pop %ebx
|
|
pop %eax
|
|
push %ecx
|
|
push %edx
|
|
NEXT
|
|
|
|
/* ( a b c d -- c d a b c d ) */
|
|
defcode TWOTUCK,"2TUCK"
|
|
pop %edx
|
|
pop %ecx
|
|
pop %ebx
|
|
pop %eax
|
|
push %ecx
|
|
push %edx
|
|
push %eax
|
|
push %ebx
|
|
push %ecx
|
|
push %edx
|
|
NEXT
|
|
|
|
/* ( a b c d e f -- c d e f a b ) */
|
|
defcode TWOROT,"2ROT"
|
|
pop %edx
|
|
pop %ecx
|
|
pop %ebx
|
|
pop %eax
|
|
xchg %eax,4(%esp)
|
|
xchg %ebx,(%esp)
|
|
push %ecx
|
|
push %edx
|
|
push %eax
|
|
push %ebx
|
|
NEXT
|
|
|
|
/* ( a b c d e f -- e f a b c d ) */
|
|
defcode NTWOROT,"-2ROT"
|
|
pop %edx
|
|
pop %ecx
|
|
pop %ebx
|
|
pop %eax
|
|
xchg %ecx,4(%esp)
|
|
xchg %edx,(%esp)
|
|
push %ecx
|
|
push %edx
|
|
push %eax
|
|
push %ebx
|
|
NEXT
|
|
|
|
/* ( xn ... x1 n -- ) */
|
|
defcode NDROP
|
|
pop %eax
|
|
lea (%esp,%eax,4),%esp
|
|
NEXT
|
|
|
|
/* ( xu ... x0 u -- xu ... x0 xu ) */
|
|
defcode PICK
|
|
pop %eax
|
|
pushl (%esp,%eax,4)
|
|
NEXT
|
|
|
|
/* ( xu ... x0 u -- xu-1 ... x0 xu ) */
|
|
defcode ROLL
|
|
pop %ecx
|
|
movl (%esp,%ecx,4),%ebx
|
|
mov %esi,%edx
|
|
lea -4(%esp,%ecx,4),%esi
|
|
lea (%esp,%ecx,4),%edi
|
|
std
|
|
rep movsd
|
|
cld
|
|
mov %edx,%esi
|
|
movl %ebx,(%esp)
|
|
NEXT
|
|
|
|
/* ( 0 -- 0 ) */
|
|
/* ( a -- a a ) */
|
|
defcode QDUP,"?DUP"
|
|
movl (%esp),%eax
|
|
test %eax,%eax
|
|
jz 1f
|
|
push %eax
|
|
1: NEXT
|
|
|
|
/* ( 0 -- 0 0 ) */
|
|
/* ( a -- a ) */
|
|
defcode QZDUP,"?0DUP"
|
|
movl (%esp),%eax
|
|
test %eax,%eax
|
|
jnz 1f
|
|
push %eax
|
|
1: NEXT
|
|
|
|
/* ( a b -- a+b ) */
|
|
defcode ADD,"+"
|
|
pop %eax
|
|
addl %eax,(%esp)
|
|
NEXT
|
|
|
|
/* ( a b -- a-b ) */
|
|
defcode SUB,"-"
|
|
pop %eax
|
|
subl %eax,(%esp)
|
|
NEXT
|
|
|
|
/* ( a -- a+1 ) */
|
|
defcode ADD1,"1+"
|
|
incl (%esp)
|
|
NEXT
|
|
|
|
/* ( a -- a-1 ) */
|
|
defcode SUB1,"1-"
|
|
decl (%esp)
|
|
NEXT
|
|
|
|
/* ( x1 -- x2 ) Two's complement of x1 */
|
|
defcode NEGATE
|
|
negl (%esp)
|
|
NEXT
|
|
|
|
/* ( n -- u ) Absolute value */
|
|
defcode ABS
|
|
pop %eax
|
|
test %eax,%eax
|
|
jl 0f
|
|
neg %eax
|
|
0: push %eax
|
|
NEXT
|
|
|
|
/* ( n1 n2 -- n1*n2 ) ( ignores overflow ) */
|
|
defcode MUL,"*"
|
|
pop %eax
|
|
pop %ebx
|
|
imull %ebx,%eax
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( n1 n2 -- d ) Multiply, producting a double-cell result */
|
|
defcode MMUL,"M*"
|
|
pop %eax
|
|
pop %ebx
|
|
imull %ebx,%eax
|
|
push %eax
|
|
push %edx
|
|
NEXT
|
|
|
|
/* ( u1 u2 -- u1*u2 ) ( ignores overflow ) */
|
|
defcode UMUL,"U*"
|
|
pop %eax
|
|
pop %ebx
|
|
mull %ebx
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( u1 u2 -- ud ) Multiply unsigned, producting a double-cell result */
|
|
defcode UMMUL,"UM*"
|
|
pop %eax
|
|
pop %ebx
|
|
mull %ebx
|
|
push %eax
|
|
push %edx
|
|
NEXT
|
|
|
|
/* ( n -- d ) Convert a single-cell signed integer to a double-cell integer */
|
|
defcode STOD,"S>D"
|
|
movl (%esp),%eax
|
|
cltd
|
|
push %edx
|
|
NEXT
|
|
|
|
/* ( d1|ud1 d2|ud2 -- d3|ud3 ) Double-cell addition */
|
|
defcode DADD,"D+"
|
|
pop %ebx
|
|
pop %eax
|
|
addl %eax,4(%esp)
|
|
adcl %ebx,(%esp)
|
|
NEXT
|
|
|
|
/* ( d1|ud1 d2|ud2 -- d3|ud3 ) Double-cell subtraction */
|
|
defcode DSUB,"D-"
|
|
pop %ebx
|
|
pop %eax
|
|
subl %eax,4(%esp)
|
|
sbbl %ebx,(%esp)
|
|
NEXT
|
|
|
|
defcode DNEGATE
|
|
notl 4(%esp)
|
|
notl (%esp)
|
|
addl $1,4(%esp)
|
|
adcl $0,(%esp)
|
|
NEXT
|
|
|
|
/* ( d1 +n1 -- n-remainder d-quotient ) Flooring division with remainder */
|
|
/* NOTE: ANS FORTH has the quotient as a single-cell value (with potential overflow) */
|
|
/* WARNING: This implementation does not handle negative divisors (just dividends) */
|
|
defcode FMDIVMOD,"FM/MOD"
|
|
pop %ebx /* divisor */
|
|
pop %eax /* upper 32 bits of dividend */
|
|
cdq
|
|
idivl %ebx
|
|
test %edx,%edx
|
|
jns 0f
|
|
dec %eax
|
|
add %ebx,%edx
|
|
0: mov %eax,%ecx
|
|
pop %eax /* lower 32 bits of dividend */
|
|
div %ebx
|
|
push %edx /* modulus */
|
|
push %eax /* lower 32 bits of quotient */
|
|
push %ecx /* upper 32 bits of quotient */
|
|
NEXT
|
|
|
|
/* ( ud1 u1 -- u-modulus ud-quotient ) Unsigned division with remainder */
|
|
/* NOTE: ANS FORTH has the quotient as a single-cell value (with potential overflow) */
|
|
defcode UMDIVMOD,"UM/MOD"
|
|
pop %ebx
|
|
pop %edx
|
|
cmp %ebx,%edx
|
|
jae 1f
|
|
xor %ecx,%ecx
|
|
0: pop %eax
|
|
divl %ebx
|
|
push %edx
|
|
push %eax
|
|
push %ecx
|
|
NEXT
|
|
1: mov %edx,%eax
|
|
xor %edx,%edx
|
|
divl %ebx
|
|
mov %eax,%ecx
|
|
jmp 0b
|
|
|
|
/* ( n1 n2 n3 -- (n1*n2)%n3 (n1*n2)/n3 ) */
|
|
/* Equivalent to >R M* R> SM/MOD S>D */
|
|
/* Note: The intermediate value between multiplication and division is 64 bits */
|
|
defcode MULDIVMOD,"*/MOD"
|
|
pop %ecx
|
|
pop %ebx
|
|
pop %eax
|
|
imull %ebx
|
|
idivl %ecx
|
|
push %edx
|
|
push %eax
|
|
NEXT
|
|
|
|
/* Same as MULDIVMOD but for unsigned inputs */
|
|
/* Equivalent to >R UM* R> UM/MOD DROP */
|
|
defcode UMULDIVMOD,"U*/MOD"
|
|
pop %ecx
|
|
pop %ebx
|
|
pop %eax
|
|
mull %ebx
|
|
divl %ecx
|
|
push %edx
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( x1 -- x2 ) Shift left by one bit */
|
|
defcode TWOMUL,"2*"
|
|
shll $1,(%esp)
|
|
NEXT
|
|
|
|
/* ( n1 -- n2 ) Arithmetic (signed) shift right by one bit */
|
|
defcode TWODIV,"2/"
|
|
sarl $1,(%esp)
|
|
NEXT
|
|
|
|
/* ( u1 -- u2 ) Logical (unsigned) shift right by one bit */
|
|
defcode UTWODIV,"U2/"
|
|
shrl $1,(%esp)
|
|
NEXT
|
|
|
|
defcode DTWOMUL,"D2*"
|
|
shll $1,4(%esp)
|
|
rcll $1,(%esp)
|
|
NEXT
|
|
|
|
defcode DTWODIV,"D2/"
|
|
sarl $1,(%esp)
|
|
rcrl $1,4(%esp)
|
|
NEXT
|
|
|
|
defcode DUTWODIV,"DU2/"
|
|
shrl $1,(%esp)
|
|
rcrl $1,4(%esp)
|
|
NEXT
|
|
|
|
/* ( x1 u -- x2 ) Shift left by u bits */
|
|
defcode LSHIFT
|
|
pop %ecx
|
|
shll %cl,(%esp)
|
|
NEXT
|
|
|
|
/* ( u1 u -- u2 ) Logical (unsigned) shift right by u bits */
|
|
defcode RSHIFT
|
|
pop %ecx
|
|
shrl %cl,(%esp)
|
|
NEXT
|
|
|
|
/* ( xd1 u -- xd2 ) Shift left by u bits */
|
|
defcode DLSHIFT
|
|
pop %ecx
|
|
movl 4(%esp),%eax
|
|
shldl %cl,%eax,(%esp)
|
|
shll %cl,4(%esp)
|
|
NEXT
|
|
|
|
/* ( ud1 u -- ud2 ) Logical (unsigned) shift right by u bits */
|
|
defcode DRSHIFT
|
|
pop %ecx
|
|
movl (%esp),%eax
|
|
shrdl %cl,%eax,4(%esp)
|
|
shrl %cl,(%esp)
|
|
NEXT
|
|
|
|
.macro defzcmp label,ncc,name="\label",flags=0
|
|
defcode \label,"\name",0,\flags
|
|
pop %eax
|
|
xor %edi,%edi
|
|
test %eax,%eax
|
|
j\ncc 0f
|
|
dec %edi
|
|
0: push %edi
|
|
NEXT
|
|
.endm
|
|
|
|
/* ( n|u -- flag ) Equality operators with implicit zero, e.g. flag=d==0 */
|
|
defzcmp ZEQU,ne,"0="
|
|
defzcmp ZNEQU,e,"0<>"
|
|
|
|
/* ( n -- flag ) Signed relational operators with implicit zero, e.g. flag=d<0 */
|
|
defzcmp ZLT,nl,"0<"
|
|
defzcmp ZGT,ng,"0>"
|
|
defzcmp ZLE,nle,"0<="
|
|
defzcmp ZGE,nge,"0>="
|
|
|
|
.macro defdzcmp label,ncc,name="\label",flags=0
|
|
defcode \label,"\name",0,\flags
|
|
pop %ebx
|
|
pop %eax
|
|
xor %edi,%edi
|
|
sub $0,%ebx
|
|
sbb $0,%eax
|
|
j\ncc 0f
|
|
dec %edi
|
|
0: push %edi
|
|
NEXT
|
|
.endm
|
|
|
|
/* ( d|ud -- flag ) Double-cell equality operators with implicit zero */
|
|
defdzcmp DZEQU,ne,"D0="
|
|
defdzcmp DZNEQU,e,"D0<>"
|
|
|
|
/* ( d -- flag ) Double-cell signed relational operators with implicit zero */
|
|
defdzcmp DZLT,nl,"D0<"
|
|
defdzcmp DZGT,ng,"D0>"
|
|
defdzcmp DZLE,nle,"D0<="
|
|
defdzcmp DZGE,nge,"D0>="
|
|
|
|
.macro defcmp label,ncc,name="\label",flags=0
|
|
defcode \label,"\name",0,\flags
|
|
pop %eax
|
|
pop %ebx
|
|
xor %edi,%edi
|
|
cmp %eax,%ebx
|
|
j\ncc 0f
|
|
dec %edi
|
|
0: push %edi
|
|
NEXT
|
|
.endm
|
|
|
|
/* ( n1|u1 n2|u2 -- flag ) Equality operators */
|
|
defcmp EQU,ne,"="
|
|
defcmp NEQU,e,"<>"
|
|
|
|
/* ( n1 n2 -- flag ) Signed relational operators */
|
|
defcmp LT,nl,"<"
|
|
defcmp GT,ng,">"
|
|
defcmp LE,nle,"<="
|
|
defcmp GE,nge,">="
|
|
|
|
/* ( u1 u2 -- flag ) Unsigned relational operators */
|
|
defcmp ULT,nb,"U<"
|
|
defcmp UGT,na,"U>"
|
|
defcmp ULE,nbe,"U<="
|
|
defcmp UGE,nae,"U>="
|
|
|
|
.macro defdcmp label,ncc,name="\label",flags=0
|
|
defcode \label,"\name",0,\flags
|
|
pop %edx
|
|
pop %ecx
|
|
pop %ebx
|
|
pop %eax
|
|
xor %edi,%edi
|
|
sub %edx,%ebx
|
|
sbb %ecx,%eax
|
|
j\ncc 0f
|
|
dec %edi
|
|
0: push %edi
|
|
NEXT
|
|
.endm
|
|
|
|
/* ( d1|ud1 d2|ud2 -- flag ) Double-cell equality operators */
|
|
defdcmp DEQU,ne,"D="
|
|
defdcmp DNEQU,e,"D<>"
|
|
|
|
/* ( d1 d2 -- flag ) Double-cell signed relational operators */
|
|
defdcmp DLT,nl,"D<"
|
|
defdcmp DGT,ng,"D>"
|
|
defdcmp DLE,nle,"D<="
|
|
defdcmp DGE,nge,"D>="
|
|
|
|
/* ( ud1 ud2 -- flag ) Double-cell unsigned relational operators */
|
|
defdcmp DULT,nb,"DU<"
|
|
defdcmp DUGT,na,"DU>"
|
|
defdcmp DULE,nbe,"DU<="
|
|
defdcmp DUGE,nae,"DU>="
|
|
|
|
defcode AND
|
|
pop %eax
|
|
andl %eax,(%esp)
|
|
NEXT
|
|
|
|
defcode OR
|
|
pop %eax
|
|
orl %eax,(%esp)
|
|
NEXT
|
|
|
|
defcode XOR
|
|
pop %eax
|
|
xorl %eax,(%esp)
|
|
NEXT
|
|
|
|
defcode INVERT
|
|
notl (%esp)
|
|
NEXT
|
|
|
|
defcode STOREBYTE,"C!"
|
|
pop %ebx
|
|
pop %eax
|
|
movb %al,(%ebx)
|
|
NEXT
|
|
|
|
defcode FETCHBYTE,"C@"
|
|
pop %ebx
|
|
xor %eax,%eax
|
|
movb (%ebx),%al
|
|
push %eax
|
|
NEXT
|
|
|
|
defcode STORE,"!"
|
|
pop %ebx
|
|
popl (%ebx)
|
|
NEXT
|
|
|
|
defcode FETCH,"@"
|
|
pop %ebx
|
|
pushl (%ebx)
|
|
NEXT
|
|
|
|
defcode INCREMENT,"+!"
|
|
pop %ebx
|
|
pop %eax
|
|
addl %eax,(%ebx)
|
|
NEXT
|
|
|
|
defcode DECREMENT,"-!"
|
|
pop %ebx
|
|
pop %eax
|
|
subl %eax,(%ebx)
|
|
NEXT
|
|
|
|
/* ( x1 a-addr -- x2 ) Store x1 in the cell at a-addr and return the old value */
|
|
defcode XCHG
|
|
pop %eax
|
|
mov (%eax),%ebx
|
|
popl (%eax)
|
|
push %ebx
|
|
NEXT
|
|
|
|
defcode TWOSTORE,"2!"
|
|
pop %ebx
|
|
popl (%ebx)
|
|
popl 4(%ebx)
|
|
NEXT
|
|
|
|
defcode TWOFETCH,"2@"
|
|
pop %ebx
|
|
pushl 4(%ebx)
|
|
pushl (%ebx)
|
|
NEXT
|
|
|
|
/* ( xd1 a-addr -- xd2 ) Store xd1 in the double-cell a-addr; return the old value */
|
|
/* Equivalent to: DUP 2@ 2>R 2! 2R> */
|
|
defcode TWOXCHG,"2XCHG"
|
|
pop %eax
|
|
mov 4(%eax),%ebx
|
|
mov (%eax),%ecx
|
|
popl (%eax)
|
|
popl 4(%eax)
|
|
push %ebx
|
|
push %ecx
|
|
NEXT
|
|
|
|
/* ( c-addr u char -- ) Fill u characters starting at c-addr with char */
|
|
defcode FILL
|
|
pop %eax
|
|
pop %ecx
|
|
pop %edi
|
|
rep stosb
|
|
NEXT
|
|
|
|
/* ( src dst n -- ) Block copy n bytes from src to dst (ascending addresses) */
|
|
defcode CMOVE
|
|
mov %esi,%edx
|
|
pop %ecx
|
|
pop %edi
|
|
pop %esi
|
|
rep movsb
|
|
mov %edx,%esi
|
|
NEXT
|
|
|
|
/* ( src dst n -- ) Block copy n bytes from src to dst (descending addresses) */
|
|
defcode CMOVE_UP,"CMOVE>"
|
|
mov %esi,%edx
|
|
pop %ecx
|
|
pop %edi
|
|
pop %esi
|
|
lea -1(%edi,%ecx),%edi
|
|
lea -1(%esi,%ecx),%esi
|
|
std
|
|
rep movsb
|
|
cld
|
|
mov %edx,%esi
|
|
NEXT
|
|
|
|
/* ( a -- ) ( R: -- a ) */
|
|
defcode TOR,">R"
|
|
pop %eax
|
|
PUSHRSP %eax
|
|
NEXT
|
|
|
|
/* ( R: a -- ) ( -- a ) */
|
|
defcode FROMR,"R>"
|
|
POPRSP %eax
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( R: a -- a ) ( -- a ) */
|
|
defcode RFETCH,"R@"
|
|
pushl (%ebp)
|
|
NEXT
|
|
|
|
/* ( R: xu ... x0 -- xu ... x0 ) ( S: u -- xu ) */
|
|
defcode RPICK
|
|
pop %eax
|
|
pushl (%ebp,%eax,4)
|
|
NEXT
|
|
|
|
/* ( a b -- ) ( R: -- a b ) */
|
|
defcode TWOTOR,"2>R"
|
|
pop %ebx
|
|
pop %eax
|
|
PUSHRSP %eax
|
|
PUSHRSP %ebx
|
|
NEXT
|
|
|
|
/* ( R: a b -- ) ( -- a b ) */
|
|
defcode TWOFROMR,"2R>"
|
|
POPRSP %ebx
|
|
POPRSP %eax
|
|
push %eax
|
|
push %ebx
|
|
NEXT
|
|
|
|
/* ( R: a b -- a b ) ( -- a b ) */
|
|
defcode TWORFETCH,"2R@"
|
|
pushl 4(%ebp)
|
|
pushl (%ebp)
|
|
NEXT
|
|
|
|
/* ( xu ... x1 u -- ) ( R: -- xu ... x1 u ) */
|
|
defcode NTOR,"N>R"
|
|
mov %esi,%edx
|
|
movl (%esp),%ecx
|
|
add $1,%ecx
|
|
mov %ecx,%ebx
|
|
shl $2,%ebx
|
|
sub %ebx,%ebp
|
|
mov %esp,%esi
|
|
mov %ebp,%edi
|
|
rep movsd
|
|
mov %esi,%esp
|
|
mov %edx,%esi
|
|
NEXT
|
|
|
|
/* ( R: xu ... x1 u -- ) ( -- xu ... x1 u ) */
|
|
defcode NFROMR,"NR>"
|
|
mov %esi,%edx
|
|
movl (%ebp),%ecx
|
|
add $1,%ecx
|
|
mov %ecx,%ebx
|
|
shl $2,%ebx
|
|
sub %ebx,%esp
|
|
mov %ebp,%esi
|
|
mov %esp,%edi
|
|
rep movsd
|
|
mov %esi,%ebp
|
|
mov %edx,%esi
|
|
NEXT
|
|
|
|
/* ( R: xu ... x1 u -- xu ... x1 u ) ( -- xu ... x1 u ) */
|
|
defcode NRFETCH,"NR@"
|
|
mov %esi,%edx
|
|
movl (%ebp),%ecx
|
|
add $1,%ecx
|
|
mov %ecx,%ebx
|
|
shl $2,%ebx
|
|
sub %ebx,%esp
|
|
mov %ebp,%esi
|
|
mov %esp,%edi
|
|
rep movsd
|
|
mov %edx,%esi
|
|
NEXT
|
|
|
|
/* ( -- a-addr ) */
|
|
defcode RSPFETCH,"RSP@"
|
|
push %ebp
|
|
NEXT
|
|
|
|
/* ( a-addr -- ) */
|
|
defcode RSPSTORE,"RSP!"
|
|
pop %ebp
|
|
NEXT
|
|
|
|
/* ( R: x -- ) */
|
|
defcode RDROP
|
|
addl $4,%ebp
|
|
NEXT
|
|
|
|
/* ( R: a b -- ) */
|
|
defcode TWORDROP,"2RDROP"
|
|
addl $8,%ebp
|
|
NEXT
|
|
|
|
/* ( -- a-addr ) Get the data stack pointer (address of cell below a-addr) */
|
|
defcode SPFETCH,"SP@"
|
|
push %esp
|
|
NEXT
|
|
|
|
/* ( a-addr -- ) Set the data stack pointer */
|
|
defcode SPSTORE,"SP!"
|
|
pop %esp
|
|
NEXT
|
|
|
|
defcode LIT
|
|
lodsl
|
|
push %eax
|
|
NEXT
|
|
|
|
defcode TWOLIT,"2LIT"
|
|
lodsl
|
|
mov %eax,%ebx
|
|
lodsl
|
|
push %eax
|
|
push %ebx
|
|
NEXT
|
|
|
|
defcode LITSTRING
|
|
xor %eax,%eax
|
|
lodsb
|
|
push %esi
|
|
push %eax
|
|
lea 3(%esi,%eax),%esi
|
|
andl $-4,%esi
|
|
NEXT
|
|
|
|
defcode BRANCH
|
|
add (%esi),%esi
|
|
NEXT
|
|
|
|
defcode ZBRANCH,"0BRANCH"
|
|
pop %eax
|
|
test %eax,%eax
|
|
jz code_BRANCH
|
|
lodsl
|
|
NEXT
|
|
|
|
defcode EXIT
|
|
POPRSP %esi
|
|
NEXT
|
|
|
|
defcode EXECUTE
|
|
pop %eax
|
|
jmp *(%eax)
|
|
|
|
/* ( ebx ecx edx esi edi ebp eax/sc -- eax/result ) */
|
|
defcode SYSCALL6
|
|
mov %ebp,%ecx
|
|
mov %esi,%ebx
|
|
pop %eax
|
|
pop %ebp
|
|
pop %edi
|
|
pop %esi
|
|
pop %edx
|
|
xchg %ecx,(%esp)
|
|
xchg %ebx,4(%esp)
|
|
int $0x80
|
|
pop %ebp
|
|
pop %esi
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( ebx ecx edx esi edi eax/sc -- eax/result ) */
|
|
defcode SYSCALL5
|
|
mov %esi,%ebx
|
|
pop %eax
|
|
pop %edi
|
|
pop %esi
|
|
pop %edx
|
|
pop %ecx
|
|
xchg %ebx,(%esp)
|
|
int $0x80
|
|
pop %esi
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( ebx ecx edx esi eax/sc -- eax/result ) */
|
|
defcode SYSCALL4
|
|
mov %esi,%edi
|
|
pop %eax
|
|
pop %esi
|
|
pop %edx
|
|
pop %ecx
|
|
pop %ebx
|
|
int $0x80
|
|
mov %edi,%esi
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( ebx ecx edx eax/sc -- eax/result ) */
|
|
defcode SYSCALL3
|
|
pop %eax
|
|
pop %edx
|
|
pop %ecx
|
|
pop %ebx
|
|
int $0x80
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( ebx ecx eax/sc -- eax/result ) */
|
|
defcode SYSCALL2
|
|
pop %eax
|
|
pop %ecx
|
|
pop %ebx
|
|
int $0x80
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( ebx eax/sc -- eax/result ) */
|
|
defcode SYSCALL1
|
|
pop %eax
|
|
pop %ebx
|
|
int $0x80
|
|
push %eax
|
|
NEXT
|
|
|
|
/* ( eax/sc -- eax/result ) */
|
|
defcode SYSCALL0
|
|
pop %eax
|
|
int $0x80
|
|
push %eax
|
|
NEXT
|
|
|
|
/* No runtime effect, but this code address can be used for debugger breakpoints */
|
|
defcode BREAK
|
|
NEXT
|
|
|
|
/* This marks the start of the bootstrap word list */
|
|
.eqv last_primitive,BREAK
|
|
.set link,0
|
|
|
|
.section .data
|
|
bootstrap_data_begin:
|
|
|
|
/* ( c-addr u -- "ccc" ) */
|
|
defword TYPE
|
|
.int LIT,1,NROT,SYS_WRITE,SYSCALL3,DROP,EXIT
|
|
|
|
/* ( c -- "c" ) */
|
|
defword EMIT
|
|
.int SPFETCH,LIT,1,SWAP,LIT,1,SYS_WRITE,SYSCALL3,TWODROP,EXIT
|
|
|
|
/* ( -- "<eol>" ) */
|
|
defword EOL
|
|
.int LIT,10,EMIT,EXIT
|
|
|
|
/* Used for any fatal errors that occur during bootstrapping */
|
|
defword BAILOUT
|
|
.int BREAK
|
|
litstring "Fatal error\n"
|
|
.int TYPE
|
|
0: .int LIT,254,SYS_EXIT,SYSCALL1,DROP,BRANCH,(0b - .)
|
|
.int EXIT /* just to mark the end */
|
|
|
|
defword UNEXPECTED_EOF,"UNEXPECTED-EOF"
|
|
litstring "Unexpected end of input\n"
|
|
.int TYPE,BAILOUT,EXIT
|
|
|
|
/* During bootstrapping the source buffer is the embedded file "startup.4th". */
|
|
/* ( -- c-addr u ) */
|
|
defword SOURCE
|
|
.int LIT,startup_defs,LIT,(startup_defs_end - startup_defs),EXIT
|
|
|
|
/* ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) */
|
|
defword DROP_PREFIX,"DROP-PREFIX"
|
|
.int ROT,OVER,ADD,NROT,SUB,EXIT
|
|
|
|
/* ( -- c-addr u ) Current parse area (input buffer minus first >IN characters) */
|
|
defword PARSE_AREA,"PARSE-AREA"
|
|
.int SOURCE,IN,FETCH,DROP_PREFIX,EXIT
|
|
|
|
/* ( "c" -- c ) Leaves c at the start of the parse area */
|
|
defword PEEK_CHAR,"PEEK-CHAR"
|
|
.int PARSE_AREA,ZBRANCH,(0f - .),FETCHBYTE,EXIT
|
|
0: .int UNEXPECTED_EOF,EXIT
|
|
|
|
/* ( "c" -- c ) Removes and returns the first character in the parse area */
|
|
defword NEXT_CHAR,"NEXT-CHAR"
|
|
.int PEEK_CHAR,LIT,1,IN,INCREMENT,EXIT
|
|
|
|
/* ( c -- flag ) */
|
|
defword ISSPACE,"SPACE?"
|
|
/* check for space (32) first and return true if input matches */
|
|
.int DUP,LIT,32,EQU,QDUP,ZBRANCH,(0f - .),NIP,EXIT
|
|
/* otherwise test for 9...13 inclusive (HT, LF, VT, FF, CR) */
|
|
0: .int LIT,9,SUB,LIT,(13 - 9),ULT,EXIT
|
|
|
|
/* Simplified version that can only work within the preallocated data region */
|
|
/* The startup.4th should replace this with a more complete version */
|
|
defword ALLOT
|
|
.int CP,INCREMENT,EXIT
|
|
|
|
defword HERE
|
|
.int CP,FETCH,EXIT
|
|
|
|
defword COMMA,","
|
|
.int HERE,CELL,ALLOT,STORE,EXIT
|
|
|
|
defword COMMABYTE,"C,"
|
|
.int HERE,LIT,1,ALLOT,STOREBYTE,EXIT
|
|
|
|
/* ( addr -- a-addr ) Round up to next cell-aligned address */
|
|
defword ALIGNED
|
|
.int LIT,3,ADD,LIT,-4,AND,EXIT
|
|
|
|
/* ( -- ) Allocate data space up to the next cell-aligned address */
|
|
/* Any bytes skipped over during alignment should be considered uninitialized */
|
|
defword ALIGN
|
|
.int HERE,DUP,ALIGNED,SWAP,SUB,ALLOT,EXIT
|
|
|
|
/* ( c-addr-1 u-1 c-addr-2 u-2 -- flag ) */
|
|
defword STREQU,"=S"
|
|
.int ROT,OVER,EQU,ZBRANCH,(1f - .) /* c-addr-1 c-addr-2 u-2 R: */
|
|
0: .int DUP,ZBRANCH,(2f - .) /* c-addr-1 c-addr-2 u R: */
|
|
.int SUB1 /* c-addr-1 c-addr-2 u' R: */
|
|
.int ROT,DUP,FETCHBYTE,TOR,ADD1 /* c-addr-2 u' c-addr-1' R: ch-1 */
|
|
.int ROT,DUP,FETCHBYTE,TOR,ADD1 /* u' c-addr-1' c-addr-2' R: ch-1 ch-2 */
|
|
.int ROT,FROMR,FROMR,NEQU,ZBRANCH,(0b - .) /* c-addr-1' c-addr-2' u' R: */
|
|
1: .int TWODROP,DROP,FALSE,EXIT /* FALSE R: */
|
|
2: .int TWODROP,DROP,TRUE,EXIT /* TRUE R: */
|
|
|
|
/* ( xt -- cfa-addr ) Address of the codeword field */
|
|
defword TCFA,">CFA"
|
|
.int EXIT
|
|
|
|
/* ( xt -- dfa-addr ) Address of the dataword field */
|
|
defword TDFA,">DFA"
|
|
.int CELL,ADD,EXIT
|
|
|
|
/* ( xt -- link-addr ) Address of the dataword field */
|
|
defword TLINK,">LINK"
|
|
.int LIT,8,ADD,EXIT
|
|
|
|
/* ( xt -- flags-addr ) Address of the flag/length byte */
|
|
defword TFLAGS,">FLAGS"
|
|
.int LIT,12,ADD,EXIT
|
|
|
|
/* ( xt -- name-addr name-len ) Address and length of the name field */
|
|
defword TNAME,">NAME"
|
|
.int TFLAGS,DUP,ADD1,SWAP,FETCHBYTE,__F_LENMASK,AND,EXIT
|
|
|
|
/* ( xt -- a-addr ) Data-field address (next cell after the name) */
|
|
defword TBODY,">BODY"
|
|
.int TNAME,ADD,ALIGNED,EXIT
|
|
|
|
/* ( xt -- flag ) Is the F_IMMED flag set? */
|
|
defword ISIMMEDIATE,"IMMEDIATE?"
|
|
.int LIT,12,ADD,FETCHBYTE,__F_IMMED,AND,LIT,0,NEQU,EXIT
|
|
|
|
/* ( xt -- flag ) Is the F_HIDDEN flag set? */
|
|
defword ISHIDDEN,"HIDDEN?"
|
|
.int LIT,12,ADD,FETCHBYTE,__F_HIDDEN,AND,LIT,0,NEQU,EXIT
|
|
|
|
/* ( xt -- flag ) Is the xt a non-primitive bootstrap word? */
|
|
defword ISBOOTSTRAP,"BOOTSTRAP?"
|
|
.int DUP,LIT,bootstrap_data_begin,UGE,ZBRANCH,(0f - .)
|
|
.int LIT,bootstrap_data_end,ULT,EXIT
|
|
0: .int DROP,FALSE,EXIT
|
|
|
|
/* Convert search order entry address to address of word list identifier field */
|
|
defword ORDER_TWID,"ORDER>WID"
|
|
.int CELL,ADD,EXIT
|
|
|
|
/* Convert search order entry address to address of link field */
|
|
defword ORDER_TLINK,"ORDER>LINK"
|
|
.int EXIT
|
|
|
|
/* ( c-addr u wid -- 0 | xt 1 | xt -1 ) */
|
|
/* 0 = not found; 1 = non-immediate; -1 = immediate */
|
|
defword SEARCH_WORDLIST,"SEARCH-WORDLIST"
|
|
.int FETCH /* c-addr u entry */
|
|
0: .int DUP,ZBRANCH,(4f - .) /* c-addr u entry */
|
|
.int DUP,ISHIDDEN,ZBRANCH,(2f - .) /* c-addr u entry */
|
|
1: .int TLINK,FETCH,BRANCH,(0b - .) /* c-addr u link */
|
|
2: .int DUP,TOR,NROT,FROMR,TNAME,TWOOVER /* entry c-addr u n-addr n-len c-addr u */
|
|
.int STREQU,ZBRANCH,(3f - .) /* entry c-addr u */
|
|
.int TWODROP,DUP,ISIMMEDIATE,LIT,1,OR,EXIT /* entry 1 | entry -1 */
|
|
3: .int ROT,BRANCH,(1b - .) /* c-addr u entry */
|
|
4: .int NIP,NIP,EXIT /* entry (= 0) */
|
|
|
|
/* ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) */
|
|
defword FIND
|
|
.int TWOTOR,CURRENT_ORDER
|
|
0: .int FETCH,QDUP,ZBRANCH,(1f - .)
|
|
.int DUP,ORDER_TLINK,SWAP,ORDER_TWID,FETCH
|
|
.int TWORFETCH,ROT,SEARCH_WORDLIST,QDUP,ZBRANCH,(0b - .)
|
|
.int TWORDROP,ROT,DROP,EXIT
|
|
1: .int TWOFROMR,LIT,0,EXIT
|
|
|
|
/* ( c-addr u -- xt 1 | xt -1 ) */
|
|
defword FIND_OR_ABORT,"FIND-OR-ABORT"
|
|
.int FIND,QDUP,ZBRANCH,(0f - .),EXIT
|
|
0: litstring "Word not found: "
|
|
.int TYPE,TYPE,EOL,BAILOUT,EXIT
|
|
|
|
/* ( "<spaces>" -- ) */
|
|
defword SKIPSPACE
|
|
0: .int PARSE_AREA,ZBRANCH,(1f - .)
|
|
.int FETCHBYTE,ISSPACE,ZBRANCH,(2f - .)
|
|
.int LIT,1,IN,INCREMENT,BRANCH,(0b - .)
|
|
1: .int DROP
|
|
2: .int EXIT
|
|
|
|
/* ( "<spaces?>ccc" -- c-addr u ) */
|
|
defword WORD
|
|
.int SKIPSPACE
|
|
.int PARSE_AREA,DROP,LIT,1
|
|
.int NEXT_CHAR,DROP
|
|
0: .int PARSE_AREA,ZBRANCH,(1f - .)
|
|
.int FETCHBYTE,ISSPACE,ZEQU,ZBRANCH,(2f - .)
|
|
.int ADD1,LIT,1,IN,INCREMENT,BRANCH,(0b - .)
|
|
1: .int DROP
|
|
2: .int EXIT
|
|
|
|
defword ESCAPED_CHAR
|
|
.int NEXT_CHAR,DUP,LIT,'\\',NEQU,ZBRANCH,(0f - .),EXIT
|
|
0: .int DROP,NEXT_CHAR
|
|
.int LIT,'0',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,0,EXIT
|
|
0: .int LIT,'a',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,7,EXIT
|
|
0: .int LIT,'b',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,8,EXIT
|
|
0: .int LIT,'t',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,9,EXIT
|
|
0: .int LIT,'n',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,10,EXIT
|
|
0: .int LIT,'v',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,11,EXIT
|
|
0: .int LIT,'f',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,12,EXIT
|
|
0: .int LIT,'r',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,13,EXIT
|
|
0: .int LIT,34,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,34,EXIT /* double-quote */
|
|
0: .int LIT,39,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,39,EXIT /* single-quote */
|
|
0: .int LIT,92,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,92,EXIT /* backslash */
|
|
0: litstring "Unknown escape sequence: \\"
|
|
.int TYPE,EMIT,EOL,BAILOUT,EXIT
|
|
|
|
defword READSTRING
|
|
.int HERE
|
|
0: .int PEEK_CHAR,LIT,34,NEQU,ZBRANCH,(1f - .)
|
|
.int ESCAPED_CHAR,COMMABYTE,BRANCH,(0b - .)
|
|
1: .int LIT,1,IN,INCREMENT,HERE,OVER,SUB,ALIGN,EXIT
|
|
|
|
defword PARSENUMBER
|
|
.int DUP,LIT,0,GT,ZBRANCH,(6f - .)
|
|
.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 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
|
|
8: .int DROP,FROMR,FROMR,ZBRANCH,(9f - .)
|
|
.int NEGATE
|
|
9: .int TRUE,EXIT
|
|
|
|
defword INTERPRET
|
|
.int SKIPSPACE
|
|
.int PEEK_CHAR,LIT,34,EQU,ZBRANCH,(1f - .)
|
|
.int LIT,1,IN,INCREMENT
|
|
.int STATE,FETCH,ZBRANCH,(0f - .)
|
|
.int LIT,LITSTRING,COMMA,HERE,LIT,0,COMMABYTE
|
|
.int READSTRING,ROT,STOREBYTE,DROP,ALIGN,EXIT
|
|
/* ELSE */
|
|
0: .int READSTRING,EXIT
|
|
/* ELSE */
|
|
1: .int WORD,TWODUP,PARSENUMBER,ZBRANCH,(3f - .)
|
|
.int NROT,TWODROP
|
|
.int STATE,FETCH,ZBRANCH,(2f - .)
|
|
.int LIT,LIT,COMMA,COMMA
|
|
2: .int EXIT
|
|
/* ELSE */
|
|
3: .int FIND_OR_ABORT,DROP
|
|
.int STATE,FETCH,ZBRANCH,(4f - .)
|
|
/* ( OR ) */
|
|
.int DUP,ISIMMEDIATE,ZBRANCH,(5f - .)
|
|
4: .int EXECUTE,EXIT
|
|
/* ELSE */
|
|
5: .int DUP,ISBOOTSTRAP,ZBRANCH,(6f - .)
|
|
litstring "Tried to compile bootstrap word: "
|
|
.int TYPE,TNAME,TYPE,EOL,BAILOUT
|
|
6: .int COMMA,EXIT
|
|
|
|
defword QUIT
|
|
.int R0,RSPSTORE
|
|
0: .int INTERPRET,BRANCH,(0b - .)
|
|
.int EXIT
|
|
|
|
defword LATEST
|
|
.int CURRENT,FETCH,FETCH,EXIT
|
|
|
|
/* CREATE depends on bootstrap ALIGN, COMMA, LATEST, WORD, ALLOT, >FLAGS, and >DFA */
|
|
defword CREATE
|
|
.int ALIGN,HERE
|
|
.int LIT,DODATA,COMMA,LIT,0,COMMA,LATEST,COMMA
|
|
.int WORD,DUP,COMMABYTE,HERE,SWAP,DUP,ALLOT,CMOVE
|
|
.int ALIGN,HERE,OVER,TDFA,STORE
|
|
.int CURRENT,FETCH,STORE,EXIT
|
|
|
|
/*
|
|
** These next few words aren't strictly necessary for bootstrapping but
|
|
** do make the early parts of the startup.4th file much more readable.
|
|
*/
|
|
|
|
defword LBRACKET,"[",F_IMMED
|
|
.int FALSE,STATE,STORE,EXIT
|
|
|
|
defword RBRACKET,"]",F_IMMED
|
|
.int TRUE,STATE,STORE,EXIT
|
|
|
|
defword SLASH,"\\",F_IMMED
|
|
0: .int NEXT_CHAR,LIT,10,EQU,ZBRANCH,(0b - .),EXIT
|
|
|
|
defword PAREN,"(",F_IMMED
|
|
0: .int NEXT_CHAR,LIT,')',EQU,ZBRANCH,(0b - .),EXIT
|
|
|
|
defword COLON,":"
|
|
/* Make word & fetch address */
|
|
.int CREATE,LATEST
|
|
/* Set as hidden */
|
|
.int DUP,TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,OR,SWAP,STOREBYTE
|
|
/* Convert to DOCOL codeword */
|
|
.int __DOCOL,SWAP,TCFA,STORE
|
|
/* Enter compilation mode */
|
|
.int TRUE,STATE,STORE,EXIT
|
|
|
|
defword SEMI,";",F_IMMED
|
|
/* Terminate the code with EXIT */
|
|
.int LIT,EXIT,COMMA
|
|
/* Fetch the address of the latest definition */
|
|
.int LATEST
|
|
/* Clear the F_HIDDEN flag */
|
|
.int TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,INVERT,AND,SWAP,STOREBYTE
|
|
/* Leave compilation mode */
|
|
.int FALSE,STATE,STORE,EXIT
|
|
|
|
defword CONSTANT
|
|
.int CREATE,LATEST,TDFA,STORE,EXIT
|
|
|
|
/* ( target-xt deferred-xt -- ) */
|
|
defword DEFERSTORE,"DEFER!"
|
|
.int __DODEFER,OVER,TCFA,STORE,TDFA,STORE,EXIT
|
|
|
|
/* ( deferred-xt -- target-xt ) */
|
|
defword DEFERFETCH,"DEFER@"
|
|
.int TDFA,FETCH,EXIT
|
|
|
|
/* ( "<spaces>ccc" -- ) */
|
|
defword DEFER
|
|
.int CREATE,LIT,BAILOUT,LATEST,DEFERSTORE,EXIT
|
|
|
|
defword QUOTE,"'"
|
|
.int WORD,FIND_OR_ABORT,DROP,EXIT
|
|
|
|
defword LITERAL,,F_IMMED
|
|
.int LIT,LIT,COMMA,COMMA,EXIT
|
|
|
|
defword COMPILE_QUOTE,"[']",F_IMMED
|
|
.int QUOTE,LITERAL,EXIT
|
|
|
|
defword CHAR
|
|
.int WORD,DROP,FETCHBYTE,EXIT
|
|
|
|
defword COMPILE_CHAR,"[CHAR]",F_IMMED
|
|
.int CHAR,LITERAL,EXIT
|
|
|
|
defword POSTPONE,,F_IMMED
|
|
.int WORD,FIND_OR_ABORT,ZGT,ZBRANCH,(0f - .)
|
|
.int LITERAL
|
|
/* this would compile bootstrap COMMA into the definition */
|
|
/* .int LITERAL,LIT,COMMA,COMMA,EXIT */
|
|
/* instead, try to use whichever COMPILE, is currently in scope */
|
|
/* and fail if no COMPILE, is available */
|
|
litstring "COMPILE,"
|
|
.int FIND,ZEQU,ZBRANCH,(0f - .)
|
|
litstring "POSTPONE used on non-immediate word without COMPILE,: "
|
|
.int TYPE,TWODROP,TNAME,TYPE,EOL,BAILOUT
|
|
0: .int DUP,ISBOOTSTRAP,ZBRANCH,(1f - .)
|
|
litstring "POSTPONE used on bootstrap word: "
|
|
.int TYPE,TNAME,TYPE,EOL,BAILOUT
|
|
1: .int COMMA,EXIT
|
|
|
|
defword AHEAD,,F_IMMED
|
|
.int LIT,BRANCH,COMMA,HERE,LIT,0,COMMA,EXIT
|
|
|
|
defword IF,,F_IMMED
|
|
.int LIT,ZBRANCH,COMMA,HERE,LIT,0,COMMA,EXIT
|
|
|
|
defword THEN,,F_IMMED
|
|
.int HERE,OVER,SUB,SWAP,STORE,EXIT
|
|
|
|
defword ELSE,,F_IMMED
|
|
.int AHEAD,SWAP,THEN,EXIT
|
|
|
|
defword BEGIN,,F_IMMED
|
|
.int HERE,EXIT
|
|
|
|
defword AGAIN,,F_IMMED
|
|
.int LIT,BRANCH,COMMA,HERE,SUB,COMMA,EXIT
|
|
|
|
defword UNTIL,,F_IMMED
|
|
.int LIT,ZBRANCH,COMMA,HERE,SUB,COMMA,EXIT
|
|
|
|
defword WHILE,,F_IMMED
|
|
.int IF,SWAP,EXIT
|
|
|
|
defword REPEAT,,F_IMMED
|
|
.int AGAIN,THEN,EXIT
|
|
|
|
.section .data
|
|
bootstrap_data_end:
|
|
|
|
/*
|
|
** End of convenience words
|
|
*/
|
|
|
|
/* This is the initial value of the BUILTIN-WORDLIST variable */
|
|
.eqv last_word,REPEAT
|
|
|
|
.section .rodata
|
|
.align 4
|
|
cold_start:
|
|
.int QUIT
|
|
|
|
.section .startup,"a"
|
|
startup_defs:
|
|
.incbin "startup.4th"
|
|
startup_defs_end:
|
|
|
|
.bss
|
|
.align 4096
|
|
return_stack:
|
|
.space RETURN_STACK_SIZE
|
|
return_stack_top:
|