From 79e05f8565531f8284a33978aaf0d48173236ebd Mon Sep 17 00:00:00 2001 From: Justus Winter <4winter@informatik.uni-hamburg.de> Date: Wed, 14 Jan 2015 02:14:46 +0100 Subject: add patch series --- ...-libports-silence-pointless-error-message.patch | 30 + ...2-startup-give-the-tasks-we-create-a-name.patch | 33 + debian/patches/0003-auth-simplify-expression.patch | 35 + ...-implicit-assumption-about-the-bootstrap-.patch | 61 + ...-proc-call-startup_essential_task-earlier.patch | 183 + ...-libshouldbeinlibc-provide-mach_print-XXX.patch | 80 + debian/patches/0007-libdiskfs-fixes-XXX.patch | 66 + .../0008-trans-add-startup-standalone-XXX.patch | 486 + debian/patches/0009-XXX-bootshell.patch | 10323 +++++++++++++++++++ debian/patches/0010-potfu_bootshell_fixbuild.patch | 75 + .../0011-bootshell-improve-error-message.patch | 27 + debian/patches/series | 11 + 12 files changed, 11410 insertions(+) create mode 100644 debian/patches/0001-libports-silence-pointless-error-message.patch create mode 100644 debian/patches/0002-startup-give-the-tasks-we-create-a-name.patch create mode 100644 debian/patches/0003-auth-simplify-expression.patch create mode 100644 debian/patches/0004-auth-remove-implicit-assumption-about-the-bootstrap-.patch create mode 100644 debian/patches/0005-proc-call-startup_essential_task-earlier.patch create mode 100644 debian/patches/0006-libshouldbeinlibc-provide-mach_print-XXX.patch create mode 100644 debian/patches/0007-libdiskfs-fixes-XXX.patch create mode 100644 debian/patches/0008-trans-add-startup-standalone-XXX.patch create mode 100644 debian/patches/0009-XXX-bootshell.patch create mode 100644 debian/patches/0010-potfu_bootshell_fixbuild.patch create mode 100644 debian/patches/0011-bootshell-improve-error-message.patch diff --git a/debian/patches/0001-libports-silence-pointless-error-message.patch b/debian/patches/0001-libports-silence-pointless-error-message.patch new file mode 100644 index 00000000..8e0fa7c8 --- /dev/null +++ b/debian/patches/0001-libports-silence-pointless-error-message.patch @@ -0,0 +1,30 @@ +From ba9d293d8fe40f6e634cf800c42ece97727ccd0f Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Sat, 3 Jan 2015 16:21:24 +0100 +Subject: [PATCH hurd 01/11] libports: silence pointless error message + +* libports/manage-multithread.c (adjust_priority): Silence pointless +error message. +--- + libports/manage-multithread.c | 5 +++++ + 1 file changed, 5 insertions(+) + +diff --git a/libports/manage-multithread.c b/libports/manage-multithread.c +index 2067cba..ad22991 100644 +--- a/libports/manage-multithread.c ++++ b/libports/manage-multithread.c +@@ -50,6 +50,11 @@ adjust_priority (unsigned int totalthreads) + thread_switch (MACH_PORT_NULL, SWITCH_OPTION_DEPRESS, t); + + err = get_privileged_ports (&host_priv, NULL); ++ if (err == MACH_SEND_INVALID_DEST) ++ /* This is returned if we neither have the privileged host control ++ port cached nor have a proc server to talk to. Give up. */ ++ return; ++ + if (err) + goto error_host_priv; + +-- +2.1.4 + diff --git a/debian/patches/0002-startup-give-the-tasks-we-create-a-name.patch b/debian/patches/0002-startup-give-the-tasks-we-create-a-name.patch new file mode 100644 index 00000000..6fa71755 --- /dev/null +++ b/debian/patches/0002-startup-give-the-tasks-we-create-a-name.patch @@ -0,0 +1,33 @@ +From 522370cfcd2dde29dac73e1479d64a6af614cc25 Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Fri, 9 Jan 2015 11:06:52 +0100 +Subject: [PATCH hurd 02/11] startup: give the tasks we create a name + +* startup/startup.c (run): Name the tasks we start. +--- + startup/startup.c | 2 ++ + 1 file changed, 2 insertions(+) + +diff --git a/startup/startup.c b/startup/startup.c +index 601c894..c9fe215 100644 +--- a/startup/startup.c ++++ b/startup/startup.c +@@ -33,6 +33,7 @@ + #include + #include + #include ++#include + #include + #include + #include +@@ -376,6 +377,7 @@ run (const char *server, mach_port_t *ports, task_t *task) + printf ("Pausing for %s\n", prog); + getchar (); + } ++ task_set_name (*task, (char *) prog); + err = file_exec (file, *task, 0, + (char *)prog, strlen (prog) + 1, /* Args. */ + startup_envz, startup_envz_len, +-- +2.1.4 + diff --git a/debian/patches/0003-auth-simplify-expression.patch b/debian/patches/0003-auth-simplify-expression.patch new file mode 100644 index 00000000..91ce3272 --- /dev/null +++ b/debian/patches/0003-auth-simplify-expression.patch @@ -0,0 +1,35 @@ +From f37373b80de3bf74ca8792d5d64498366b088fab Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Fri, 2 Jan 2015 21:53:08 +0100 +Subject: [PATCH hurd 03/11] auth: simplify expression + +* auth/auth.c (S_auth_{user,server}_authenticate): Simplify expression. +--- + auth/auth.c | 4 ++-- + 1 file changed, 2 insertions(+), 2 deletions(-) + +diff --git a/auth/auth.c b/auth/auth.c +index c36bcb2..a7a188a 100644 +--- a/auth/auth.c ++++ b/auth/auth.c +@@ -299,7 +299,7 @@ S_auth_user_authenticate (struct authhandle *userauth, + if (! userauth) + return EOPNOTSUPP; + +- if (rendezvous == MACH_PORT_NULL || rendezvous == MACH_PORT_DEAD) ++ if (! MACH_PORT_VALID (rendezvous)) + return EINVAL; + + u.user = userauth; +@@ -380,7 +380,7 @@ S_auth_server_authenticate (struct authhandle *serverauth, + if (! serverauth) + return EOPNOTSUPP; + +- if (rendezvous == MACH_PORT_NULL || rendezvous == MACH_PORT_DEAD) ++ if (! MACH_PORT_VALID (rendezvous)) + return EINVAL; + + pthread_mutex_lock (&pending_lock); +-- +2.1.4 + diff --git a/debian/patches/0004-auth-remove-implicit-assumption-about-the-bootstrap-.patch b/debian/patches/0004-auth-remove-implicit-assumption-about-the-bootstrap-.patch new file mode 100644 index 00000000..02c2c804 --- /dev/null +++ b/debian/patches/0004-auth-remove-implicit-assumption-about-the-bootstrap-.patch @@ -0,0 +1,61 @@ +From 267fb2b2fcffe5ed09c18ee879193ad698223d65 Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Wed, 7 Jan 2015 16:00:06 +0100 +Subject: [PATCH hurd 04/11] auth: remove implicit assumption about the + bootstrap process + +The current code assumes that it can speak the startup protocol over +its bootstrap port. + +* auth/auth.c (main): Generalize by trying to use `/servers/startup' +before falling back to the bootstrap port. +--- + auth/auth.c | 15 ++++++++++++++- + 1 file changed, 14 insertions(+), 1 deletion(-) + +diff --git a/auth/auth.c b/auth/auth.c +index a7a188a..d5ef587 100644 +--- a/auth/auth.c ++++ b/auth/auth.c +@@ -25,6 +25,7 @@ + #include + #include + #include ++#include + #include + #include + #include +@@ -482,6 +483,7 @@ main (int argc, char **argv) + { + error_t err; + mach_port_t boot; ++ mach_port_t startup; + process_t proc; + mach_port_t hostpriv, masterdev; + struct authhandle *firstauth; +@@ -518,10 +520,21 @@ main (int argc, char **argv) + _hurd_port_set (&_hurd_ports[INIT_PORT_PROC], proc); + _hurd_proc_init (argv, NULL, 0); + ++ startup = file_name_lookup (_SERVERS_STARTUP, 0, 0); ++ if (! MACH_PORT_VALID (startup)) ++ { ++ error (0, errno, "%s", _SERVERS_STARTUP); ++ /* Fall back to using the bootstrap port as before. */ ++ startup = boot; ++ } ++ + /* Init knows intimately that we will be ready for messages + as soon as this returns. */ +- startup_essential_task (boot, mach_task_self (), MACH_PORT_NULL, "auth", ++ startup_essential_task (startup, mach_task_self (), MACH_PORT_NULL, "auth", + hostpriv); ++ ++ if (startup != boot) ++ mach_port_deallocate (mach_task_self (), startup); + mach_port_deallocate (mach_task_self (), boot); + mach_port_deallocate (mach_task_self (), hostpriv); + +-- +2.1.4 + diff --git a/debian/patches/0005-proc-call-startup_essential_task-earlier.patch b/debian/patches/0005-proc-call-startup_essential_task-earlier.patch new file mode 100644 index 00000000..cd7f469d --- /dev/null +++ b/debian/patches/0005-proc-call-startup_essential_task-earlier.patch @@ -0,0 +1,183 @@ +From 04f4b23c72c04136b2003dd121009de754fc7fa8 Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Wed, 7 Jan 2015 16:05:48 +0100 +Subject: [PATCH hurd 05/11] proc: call `startup_essential_task' earlier + +Previously, the proc server did not call `startup_essential_task' +until it got the message port of the startup server using +`proc_setmsgport'. + +Now that we have `/servers/startup', we can do this in main, before we +start our message service loop. + +A complication arises because the traditional startup server is +single-threaded. Handle this by tweaking startup not to bind itself +to `/servers/startup' before it is ready. + +* proc/main.c (main): Try to lookup `/servers/startup' and send the +message here, or... +* proc/msg.c (S_proc_setmsgport): ... fall back to the old way here. +* proc/proc.h (startup_fallback): New variable. +* startup/startup.c (main): Move code installing ourself on `/servers/startup' +(install_as_translator): ... here. +(launch_core_servers): And use it here, just before we reply to `/hurd/auth'. +--- + proc/main.c | 23 +++++++++++++++++++++++ + proc/msg.c | 2 +- + proc/proc.h | 2 ++ + startup/startup.c | 44 ++++++++++++++++++++++++++++++++------------ + 4 files changed, 58 insertions(+), 13 deletions(-) + +diff --git a/proc/main.c b/proc/main.c +index b4288fb..6df4141 100644 +--- a/proc/main.c ++++ b/proc/main.c +@@ -22,6 +22,7 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ + #include + #include + #include ++#include + #include + #include + #include +@@ -62,6 +63,7 @@ message_demuxer (mach_msg_header_t *inp, + } + + pthread_mutex_t global_lock = PTHREAD_MUTEX_INITIALIZER; ++int startup_fallback; + + error_t + increase_priority (void) +@@ -99,6 +101,7 @@ main (int argc, char **argv, char **envp) + error_t err; + void *genport; + process_t startup_port; ++ mach_port_t startup; + struct argp argp = { 0, 0, 0, "Hurd process server" }; + + argp_parse (&argp, argc, argv, 0, 0, 0); +@@ -173,6 +176,26 @@ main (int argc, char **argv, char **envp) + mach_port_deallocate (mach_task_self (), cons); + } + ++ startup = file_name_lookup (_SERVERS_STARTUP, 0, 0); ++ if (MACH_PORT_VALID (startup)) ++ { ++ err = startup_essential_task (startup, mach_task_self (), ++ MACH_PORT_NULL, "proc", _hurd_host_priv); ++ if (err) ++ /* Due to the single-threaded nature of /hurd/startup, it can ++ only handle requests once the core server bootstrap has ++ completed. Therefore, it does not bind itself to ++ /servers/startup until it is ready. */ ++ /* Fall back to abusing the message port lookup. */ ++ startup_fallback = 1; ++ ++ err = mach_port_deallocate (mach_task_self (), startup); ++ assert_perror (err); ++ } ++ else ++ /* Fall back to abusing the message port lookup. */ ++ startup_fallback = 1; ++ + while (1) + ports_manage_port_operations_multithread (proc_bucket, + message_demuxer, +diff --git a/proc/msg.c b/proc/msg.c +index 796cae3..c7bab99 100644 +--- a/proc/msg.c ++++ b/proc/msg.c +@@ -63,7 +63,7 @@ S_proc_setmsgport (struct proc *p, + prociterate (check_message_return, p); + p->p_checkmsghangs = 0; + +- if (p == startup_proc) ++ if (p == startup_proc && startup_fallback) + { + /* Init is single threaded, so we can't delay our reply for + the essential task RPC; spawn a thread to do it. */ +diff --git a/proc/proc.h b/proc/proc.h +index a056d18..4be1de4 100644 +--- a/proc/proc.h ++++ b/proc/proc.h +@@ -151,6 +151,8 @@ mach_port_t generic_port; /* messages not related to a specific proc */ + + pthread_mutex_t global_lock; + ++extern int startup_fallback; /* (ab)use /hurd/startup's message port */ ++ + /* Forward declarations */ + void complete_wait (struct proc *, int); + int check_uid (struct proc *, uid_t); +diff --git a/startup/startup.c b/startup/startup.c +index c9fe215..e01d2a8 100644 +--- a/startup/startup.c ++++ b/startup/startup.c +@@ -514,6 +514,32 @@ demuxer (mach_msg_header_t *inp, + startup_server (inp, outp)); + } + ++error_t ++install_as_translator (void) ++{ ++ error_t err; ++ file_t node; ++ ++ node = file_name_lookup (_SERVERS_STARTUP, O_NOTRANS, 0); ++ if (! MACH_PORT_VALID (node)) ++ { ++ if (errno == ENOENT) ++ { ++ /* Degrade gracefully if the node does not exist. */ ++ error (0, errno, "%s", _SERVERS_STARTUP); ++ return 0; ++ } ++ return errno; ++ } ++ ++ err = file_set_translator (node, ++ 0, FS_TRANS_SET, 0, ++ NULL, 0, ++ startup, MACH_MSG_TYPE_COPY_SEND); ++ mach_port_deallocate (mach_task_self (), node); ++ return err; ++} ++ + static int + parse_opt (int key, char *arg, struct argp_state *state) + { +@@ -587,18 +613,6 @@ main (int argc, char **argv, char **envp) + /* Crash if the boot filesystem task dies. */ + request_dead_name (fstask); + +- file_t node = file_name_lookup (_SERVERS_STARTUP, O_NOTRANS, 0); +- if (node == MACH_PORT_NULL) +- error (0, errno, "%s", _SERVERS_STARTUP); +- else +- { +- file_set_translator (node, +- 0, FS_TRANS_SET, 0, +- NULL, 0, +- startup, MACH_MSG_TYPE_COPY_SEND); +- mach_port_deallocate (mach_task_self (), node); +- } +- + /* Set up the set of ports we will pass to the programs we exec. */ + for (i = 0; i < INIT_PORT_MAX; i++) + switch (i) +@@ -672,6 +686,12 @@ launch_core_servers (void) + proc_task2proc (procserver, authtask, &authproc); + proc_mark_important (authproc); + proc_mark_exec (authproc); ++ ++ err = install_as_translator (); ++ if (err) ++ /* Good luck. Who knows, maybe it's an old installation. */ ++ error (0, err, "Failed to bind to " _SERVERS_STARTUP); ++ + startup_authinit_reply (authreply, authreplytype, 0, authproc, + MACH_MSG_TYPE_COPY_SEND); + mach_port_deallocate (mach_task_self (), authproc); +-- +2.1.4 + diff --git a/debian/patches/0006-libshouldbeinlibc-provide-mach_print-XXX.patch b/debian/patches/0006-libshouldbeinlibc-provide-mach_print-XXX.patch new file mode 100644 index 00000000..fdf3969a --- /dev/null +++ b/debian/patches/0006-libshouldbeinlibc-provide-mach_print-XXX.patch @@ -0,0 +1,80 @@ +From 383f73297a9b1658c4c1fb2112a1d47e3e8e3c14 Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Tue, 13 Jan 2015 17:18:17 +0100 +Subject: [PATCH hurd 06/11] libshouldbeinlibc: provide `mach_print' XXX + +* libshouldbeinlibc/mach-print.c: New file. +* libshouldbeinlibc/mach-print.h: Likewise. +* libshouldbeinlibc/Makefile: Add `mach-print.{c,h}'. +--- + libshouldbeinlibc/Makefile | 2 ++ + libshouldbeinlibc/mach-print.c | 30 ++++++++++++++++++++++++++++++ + libshouldbeinlibc/mach-print.h | 2 ++ + 3 files changed, 34 insertions(+) + create mode 100644 libshouldbeinlibc/mach-print.c + create mode 100644 libshouldbeinlibc/mach-print.h + +diff --git a/libshouldbeinlibc/Makefile b/libshouldbeinlibc/Makefile +index 633d60e..7a17d0e 100644 +--- a/libshouldbeinlibc/Makefile ++++ b/libshouldbeinlibc/Makefile +@@ -29,10 +29,12 @@ SRCS = termsize.c timefmt.c exec-reauth.c maptime-funcs.c \ + ugids-auth.c ugids-xinl.c ugids-merge.c ugids-imply.c ugids-posix.c \ + ugids-verify-auth.c nullauth.c \ + refcount.c \ ++ mach-print.c \ + + installhdrs = idvec.h timefmt.h maptime.h \ + wire.h portinfo.h portxlate.h cacheq.h ugids.h nullauth.h \ + refcount.h \ ++ mach-print.h \ + + installhdrsubdir = . + +diff --git a/libshouldbeinlibc/mach-print.c b/libshouldbeinlibc/mach-print.c +new file mode 100644 +index 0000000..2b31dca +--- /dev/null ++++ b/libshouldbeinlibc/mach-print.c +@@ -0,0 +1,30 @@ ++#include ++#include ++ ++#define BUFFER_SIZE 1024 ++ ++void ++mach_print(const char *msg) ++{ ++ // XXX check architecture ++ asm (" pop %%eax;" ++ " push %0;" ++ " push %%eax;" ++ " mov $0xffffffe2, %%eax;" ++ " lcall $0x7, $0x0;" ++ : /* No outputs. */ ++ : "r" (msg) ++ : "eax"); ++} ++ ++void ++mach_printf (const char *format, ...) ++{ ++ va_list ap; ++ char buf[BUFFER_SIZE]; ++ ++ va_start(ap, format); ++ vsnprintf(buf, sizeof(buf), format, ap); ++ mach_print(buf); ++ va_end(ap); ++} +diff --git a/libshouldbeinlibc/mach-print.h b/libshouldbeinlibc/mach-print.h +new file mode 100644 +index 0000000..a733939 +--- /dev/null ++++ b/libshouldbeinlibc/mach-print.h +@@ -0,0 +1,2 @@ ++void mach_print(const char *); ++void mach_printf(const char *format, ...); // XXX attribute printf +-- +2.1.4 + diff --git a/debian/patches/0007-libdiskfs-fixes-XXX.patch b/debian/patches/0007-libdiskfs-fixes-XXX.patch new file mode 100644 index 00000000..5b377a56 --- /dev/null +++ b/debian/patches/0007-libdiskfs-fixes-XXX.patch @@ -0,0 +1,66 @@ +From cdda9ead492454f3810f5473b7eefd8eab6e29ad Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Tue, 13 Jan 2015 18:59:29 +0100 +Subject: [PATCH hurd 07/11] libdiskfs: fixes XXX + +--- + libdiskfs/boot-start.c | 3 ++- + libdiskfs/init-init.c | 10 +++++----- + libdiskfs/init-startup.c | 3 ++- + 3 files changed, 9 insertions(+), 7 deletions(-) + +diff --git a/libdiskfs/boot-start.c b/libdiskfs/boot-start.c +index cfe2303..5233cae 100644 +--- a/libdiskfs/boot-start.c ++++ b/libdiskfs/boot-start.c +@@ -464,7 +464,8 @@ diskfs_S_fsys_init (struct diskfs_control *pt, + struct peropen *rootpo; + + if (!pt +- || pt->pi.class != diskfs_initboot_class) ++ || (pt->pi.class != diskfs_initboot_class ++ && pt->pi.class != diskfs_control_class)) // XXX + return EOPNOTSUPP; + + if (initdone) +diff --git a/libdiskfs/init-init.c b/libdiskfs/init-init.c +index 7a7f248..bc25bbe 100644 +--- a/libdiskfs/init-init.c ++++ b/libdiskfs/init-init.c +@@ -71,14 +71,14 @@ diskfs_init_diskfs (void) + diskfs_default_pager = MACH_PORT_NULL; + err = vm_set_default_memory_manager (host, &diskfs_default_pager); + mach_port_deallocate (mach_task_self (), host); +- +- if (!err) +- err = maptime_map (1, 0, &diskfs_mtime); + } ++ if (err) ++ return err; + } +- else +- err = maptime_map (0, 0, &diskfs_mtime); + ++ err = maptime_map (0, 0, &diskfs_mtime); ++ if (err) ++ err = maptime_map (1, 0, &diskfs_mtime); + if (err) + return err; + +diff --git a/libdiskfs/init-startup.c b/libdiskfs/init-startup.c +index 3a588e1..a3a0d2d 100644 +--- a/libdiskfs/init-startup.c ++++ b/libdiskfs/init-startup.c +@@ -106,7 +106,8 @@ diskfs_startup_diskfs (mach_port_t bootstrap, int flags) + mach_port_deallocate (mach_task_self (), bootstrap); + _diskfs_ncontrol_ports++; + +- _diskfs_init_completed (); ++ if (MACH_PORT_VALID (getproc ())) //XXX ++ _diskfs_init_completed (); + } + else + { +-- +2.1.4 + diff --git a/debian/patches/0008-trans-add-startup-standalone-XXX.patch b/debian/patches/0008-trans-add-startup-standalone-XXX.patch new file mode 100644 index 00000000..b4259768 --- /dev/null +++ b/debian/patches/0008-trans-add-startup-standalone-XXX.patch @@ -0,0 +1,486 @@ +From 6686c9fef8c7298e4bf33bb75705ca690add7b37 Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Tue, 13 Jan 2015 19:01:50 +0100 +Subject: [PATCH hurd 08/11] trans: add `startup-standalone' XXX + +Provide a stripped-down version of the startup translator that +supervises core servers and handles system shutdown. + +* trans/startup-standalone.c: New file. +* trans/Makefile: Add `startup-standalone'. +--- + trans/Makefile | 9 +- + trans/startup-standalone.c | 428 +++++++++++++++++++++++++++++++++++++++++++++ + 2 files changed, 433 insertions(+), 4 deletions(-) + create mode 100644 trans/startup-standalone.c + +diff --git a/trans/Makefile b/trans/Makefile +index ce1eae7..5153361 100644 +--- a/trans/Makefile ++++ b/trans/Makefile +@@ -21,14 +21,14 @@ makemode := servers + + targets = symlink firmlink ifsock magic null fifo new-fifo fwd crash \ + password hello hello-mt streamio fakeroot proxy-defpager remap \ +- mtab ++ mtab startup-standalone + SRCS = ifsock.c symlink.c magic.c null.c fifo.c new-fifo.c fwd.c \ + crash.c firmlink.c password.c hello.c hello-mt.c streamio.c \ +- fakeroot.c proxy-defpager.c remap.c mtab.c ++ fakeroot.c proxy-defpager.c remap.c mtab.c startup-standalone.c + OBJS = $(SRCS:.c=.o) fsysServer.o ifsockServer.o passwordServer.o \ + crashServer.o crash_replyUser.o msgServer.o \ + default_pagerServer.o default_pagerUser.o \ +- device_replyServer.o elfcore.o ++ device_replyServer.o elfcore.o startupServer.o + HURDLIBS = ports netfs trivfs iohelp fshelp pipe ihash shouldbeinlibc + LDLIBS += -lpthread + password-LDLIBS = -lcrypt +@@ -61,8 +61,9 @@ crash: crashServer.o crash_replyUser.o msgServer.o elfcore.o + password: passwordServer.o + streamio: device_replyServer.o + proxy-defpager: default_pagerServer.o default_pagerUser.o ++startup-standalone: startupServer.o startup_notifyUser.o + +-proxy-defpager crash password streamio: ../libports/libports.a ../libtrivfs/libtrivfs.a ../libfshelp/libfshelp.a ++proxy-defpager crash password streamio startup-standalone: ../libports/libports.a ../libtrivfs/libtrivfs.a ../libfshelp/libfshelp.a + fifo new-fifo: ../libpipe/libpipe.a + fwd: ../libfshelp/libfshelp.a ../libports/libports.a + hello-mt magic null ifsock fifo new-fifo firmlink: ../libtrivfs/libtrivfs.a ../libfshelp/libfshelp.a ../libports/libports.a ../libihash/libihash.a +diff --git a/trans/startup-standalone.c b/trans/startup-standalone.c +new file mode 100644 +index 0000000..dcb2cb4 +--- /dev/null ++++ b/trans/startup-standalone.c +@@ -0,0 +1,428 @@ ++/* Start and maintain hurd core servers and system run state ++ ++ Copyright (C) 1993-2015 Free Software Foundation, Inc. ++ This file is part of the GNU Hurd. ++ ++ The GNU Hurd is free software; you can redistribute it and/or modify ++ it under the terms of the GNU General Public License as published by ++ the Free Software Foundation; either version 2, or (at your option) ++ any later version. ++ ++ The GNU Hurd is distributed in the hope that it will be useful, ++ but WITHOUT ANY WARRANTY; without even the implied warranty of ++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ GNU General Public License for more details. ++ ++ You should have received a copy of the GNU General Public License ++ along with the GNU Hurd; see the file COPYING. If not, write to ++ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ ++ ++/* Written by Michael I. Bushnell and Roland McGrath. */ ++ ++/* This is probably more include files than I've ever seen before for ++ one file. */ ++ ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++ ++#include "startup_notify_U.h" ++#include "startup_reply_U.h" ++#include "startup_S.h" ++#include "notify_S.h" ++ ++/* The privileged host control port. Used for authentication. */ ++mach_port_t host_priv; ++ ++/* We receive dead-name notifications here. */ ++struct port_info *notification; ++ ++/* host_reboot flags for when we crash. */ ++static int crash_flags = RB_AUTOBOOT; ++ ++#define BOOT(flags) ((flags & RB_HALT) ? "halt" : "reboot") ++ ++const char *argp_program_version = STANDARD_HURD_VERSION (startup-standalone); ++ ++/* Trivfs hooks. */ ++int trivfs_fstype = FSTYPE_MISC; ++int trivfs_fsid = 0; ++ ++int trivfs_allow_open = 0; ++int trivfs_support_read = 0; ++int trivfs_support_write = 0; ++int trivfs_support_exec = 0; ++ ++void ++trivfs_modify_stat (struct trivfs_protid *cred, struct stat *st) ++{ ++ /* Mark the node as a read-only plain file. */ ++ st->st_mode &= ~(S_IFMT | ALLPERMS); ++ st->st_mode |= (S_IFREG | S_IRUSR | S_IRGRP | S_IROTH); ++ st->st_size = 0; ++} ++ ++error_t ++trivfs_goaway (struct trivfs_control *cntl, int flags) ++{ ++ exit (0); ++} ++ ++/* Options processing. We accept the same options on the command line ++ and from fsys_set_options. */ ++ ++static const struct argp_option options[] = ++{ ++ {0} ++}; ++ ++static error_t ++parse_opt (int opt, char *arg, struct argp_state *state) ++{ ++ switch (opt) ++ { ++ default: ++ return ARGP_ERR_UNKNOWN; ++ case ARGP_KEY_INIT: ++ case ARGP_KEY_SUCCESS: ++ case ARGP_KEY_ERROR: ++ break; ++ } ++ return 0; ++} ++ ++/* This will be called from libtrivfs to help construct the answer ++ to an fsys_get_options RPC. */ ++error_t ++trivfs_append_args (struct trivfs_control *fsys, ++ char **argz, size_t *argz_len) ++{ ++ return 0; ++} ++ ++static const char doc[] = ++ "Supervise Hurd core servers and manage system shutdown"; ++ ++static struct argp hello_argp = ++{ options, parse_opt, 0, doc }; ++ ++/* Setting this variable makes libtrivfs use our argp to ++ parse options passed in an fsys_set_options RPC. */ ++struct argp *trivfs_runtime_argp = &hello_argp; ++ ++static int ++demuxer (mach_msg_header_t *inp, ++ mach_msg_header_t *outp) ++{ ++ // XXX nicer demuxer ++ extern int startup_server (mach_msg_header_t *, mach_msg_header_t *); ++ ++ return startup_server (inp, outp) || trivfs_demuxer (inp, outp); ++} ++ ++int ++main (int argc, char **argv) ++{ ++ error_t err; ++ mach_port_t bootstrap; ++ struct trivfs_control *fsys; ++ struct port_class *notification_class; ++ ++ // XXX ++ fprintf (stdout, "stdout\n"); ++ fflush (stdout); ++ fprintf (stderr, "stderr\n"); ++ ++ /* We use the same argp for options available at startup ++ as for options we'll accept in an fsys_set_options RPC. */ ++ argp_parse (&hello_argp, argc, argv, 0, 0, 0); ++ ++ err = get_privileged_ports (&host_priv, NULL); ++ if (err) ++ error (1, err, "Must be started as root"); ++ ++ task_get_bootstrap_port (mach_task_self (), &bootstrap); ++ if (bootstrap == MACH_PORT_NULL) ++ error (1, 0, "Must be started as a translator"); ++ ++ /* Reply to our parent */ ++ err = trivfs_startup (bootstrap, 0, 0, 0, 0, 0, &fsys); ++ if (err) ++ error (3, err, "trivfs_startup"); ++ ++ err = mach_port_deallocate (mach_task_self (), bootstrap); ++ assert_perror (err); ++ ++ notification_class = ports_create_class (NULL, NULL); ++ if (! notification_class) ++ error (1, errno, "ports_create_class"); ++ ++ err = ports_create_port (notification_class, fsys->pi.bucket, 0, ++ ¬ification); ++ if (err) ++ error (1, err, "ports_create_port"); ++ ++ /* Launch. */ ++ ports_manage_port_operations_one_thread (fsys->pi.bucket, demuxer, 0); ++ ++ return 0; ++} ++ ++/* This structure keeps track of each notified task. */ ++struct ntfy_task ++ { ++ mach_port_t notify_port; ++ struct ntfy_task *next; ++ char *name; ++ }; ++ ++/* This structure keeps track of each registered essential task. */ ++struct ess_task ++ { ++ struct ess_task *next; ++ task_t task_port; ++ char *name; ++ }; ++ ++/* These are linked lists of all of the registered items. */ ++static struct ess_task *ess_tasks; ++static struct ntfy_task *ntfy_tasks; ++ ++/** System shutdown **/ ++ ++/* Reboot the microkernel. */ ++void ++reboot_mach (int flags) ++{ ++ error_t err; ++ printf ("%s: %sing Mach (flags %#x)...\n", ++ program_invocation_short_name, BOOT (flags), flags); ++ fflush (stdout); ++ sleep (5); ++ while ((err = host_reboot (host_priv, flags))) ++ error (0, err, "reboot"); ++ for (;;); ++} ++ ++/* Reboot the microkernel, specifying that this is a crash. */ ++void ++crash_mach (void) ++{ ++ reboot_mach (crash_flags); ++} ++ ++/* Notify all tasks that have requested shutdown notifications */ ++void ++notify_shutdown (const char *msg) ++{ ++ struct ntfy_task *n; ++ ++ for (n = ntfy_tasks; n != NULL; n = n->next) ++ { ++ error_t err; ++ printf ("%s: notifying %s of %s...", ++ program_invocation_short_name, n->name, msg); ++ fflush (stdout); ++ err = startup_dosync (n->notify_port, 60000); /* 1 minute to reply */ ++ if (err == MACH_SEND_INVALID_DEST) ++ puts ("(no longer present)"); ++ else if (err) ++ puts (strerror (err)); ++ else ++ puts ("done"); ++ fflush (stdout); ++ } ++} ++ ++/* Reboot the Hurd. */ ++void ++reboot_system (int flags) ++{ ++ notify_shutdown (BOOT (flags)); ++ reboot_mach (flags); ++} ++ ++/* Reboot the Hurd, specifying that this is a crash. */ ++void ++crash_system (void) ++{ ++ reboot_system (crash_flags); ++} ++ ++/* Request a dead-name notification sent to our port. */ ++static error_t ++request_dead_name (mach_port_t name) ++{ ++ error_t err; ++ mach_port_t prev; ++ err = mach_port_request_notification (mach_task_self (), name, ++ MACH_NOTIFY_DEAD_NAME, 1, ++ notification->port_right, ++ MACH_MSG_TYPE_MAKE_SEND_ONCE, &prev); ++ if (prev != MACH_PORT_NULL) ++ mach_port_deallocate (mach_task_self (), prev); ++ return err; ++} ++ ++/* Record an essential task in the list. */ ++static error_t ++record_essential_task (const char *name, task_t task) ++{ ++ error_t err; ++ struct ess_task *et; ++ /* Record this task as essential. */ ++ et = malloc (sizeof (struct ess_task)); ++ if (et == NULL) ++ return ENOMEM; ++ et->task_port = task; ++ et->name = strdup (name); ++ if (et->name == NULL) ++ { ++ free (et); ++ return ENOMEM; ++ } ++ et->next = ess_tasks; ++ ess_tasks = et; ++ ++ /* Dead-name notification on the task port will tell us when it dies. */ ++ err = request_dead_name (task); ++ if (err) ++ return err; ++ ++ return 0; ++} ++ ++kern_return_t ++S_startup_essential_task (mach_port_t server, ++ mach_port_t reply, ++ mach_msg_type_name_t replytype, ++ task_t task, ++ mach_port_t excpt, ++ char *name, ++ mach_port_t credential) ++{ ++ error_t err; ++ if (credential != host_priv) ++ return EPERM; ++ ++ err = mach_port_deallocate (mach_task_self (), credential); ++ assert_perror (err); ++ ++ err = record_essential_task (name, task); ++ if (err) ++ return err; ++ ++ return 0; ++} ++ ++kern_return_t ++S_startup_request_notification (mach_port_t server, ++ mach_port_t notify, ++ char *name) ++{ ++ struct ntfy_task *nt; ++ request_dead_name (notify); ++ ++ /* Note that the ntfy_tasks list is kept in inverse order of the ++ calls; this is important. We need later notification requests ++ to get executed first. */ ++ nt = malloc (sizeof (struct ntfy_task)); ++ nt->notify_port = notify; ++ nt->next = ntfy_tasks; ++ nt->name = strdup (name); ++ ntfy_tasks = nt; ++ return 0; ++} ++ ++kern_return_t ++S_startup_procinit (startup_t bootstrap, ++ mach_port_t reply, ++ mach_msg_type_name_t replyPoly, ++ process_t procserver, ++ mach_port_t *startuptask, ++ auth_t *auth, ++ mach_port_t *hostpriv, ++ mach_msg_type_name_t *hostprivPoly, ++ mach_port_t *devmaster, ++ mach_msg_type_name_t *devmasterPoly) ++{ ++ return EOPNOTSUPP; ++} ++ ++kern_return_t ++S_startup_authinit (startup_t bootstrap, ++ mach_port_t reply, ++ mach_msg_type_name_t replyPoly, ++ mach_port_t auth, ++ mach_port_t *proc, ++ mach_msg_type_name_t *procPoly) ++{ ++ return EOPNOTSUPP; ++} ++ ++error_t ++ports_do_mach_notify_dead_name (struct port_info *pi, ++ mach_port_t dead_name) ++{ ++ error_t err; ++ struct ntfy_task *nt, *pnt; ++ struct ess_task *et; ++ ++ if (!pi) ++ return EOPNOTSUPP; ++ ++ ports_dead_name (pi, dead_name); ++ ++ /* Drop gratuitous extra reference that the notification creates. */ ++ err = mach_port_deallocate (mach_task_self (), dead_name); ++ assert_perror (err); ++ ++ if (pi != notification) ++ return 0; ++ ++ for (et = ess_tasks; et != NULL; et = et->next) ++ if (et->task_port == dead_name) ++ /* An essential task has died. */ ++ { ++ error (0, 0, "Crashing system; essential task %s died", et->name); ++ crash_system (); ++ } ++ ++ for (nt = ntfy_tasks, pnt = NULL; nt != NULL; pnt = nt, nt = nt->next) ++ if (nt->notify_port == dead_name) ++ { ++ /* Someone who wanted to be notified is gone. */ ++ mach_port_deallocate (mach_task_self (), dead_name); ++ if (pnt != NULL) ++ pnt->next = nt->next; ++ else ++ ntfy_tasks = nt->next; ++ free (nt); ++ ++ return 0; ++ } ++ ++ return 0; ++} ++ ++kern_return_t ++S_startup_reboot (mach_port_t server, ++ mach_port_t refpt, ++ int code) ++{ ++ if (refpt != host_priv) ++ return EPERM; ++ ++ reboot_system (code); ++ for (;;); ++} +-- +2.1.4 + diff --git a/debian/patches/0009-XXX-bootshell.patch b/debian/patches/0009-XXX-bootshell.patch new file mode 100644 index 00000000..8864809c --- /dev/null +++ b/debian/patches/0009-XXX-bootshell.patch @@ -0,0 +1,10323 @@ +From e41e16d77b66887d6630e3b4a05ae8a57bfe340d Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Tue, 23 Dec 2014 15:03:44 +0100 +Subject: [PATCH hurd 09/11] XXX bootshell + +XXX hack in toplevel Makefile. +--- + Makefile | 1 + + bootshell/COPYING.tinyscheme | 31 + + bootshell/Makefile | 63 + + bootshell/Manual.txt | 452 ++++ + bootshell/MiniSCHEMETribute.txt | 88 + + bootshell/boot.scm | 249 ++ + bootshell/bootshell.h | 32 + + bootshell/exceptions.c | 72 + + bootshell/exec-startup.c | 162 ++ + bootshell/ffi.c | 819 +++++++ + bootshell/ffi.h | 130 + + bootshell/fs.c | 91 + + bootshell/fsys.c | 74 + + bootshell/hack.txt | 244 ++ + bootshell/init.scm | 716 ++++++ + bootshell/main.c | 296 +++ + bootshell/mig-decls.h | 3 + + bootshell/mig-mutate.h | 27 + + bootshell/opdefines.h | 195 ++ + bootshell/runsystem.scm | 175 ++ + bootshell/scheme-config.h | 11 + + bootshell/scheme-private.h | 210 ++ + bootshell/scheme.c | 5075 +++++++++++++++++++++++++++++++++++++++ + bootshell/scheme.h | 255 ++ + bootshell/startup.c | 487 ++++ + bootshell/startup.h | 12 + + bootshell/utils.c | 121 + + 27 files changed, 10091 insertions(+) + create mode 100644 bootshell/COPYING.tinyscheme + create mode 100644 bootshell/Makefile + create mode 100644 bootshell/Manual.txt + create mode 100644 bootshell/MiniSCHEMETribute.txt + create mode 100644 bootshell/boot.scm + create mode 100644 bootshell/bootshell.h + create mode 100644 bootshell/exceptions.c + create mode 100644 bootshell/exec-startup.c + create mode 100644 bootshell/ffi.c + create mode 100644 bootshell/ffi.h + create mode 100644 bootshell/fs.c + create mode 100644 bootshell/fsys.c + create mode 100644 bootshell/hack.txt + create mode 100644 bootshell/init.scm + create mode 100644 bootshell/main.c + create mode 100644 bootshell/mig-decls.h + create mode 100644 bootshell/mig-mutate.h + create mode 100644 bootshell/opdefines.h + create mode 100644 bootshell/runsystem.scm + create mode 100644 bootshell/scheme-config.h + create mode 100644 bootshell/scheme-private.h + create mode 100644 bootshell/scheme.c + create mode 100644 bootshell/scheme.h + create mode 100644 bootshell/startup.c + create mode 100644 bootshell/startup.h + create mode 100644 bootshell/utils.c + +diff --git a/Makefile b/Makefile +index 3178740..3a2c2ed 100644 +--- a/Makefile ++++ b/Makefile +@@ -32,6 +32,7 @@ lib-subdirs = libshouldbeinlibc libihash libiohelp libports libthreads \ + + # Hurd programs + prog-subdirs = auth proc exec term \ ++ bootshell \ + ext2fs isofs tmpfs fatfs \ + storeio pflocal pfinet defpager mach-defpager \ + login daemons boot console \ +diff --git a/bootshell/COPYING.tinyscheme b/bootshell/COPYING.tinyscheme +new file mode 100644 +index 0000000..a6c49a2 +--- /dev/null ++++ b/bootshell/COPYING.tinyscheme +@@ -0,0 +1,31 @@ ++ LICENSE TERMS ++ ++Copyright (c) 2000, Dimitrios Souflis ++All rights reserved. ++ ++Redistribution and use in source and binary forms, with or without ++modification, are permitted provided that the following conditions are ++met: ++ ++Redistributions of source code must retain the above copyright notice, ++this list of conditions and the following disclaimer. ++ ++Redistributions in binary form must reproduce the above copyright ++notice, this list of conditions and the following disclaimer in the ++documentation and/or other materials provided with the distribution. ++ ++Neither the name of Dimitrios Souflis nor the names of the ++contributors may be used to endorse or promote products derived from ++this software without specific prior written permission. ++ ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ++``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ++LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ++A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR ++CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ++EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ++PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ++PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ++LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ++NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ++SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +diff --git a/bootshell/Makefile b/bootshell/Makefile +new file mode 100644 +index 0000000..97e30f7 +--- /dev/null ++++ b/bootshell/Makefile +@@ -0,0 +1,63 @@ ++# Makefile for bootshell subdirectory of hurd sources ++# ++# Copyright (C) 1999, 2000, 2002, 2007, 2010, 2012 Free Software Foundation, ++# Inc. ++# ++# This file is part of the GNU Hurd. ++# ++# The GNU Hurd is free software; you can redistribute it and/or ++# modify it under the terms of the GNU General Public License as ++# published by the Free Software Foundation; either version 2, or (at ++# your option) any later version. ++# ++# The GNU Hurd is distributed in the hope that it will be useful, but ++# WITHOUT ANY WARRANTY; without even the implied warranty of ++# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ++# General Public License for more details. ++# ++# You should have received a copy of the GNU General Public License ++# along with this program; if not, write to the Free Software ++# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ++ ++dir := bootshell ++makemode:= server ++target := bootshell ++ ++SCRIPTS := init.scm boot.scm runsystem.scm ++SRCS := \ ++ scheme.c \ ++ main.c \ ++ exceptions.c \ ++ fs.c \ ++ fsys.c \ ++ exec-startup.c \ ++ startup.c \ ++ utils.c \ ++ ffi.c \ ++ ++SPROTOCOLS := exc exec_startup fs fsys startup ++UPROTOCOLS := startup startup_reply ++ ++MIGSTUBS:= \ ++ $(foreach p,$(SPROTOCOLS),$(p)Server.o) \ ++ $(foreach p,$(UPROTOCOLS),$(p)User.o) ++OBJS := $(SRCS:.c=.o) $(SCRIPTS:.scm=.o) $(MIGSTUBS) ++ ++HURDLIBS:= shouldbeinlibc ++#OTHERLIBS:= -lpthread -lreadline -lhistory \ ++# $(shell pkg-config --libs --static ncurses) ++OTHERLIBS:= -lpthread ++CFLAGS += -imacros scheme-config.h ++LDFLAGS += -static ++MIGSFLAGS := -imacros mig-mutate.h ++ ++%.o: %.scm ++ $(LD) -r --format=binary $< -o $@ ++ ++NOWARN := conversion sign-conversion switch unused-function ++CFLAGS := $(filter-out $(foreach flag,$NOWARN,-W$(flag)),$(CFLAGS)) ++ ++CFLAGS += -Wno-sign-conversion ++CFLAGS += -O0 -fno-omit-frame-pointer ++ ++include ../Makeconf +diff --git a/bootshell/Manual.txt b/bootshell/Manual.txt +new file mode 100644 +index 0000000..bf0e8ea +--- /dev/null ++++ b/bootshell/Manual.txt +@@ -0,0 +1,452 @@ ++ ++ ++ TinySCHEME Version 1.41 ++ ++ "Safe if used as prescribed" ++ -- Philip K. Dick, "Ubik" ++ ++This software is open source, covered by a BSD-style license. ++Please read accompanying file COPYING. ++------------------------------------------------------------------------------- ++ ++ This Scheme interpreter is based on MiniSCHEME version 0.85k4 ++ (see miniscm.tar.gz in the Scheme Repository) ++ Original credits in file MiniSCHEMETribute.txt. ++ ++ D. Souflis (dsouflis@acm.org) ++ ++------------------------------------------------------------------------------- ++ What is TinyScheme? ++ ------------------- ++ ++ TinyScheme is a lightweight Scheme interpreter that implements as large ++ a subset of R5RS as was possible without getting very large and ++ complicated. It is meant to be used as an embedded scripting interpreter ++ for other programs. As such, it does not offer IDEs or extensive toolkits ++ although it does sport a small top-level loop, included conditionally. ++ A lot of functionality in TinyScheme is included conditionally, to allow ++ developers freedom in balancing features and footprint. ++ ++ As an embedded interpreter, it allows multiple interpreter states to ++ coexist in the same program, without any interference between them. ++ Programmatically, foreign functions in C can be added and values ++ can be defined in the Scheme environment. Being a quite small program, ++ it is easy to comprehend, get to grips with, and use. ++ ++ Known bugs ++ ---------- ++ ++ TinyScheme is known to misbehave when memory is exhausted. ++ ++ ++ Things that keep missing, or that need fixing ++ --------------------------------------------- ++ ++ There are no hygienic macros. No rational or ++ complex numbers. No unwind-protect and call-with-values. ++ ++ Maybe (a subset of) SLIB will work with TinySCHEME... ++ ++ Decent debugging facilities are missing. Only tracing is supported ++ natively. ++ ++ ++ Scheme Reference ++ ---------------- ++ ++ If something seems to be missing, please refer to the code and ++ "init.scm", since some are library functions. Refer to the MiniSCHEME ++ readme as a last resort. ++ ++ Environments ++ (interaction-environment) ++ See R5RS. In TinySCHEME, immutable list of association lists. ++ ++ (current-environment) ++ The environment in effect at the time of the call. An example of its ++ use and its utility can be found in the sample code that implements ++ packages in "init.scm": ++ ++ (macro (package form) ++ `(apply (lambda () ++ ,@(cdr form) ++ (current-environment)))) ++ ++ The environment containing the (local) definitions inside the closure ++ is returned as an immutable value. ++ ++ (defined? ) (defined? ) ++ Checks whether the given symbol is defined in the current (or given) ++ environment. ++ ++ Symbols ++ (gensym) ++ Returns a new interned symbol each time. Will probably move to the ++ library when string->symbol is implemented. ++ ++ Directives ++ (gc) ++ Performs garbage collection immediatelly. ++ ++ (gcverbose) (gcverbose ) ++ The argument (defaulting to #t) controls whether GC produces ++ visible outcome. ++ ++ (quit) (quit ) ++ Stops the interpreter and sets the 'retcode' internal field (defaults ++ to 0). When standalone, 'retcode' is returned as exit code to the OS. ++ ++ (tracing ) ++ 1, turns on tracing. 0 turns it off. (Only when USE_TRACING is 1). ++ ++ Mathematical functions ++ Since rationals and complexes are absent, the respective functions ++ are also missing. ++ Supported: exp, log, sin, cos, tan, asin, acos, atan, floor, ceiling, ++ trunc, round and also sqrt and expt when USE_MATH=1. ++ Number-theoretical quotient, remainder and modulo, gcd, lcm. ++ Library: exact?, inexact?, odd?, even?, zero?, positive?, negative?, ++ exact->inexact. inexact->exact is a core function. ++ ++ Type predicates ++ boolean?,eof-object?,symbol?,number?,string?,integer?,real?,list?,null?, ++ char?,port?,input-port?,output-port?,procedure?,pair?,environment?', ++ vector?. Also closure?, macro?. ++ ++ Types ++ Types supported: ++ ++ Numbers (integers and reals) ++ Symbols ++ Pairs ++ Strings ++ Characters ++ Ports ++ Eof object ++ Environments ++ Vectors ++ ++ Literals ++ String literals can contain escaped quotes \" as usual, but also ++ \n, \r, \t, \xDD (hex representations) and \DDD (octal representations). ++ Note also that it is possible to include literal newlines in string ++ literals, e.g. ++ ++ (define s "String with newline here ++ and here ++ that can function like a HERE-string") ++ ++ Character literals contain #\space and #\newline and are supplemented ++ with #\return and #\tab, with obvious meanings. Hex character ++ representations are allowed (e.g. #\x20 is #\space). ++ When USE_ASCII_NAMES is defined, various control characters can be ++ referred to by their ASCII name. ++ 0 #\nul 17 #\dc1 ++ 1 #\soh 18 #\dc2 ++ 2 #\stx 19 #\dc3 ++ 3 #\etx 20 #\dc4 ++ 4 #\eot 21 #\nak ++ 5 #\enq 22 #\syn ++ 6 #\ack 23 #\etv ++ 7 #\bel 24 #\can ++ 8 #\bs 25 #\em ++ 9 #\ht 26 #\sub ++ 10 #\lf 27 #\esc ++ 11 #\vt 28 #\fs ++ 12 #\ff 29 #\gs ++ 13 #\cr 30 #\rs ++ 14 #\so 31 #\us ++ 15 #\si ++ 16 #\dle 127 #\del ++ ++ Numeric literals support #x #o #b and #d. Flonums are currently read only ++ in decimal notation. Full grammar will be supported soon. ++ ++ Quote, quasiquote etc. ++ As usual. ++ ++ Immutable values ++ Immutable pairs cannot be modified by set-car! and set-cdr!. ++ Immutable strings cannot be modified via string-set! ++ ++ I/O ++ As per R5RS, plus String Ports (see below). ++ current-input-port, current-output-port, ++ close-input-port, close-output-port, input-port?, output-port?, ++ open-input-file, open-output-file. ++ read, write, display, newline, write-char, read-char, peek-char. ++ char-ready? returns #t only for string ports, because there is no ++ portable way in stdio to determine if a character is available. ++ Also open-input-output-file, set-input-port, set-output-port (not R5RS) ++ Library: call-with-input-file, call-with-output-file, ++ with-input-from-file, with-output-from-file and ++ with-input-output-from-to-files, close-port and input-output-port? ++ (not R5RS). ++ String Ports: open-input-string, open-output-string, get-output-string, ++ open-input-output-string. Strings can be used with I/O routines. ++ ++ Vectors ++ make-vector, vector, vector-length, vector-ref, vector-set!, list->vector, ++ vector-fill!, vector->list, vector-equal? (auxiliary function, not R5RS) ++ ++ Strings ++ string, make-string, list->string, string-length, string-ref, string-set!, ++ substring, string->list, string-fill!, string-append, string-copy. ++ string=?, string?, string>?, string<=?, string>=?. ++ (No string-ci*? yet). string->number, number->string. Also atom->string, ++ string->atom (not R5RS). ++ ++ Symbols ++ symbol->string, string->symbol ++ ++ Characters ++ integer->char, char->integer. ++ char=?, char?, char<=?, char>=?. ++ (No char-ci*?) ++ ++ Pairs & Lists ++ cons, car, cdr, list, length, map, for-each, foldr, list-tail, ++ list-ref, last-pair, reverse, append. ++ Also member, memq, memv, based on generic-member, assoc, assq, assv ++ based on generic-assoc. ++ ++ Streams ++ head, tail, cons-stream ++ ++ Control features ++ Apart from procedure?, also macro? and closure? ++ map, for-each, force, delay, call-with-current-continuation (or call/cc), ++ eval, apply. 'Forcing' a value that is not a promise produces the value. ++ There is no call-with-values, values, nor dynamic-wind. Dynamic-wind in ++ the presence of continuations would require support from the abstract ++ machine itself. ++ ++ Property lists ++ TinyScheme inherited from MiniScheme property lists for symbols. ++ put, get. ++ ++ Dynamically-loaded extensions ++ (load-extension ) ++ Loads a DLL declaring foreign procedures. On Unix/Linux, one can make use ++ of the ld.so.conf file or the LD_RUN_PATH system variable in order to place ++ the library in a directory other than the current one. Please refer to the ++ appropriate 'man' page. ++ ++ Esoteric procedures ++ (oblist) ++ Returns the oblist, an immutable list of all the symbols. ++ ++ (macro-expand
) ++ Returns the expanded form of the macro call denoted by the argument ++ ++ (define-with-return ( ...) ) ++ Like plain 'define', but makes the continuation available as 'return' ++ inside the procedure. Handy for imperative programs. ++ ++ (new-segment ) ++ Allocates more memory segments. ++ ++ defined? ++ See "Environments" ++ ++ (get-closure-code ) ++ Gets the code as scheme data. ++ ++ (make-closure ) ++ Makes a new closure in the given environment. ++ ++ Obsolete procedures ++ (print-width ) ++ ++ Programmer's Reference ++ ---------------------- ++ ++ The interpreter state is initialized with "scheme_init". ++ Custom memory allocation routines can be installed with an alternate ++ initialization function: "scheme_init_custom_alloc". ++ Files can be loaded with "scheme_load_file". Strings containing Scheme ++ code can be loaded with "scheme_load_string". It is a good idea to ++ "scheme_load" init.scm before anything else. ++ ++ External data for keeping external state (of use to foreign functions) ++ can be installed with "scheme_set_external_data". ++ Foreign functions are installed with "assign_foreign". Additional ++ definitions can be added to the interpreter state, with "scheme_define" ++ (this is the way HTTP header data and HTML form data are passed to the ++ Scheme script in the Altera SQL Server). If you wish to define the ++ foreign function in a specific environment (to enhance modularity), ++ use "assign_foreign_env". ++ ++ The procedure "scheme_apply0" has been added with persistent scripts in ++ mind. Persistent scripts are loaded once, and every time they are needed ++ to produce HTTP output, appropriate data are passed through global ++ definitions and function "main" is called to do the job. One could ++ add easily "scheme_apply1" etc. ++ ++ The interpreter state should be deinitialized with "scheme_deinit". ++ ++ DLLs containing foreign functions should define a function named ++ init_. E.g. foo.dll should define init_foo, and bar.so ++ should define init_bar. This function should assign_foreign any foreign ++ function contained in the DLL. ++ ++ The first dynamically loaded extension available for TinyScheme is ++ a regular expression library. Although it's by no means an ++ established standard, this library is supposed to be installed in ++ a directory mirroring its name under the TinyScheme location. ++ ++ ++ Foreign Functions ++ ----------------- ++ ++ The user can add foreign functions in C. For example, a function ++ that squares its argument: ++ ++ pointer square(scheme *sc, pointer args) { ++ if(args!=sc->NIL) { ++ if(sc->isnumber(sc->pair_car(args))) { ++ double v=sc->rvalue(sc->pair_car(args)); ++ return sc->mk_real(sc,v*v); ++ } ++ } ++ return sc->NIL; ++ } ++ ++ Foreign functions are now defined as closures: ++ ++ sc->interface->scheme_define( ++ sc, ++ sc->global_env, ++ sc->interface->mk_symbol(sc,"square"), ++ sc->interface->mk_foreign_func(sc, square)); ++ ++ ++ Foreign functions can use the external data in the "scheme" struct ++ to implement any kind of external state. ++ ++ External data are set with the following function: ++ void scheme_set_external_data(scheme *sc, void *p); ++ ++ As of v.1.17, the canonical way for a foreign function in a DLL to ++ manipulate Scheme data is using the function pointers in sc->interface. ++ ++ Standalone ++ ---------- ++ ++ Usage: tinyscheme -? ++ or: tinyscheme [ ...] ++ followed by ++ -1 [ ...] ++ -c [ ...] ++ assuming that the executable is named tinyscheme. ++ ++ Use - in the place of a filename to denote stdin. ++ The -1 flag is meant for #! usage in shell scripts. If you specify ++ #! /somewhere/tinyscheme -1 ++ then tinyscheme will be called to process the file. For example, the ++ following script echoes the Scheme list of its arguments. ++ ++ #! /somewhere/tinyscheme -1 ++ (display *args*) ++ ++ The -c flag permits execution of arbitrary Scheme code. ++ ++ ++ Error Handling ++ -------------- ++ ++ Errors are recovered from without damage. The user can install his ++ own handler for system errors, by defining *error-hook*. Defining ++ to '() gives the default behavior, which is equivalent to "error". ++ USE_ERROR_HOOK must be defined. ++ ++ A simple exception handling mechanism can be found in "init.scm". ++ A new syntactic form is introduced: ++ ++ (catch ++ ... ) ++ ++ "Catch" establishes a scope spanning multiple call-frames ++ until another "catch" is encountered. ++ ++ Exceptions are thrown with: ++ ++ (throw "message") ++ ++ If used outside a (catch ...), reverts to (error "message"). ++ ++ Example of use: ++ ++ (define (foo x) (write x) (newline) (/ x 0)) ++ ++ (catch (begin (display "Error!\n") 0) ++ (write "Before foo ... ") ++ (foo 5) ++ (write "After foo")) ++ ++ The exception mechanism can be used even by system errors, by ++ ++ (define *error-hook* throw) ++ ++ which makes use of the error hook described above. ++ ++ If necessary, the user can devise his own exception mechanism with ++ tagged exceptions etc. ++ ++ ++ Reader extensions ++ ----------------- ++ ++ When encountering an unknown character after '#', the user-specified ++ procedure *sharp-hook* (if any), is called to read the expression. ++ This can be used to extend the reader to handle user-defined constants ++ or whatever. It should be a procedure without arguments, reading from ++ the current input port (which will be the load-port). ++ ++ ++ Colon Qualifiers - Packages ++ --------------------------- ++ ++ When USE_COLON_HOOK=1: ++ The lexer now recognizes the construction :: and ++ transforms it in the following manner (T is the transformation function): ++ ++ T(::) = (*colon-hook* 'T() ) ++ ++ where is a symbol not containing any double-colons. ++ ++ As the definition is recursive, qualifiers can be nested. ++ The user can define his own *colon-hook*, to handle qualified names. ++ By default, "init.scm" defines *colon-hook* as EVAL. Consequently, ++ the qualifier must denote a Scheme environment, such as one returned ++ by (interaction-environment). "Init.scm" defines a new syntantic form, ++ PACKAGE, as a simple example. It is used like this: ++ ++ (define toto ++ (package ++ (define foo 1) ++ (define bar +))) ++ ++ foo ==> Error, "foo" undefined ++ (eval 'foo) ==> Error, "foo" undefined ++ (eval 'foo toto) ==> 1 ++ toto::foo ==> 1 ++ ((eval 'bar toto) 2 (eval 'foo toto)) ==> 3 ++ (toto::bar 2 toto::foo) ==> 3 ++ (eval (bar 2 foo) toto) ==> 3 ++ ++ If the user installs another package infrastructure, he must define ++ a new 'package' procedure or macro to retain compatibility with supplied ++ code. ++ ++ Note: Older versions used ':' as a qualifier. Unfortunately, the use ++ of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially ++ precludes its use as a real qualifier. ++ ++ ++ ++ ++ ++ ++ ++ +diff --git a/bootshell/MiniSCHEMETribute.txt b/bootshell/MiniSCHEMETribute.txt +new file mode 100644 +index 0000000..02ebd26 +--- /dev/null ++++ b/bootshell/MiniSCHEMETribute.txt +@@ -0,0 +1,88 @@ ++ TinyScheme would not exist if it wasn't for MiniScheme. I had just ++ written the HTTP server for Ovrimos SQL Server, and I was lamenting the ++ lack of a scripting language. Server-side Javascript would have been the ++ preferred solution, had there been a Javascript interpreter I could ++ lay my hands on. But there weren't. Perl would have been another solution, ++ but it was probably ten times bigger that the program it was supposed to ++ be embedded in. There would also be thorny licencing issues. ++ ++ So, the obvious thing to do was find a trully small interpreter. Forth ++ was a language I had once quasi-implemented, but the difficulty of ++ handling dynamic data and the weirdness of the language put me off. I then ++ looked around for a LISP interpreter, the next thing I knew was easy to ++ implement. Alas, the LeLisp I knew from my days in UPMC (Universite Pierre ++ et Marie Curie) had given way to Common Lisp, a megalith of a language! ++ Then my search lead me to Scheme, a language I knew was very orthogonal ++ and clean. When I found Mini-Scheme, a single C file of some 2400 loc, I ++ fell in love with it! What if it lacked floating-point numbers and ++ strings! The rest, as they say, is history. ++ ++ Below are the original credits. Don't email Akira KIDA, the address has ++ changed. ++ ++ ---------- Mini-Scheme Interpreter Version 0.85 ---------- ++ ++ coded by Atsushi Moriwaki (11/5/1989) ++ ++ E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp ++ ++ THIS SOFTWARE IS IN THE PUBLIC DOMAIN ++ ------------------------------------ ++ This software is completely free to copy, modify and/or re-distribute. ++ But I would appreciate it if you left my name on the code as the author. ++ ++ This version has been modified by R.C. Secrist. ++ ++ Mini-Scheme is now maintained by Akira KIDA. ++ ++ This is a revised and modified version by Akira KIDA. ++ current version is 0.85k4 (15 May 1994) ++ ++ Please send suggestions, bug reports and/or requests to: ++ ++ ++ ++ Features compared to MiniSCHEME ++ ------------------------------- ++ ++ All code is now reentrant. Interpreter state is held in a 'scheme' ++ struct, and many interpreters can coexist in the same program, possibly ++ in different threads. The user can specify user-defined memory allocation ++ primitives. (see "Programmer's Reference") ++ ++ The reader is more consistent. ++ ++ Strings, characters and flonums are supported. (see "Types") ++ ++ Files being loaded can be nested up to some depth. ++ ++ R5RS I/O is there, plus String Ports. (see "Scheme Reference","I/O") ++ ++ Vectors exist. ++ ++ As a standalone application, it supports command-line arguments. ++ (see "Standalone") ++ ++ Running out of memory is now handled. ++ ++ The user can add foreign functions in C. (see "Foreign Functions") ++ ++ The code has been changed slightly, core functions have been moved ++ to the library, behavior has been aligned with R5RS etc. ++ ++ Support has been added for user-defined error recovery. ++ (see "Error Handling") ++ ++ Support has been added for modular programming. ++ (see "Colon Qualifiers - Packages") ++ ++ To enable this, EVAL has changed internally, and can ++ now take two arguments, as per R5RS. Environments are supported. ++ (see "Colon Qualifiers - Packages") ++ ++ Promises are now evaluated once only. ++ ++ (macro (foo form) ...) is now equivalent to (macro foo (lambda(form) ...)) ++ ++ The reader can be extended using new #-expressions ++ (see "Reader extensions") +diff --git a/bootshell/boot.scm b/bootshell/boot.scm +new file mode 100644 +index 0000000..f6b4d25 +--- /dev/null ++++ b/bootshell/boot.scm +@@ -0,0 +1,249 @@ ++;; Missing library functions. ++(define (filter pred lst) ++ (cond ((null? lst) '()) ++ ((pred (car lst)) ++ (cons (car lst) (filter pred (cdr lst)))) ++ (else (filter pred (cdr lst))))) ++ ++(define (any p l) ++ (cond ((null? l) #f) ++ ((p (car l)) #t) ++ (else (any p (cdr l))))) ++ ++;; Is s1 a prefix of s2 ? ++(define (string-prefix? s1 s2) ++ (and (>= (string-length s2) (string-length s1)) ++ (string=? s1 (substring s2 0 (string-length s1))))) ++ ++;; Given a list of prefixes, does s start with any of them ? ++(define (string-prefix-any? lp s) ++ (any (lambda (p) (string-prefix? p s)) lp)) ++ ++;; The `catch' from init.scm doesn't give the thrown value to the ++;; handler. XXX: Crappy workaround. ++(define last-exception '()) ++(define (throw . x) ++ (set! last-exception x) ++ (if (more-handlers?) ++ (apply (pop-handler)) ++ (apply error x))) ++(define *error-hook* throw) ++ ++;; Foreign function interface. ++ ++(define (ffi-apply name f args) ++ (let ((result (apply f args))) ++ (cond ++ ((null? result) (throw "Got NULL.")) ++ ((not (= (car result) 0)) (throw (string-append ++ name ": " (strerror (car result))))) ++ ((and (= (car result) 0) (pair? (cdr result))) (cadr result)) ++ ((= (car result) 0) '()) ++ (else ++ (throw "Weird."))))) ++ ++;; Convenience functions. ++(define (echo . msg) ++ (map display msg) ++ (newline)) ++ ++(define (trace-show x) ++ (write x) ++ x) ++ ++; Semi-crappy repl using `prompt' function. ++(define (shell p) ++ (let ((prefix "")) ++ (do () (#f) ++ (let ((line (prompt (p prefix)))) ++ (set! prefix (string-append prefix line)) ++ ++ (if (> (string-length prefix) 0) ++ (let ((c (read (open-input-string prefix)))) ++ (cond ++ ((eof-object? c) ()) ++ (else (catch (echo "Error: " last-exception) ++ (echo " ===> " (eval c))) ++ (set! prefix ""))))))))) ++ ++; unfortunately, this doesn't work ++;(define (shell p) ++; (display (p)) ++; (eval (read)) ++; (shell p)) ++ ++(define version "bootshell/TinySCHEME 1.41") ++ ++(define (prompt-append-prefix prompt prefix) ++ (string-append prompt (if (> (string-length prefix) 0) ++ (string-append prefix " ... ") ++ "> "))) ++ ++(define (interactive-repl) ++ (shell (lambda (p) (prompt-append-prefix "(bootshell) " p)))) ++ ++(define (emergency-shell) ++ (shell (lambda (p) (prompt-append-prefix "(emergency-shell) " p)))) ++ ++(define (panic . msg) ++ (display "\n\npanic: ") ++ (map display msg) ++ (newline) ++ (emergency-shell)) ++ ++;; port management ++(define (mach-port-valid? p) (not (or (= p MACH_PORT_NULL) ++ (= p MACH_PORT_DEAD)))) ++ ++(define (make-send-right receive-right) ++ (mach-port-insert-right mach-task-self receive-right receive-right ++ MACH_MSG_TYPE_MAKE_SEND)) ++(define (copy-send-right send-right) ++ (mach-port-insert-right mach-task-self send-right send-right ++ MACH_MSG_TYPE_COPY_SEND)) ++ ++;; Binds a send right to an identifier, much like `let'. Deallocates ++;; the send right once it goes out of scope. ++(macro (letport form) ++ (let ((result-sym (gensym))) ++ `((lambda ((,@(caaadr form))) ++ (let ((,result-sym ++ ,(if (= 1 (length (cadr form))) ++ `(begin ,@(cddr form)) ++ `(letport ,(cdadr form) ,@(cddr form))))) ++ (if (mach-port-valid? ,(caaadr form)) ++ (mach-port-deallocate mach-task-self ,(caaadr form))) ++ ,result-sym)) ,@(cdaadr form)))) ++ ++;; TinySCHEME doesn't have define-syntax :( ++;; ++;; (define-syntax letport ++;; (syntax-rules () ++;; ((letport ((var expr) ...) body ...) ++;; ((lambda expressions ++;; (let ((result (apply (lambda (var ...) body ...) expressions))) ++;; (map (lambda (p) (mach-port-deallocate mach-task-self p)) ++;; expressions) ++;; result)) expr ...)))) ++ ++;; task management ++ ++(define (task-get-kernel-port t) ++ (task-get-special-port t TASK_KERNEL_PORT)) ++(define (task-get-exception-port t) ++ (task-get-special-port t TASK_EXCEPTION_PORT)) ++(define (task-get-bootstrap-port t) ++ (task-get-special-port t TASK_BOOTSTRAP_PORT)) ++ ++(define (task-set-kernel-port t p) ++ (task-set-special-port t TASK_KERNEL_PORT p)) ++(define (task-set-exception-port t p) ++ (task-set-special-port t TASK_EXCEPTION_PORT p)) ++(define (task-set-bootstrap-port t p) ++ (task-set-special-port t TASK_BOOTSTRAP_PORT p)) ++ ++;; Hurd server bootstrap. ++ ++(define ESUCCESS 0) ; ++ ++;; translator linkage ++ ++(define (set-active-translator path active-control) ++ (letport ((node (file-name-lookup path O_NOTRANS 438))) ;;=^= 0666 ++ (file-set-translator node 0 FS_TRANS_SET 0 0 0 ++ active-control MACH_MSG_TYPE_COPY_SEND))) ++ ++;; Wait for the predicate CONDITION to return #t, or throw 'timeout ++;; after T microseconds. ++(define (wait-for condition t) ++ (if (<= t 0) ++ (throw 'timeout) ++ (if (not (condition)) ++ (begin (usleep 10000) ++ (wait-for condition (- t 10000)))))) ++ ++;; Read a word from port P. ++(define (read-word p) ++ (list->string ++ (let f () ++ (let ((c (peek-char p))) ++ (cond ++ ((eof-object? c) '()) ++ ((char-alphabetic? c) ++ (read-char p) ++ (cons c (f))) ++ (else '())))))) ++ ++;; Read everything from port P. ++(define (read-all p) ++ (list->string ++ (let f () ++ (let ((c (peek-char p))) ++ (cond ++ ((eof-object? c) '()) ++ (else (read-char p) ++ (cons c (f)))))))) ++ ++;; Shell-like functions. ++ ++(define cd chdir) ++(define (pwd) (echo (getcwd))) ++(define (cat path) ++ (display (call-with-input-file path read-all))) ++(define (hostname) ++ ((lambda (x) (if (string? x) x "unnamed")) ++ (call-with-input-file "/etc/hostname" read-word))) ++ ++(define (print-banner) ++ (echo " ++Welcome to bootshell, a scheme shell. Type `(help)' for help. ++")) ++ ++(define (reboot-hurd) ++ (letport ((startup (file-name-lookup "/servers/startup" 0 0))) ++ (startup-reboot startup host-priv RB_AUTOBOOT))) ++ ++(define (halt-hurd) ++ (letport ((startup (file-name-lookup "/servers/startup" 0 0))) ++ (startup-reboot startup host-priv RB_HALT))) ++ ++(define (reboot-mach) (host-reboot host-priv RB_AUTOBOOT)) ++(define (halt-mach) (host-reboot host-priv RB_HALT)) ++(define (kdb-mach) (host-reboot host-priv RB_DEBUGGER)) ++ ++(define (reboot) ++ (catch (reboot-mach) ++ (reboot-hurd))) ++(define (halt) ++ (catch (halt-mach) ++ (halt-hurd))) ++ ++;; Online documentation. ++ ++(define (help) ++ (echo "Welcome to the Hurd boot shell. XXX this is not up to date :( ++ ++Functions ++ General shell-like functions ++ cat cd echo halt help hostname kdb mach-print panic prompt pwd ++ reboot shell sleep {reboot,halt}-{mach,hurd} ++" " ++ Mach related ++ mach-port-valid? {copy,make}-send-right task-{create,resume,terminate} ++ task-{g,s}et-{special,kernel,exception,bootstrap}-port host-reboot ++" " ++ Hurd related ++ file_name_lookup chdir getcwd startup-reboot ++ XXX write them ++ {s,g}etauth {s,g}etproc file_name_lookup_under file_name_path_lookup ++" " ++Environment: ++ mach-task-self exception-port bootstrap-port host-priv device-master ++ rootfs-task hello-task rootfs-control")) ++ ++;; XXX ++ ++(define log display) ++ ++;; We're ready. ++(echo version ".") +diff --git a/bootshell/bootshell.h b/bootshell/bootshell.h +new file mode 100644 +index 0000000..2112f83 +--- /dev/null ++++ b/bootshell/bootshell.h +@@ -0,0 +1,32 @@ ++#ifndef _HURD_BOOTSHELL_H ++#define _HURD_BOOTSHELL_H ++ ++#include ++ ++extern mach_port_t portarray_template[]; ++ ++/* We catch exceptions using this port. */ ++extern mach_port_t exception_port; ++ ++extern mach_port_t console; ++extern mach_port_t rootnode; ++ ++error_t init_exception_handling (void); ++error_t init_fs_server (void); ++ ++void mach_print(const char *); ++void mach_printf(const char *format, ...); ++ ++mach_msg_return_t ++mach_msg_server_timeout_once (boolean_t (*demux) (mach_msg_header_t *request, ++ mach_msg_header_t *reply), ++ mach_msg_size_t max_size, ++ mach_port_t rcv_name, ++ mach_msg_option_t option, ++ mach_msg_timeout_t timeout, ++ mach_msg_id_t *msgh_id); ++ ++#define TRACE error (0, 0, "%s:%d", __FUNCTION__, __LINE__); ++#define TR mach_printf ("%s:%d\n", __FUNCTION__, __LINE__); ++ ++#endif +diff --git a/bootshell/exceptions.c b/bootshell/exceptions.c +new file mode 100644 +index 0000000..0ad6ada +--- /dev/null ++++ b/bootshell/exceptions.c +@@ -0,0 +1,72 @@ ++#include ++/* Mach exception handling. */ ++#include ++// eek #include "exc_S.h" ++ ++#include "bootshell.h" ++ ++error_t ++catch_exception_raise (mach_port_t e, ++ thread_t thread, ++ task_t task, ++ int exception, int code, int subcode) ++{ ++ if (e != exception_port) ++ return EOPNOTSUPP; ++ ++ mach_printf ("catch_exception_raise (%d, %d, %d, %d, %d): ", ++ thread, task, exception, code, subcode); ++ ++ if (task == mach_task_self ()) ++ mach_print ("terminating bootshell. bye.\n"); ++ else ++ mach_printf ("terminating task %d.\n", task); ++ ++ task_terminate (task); ++ return 0; ++} ++ ++static void * ++service_exception_requests (void *arg) ++{ ++ extern boolean_t exc_server (mach_msg_header_t *, mach_msg_header_t *); ++ ++ while (1) ++ mach_msg_server (exc_server, 0, exception_port); ++ ++ /* Not reached. */ ++ return NULL; ++} ++ ++error_t ++init_exception_handling (void) ++{ ++ error_t err; ++ pthread_t t; ++ ++ err = mach_port_allocate (mach_task_self (), ++ MACH_PORT_RIGHT_RECEIVE, ++ &exception_port); ++ if (err) ++ return err; ++ ++ /* Make a thread to service exception requests. */ ++ err = pthread_create (&t, NULL, service_exception_requests, NULL); ++ if (err) ++ return err; ++ pthread_detach (t); ++ ++ err = mach_port_insert_right (mach_task_self (), ++ exception_port, ++ exception_port, ++ MACH_MSG_TYPE_MAKE_SEND); ++ if (err) ++ return err; ++ ++ err = task_set_exception_port (mach_task_self (), exception_port); ++ if (err) ++ return err; ++ ++ return err; ++} ++ +diff --git a/bootshell/exec-startup.c b/bootshell/exec-startup.c +new file mode 100644 +index 0000000..b036a4b +--- /dev/null ++++ b/bootshell/exec-startup.c +@@ -0,0 +1,162 @@ ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++ ++// eek #include "fsys_S.h" ++ ++#include "bootshell.h" ++#include "ffi.h" ++ ++/* XXX would be nice not to use a global variable, maybe with ++ payloads. */ ++static struct ++{ ++ /* Filled by caller. */ ++ mach_port_t bootstrap_port; ++ char *argz; ++ size_t argz_len; ++ ++ /* Filled by the server function. */ ++} exec_startup_get_info_args; ++ ++/* We look like an execserver to the execserver itself; it makes this ++ call (as does any task) to get its state. We can't give it all of ++ its ports (we'll provide those with a later call to exec_init). */ ++kern_return_t ++S_exec_startup_get_info (mach_port_t bootstrap_port, ++ vm_address_t *user_entry, ++ vm_address_t *phdr_data, ++ vm_size_t *phdr_size, ++ vm_address_t *base_addr, ++ vm_size_t *stack_size, ++ int *flags, ++ char **argz, ++ mach_msg_type_number_t *argz_len, ++ char **envz, ++ mach_msg_type_number_t *envz_len, ++ mach_port_t **dtableP, ++ mach_msg_type_name_t *dtablepoly, ++ mach_msg_type_number_t *dtablelen, ++ mach_port_t **portarrayP, ++ mach_msg_type_name_t *portarraypoly, ++ mach_msg_type_number_t *portarraylen, ++ int **intarrayP, ++ mach_msg_type_number_t *intarraylen) ++{ ++ error_t err; ++ mach_port_t *portarray, *dtable; ++ mach_port_t rootport; ++ ++ if (bootstrap_port != exec_startup_get_info_args.bootstrap_port) ++ return EOPNOTSUPP; ++ ++ *user_entry = 0; ++ *phdr_data = *base_addr = 0; ++ *phdr_size = *stack_size = 0; ++ ++ *flags = 0; ++ ++ /* Arguments. */ ++ *argz_len = exec_startup_get_info_args.argz_len; ++ if (*argz_len == 0) ++ /* We have no args for it. Tell it to look on its stack ++ for the args placed there by the boot loader. */ ++ *flags |= EXEC_STACK_ARGS; ++ else ++ { ++ err = vm_allocate (mach_task_self (), argz, *argz_len, TRUE); ++ if (err) ++ return err; ++ memcpy (*argz, exec_startup_get_info_args.argz, *argz_len); ++ } ++ ++ /* Environment. */ ++ *envz = NULL; ++ *envz_len = 0; ++ ++ /* File descriptors. */ ++ if (*dtablelen < 3) ++ *dtableP = mmap (0, 3 * sizeof (mach_port_t), PROT_READ|PROT_WRITE, ++ MAP_ANON, 0, 0); ++ dtable = *dtableP; ++ *dtablepoly = MACH_MSG_TYPE_COPY_SEND; ++ *dtablelen = 3; ++ dtable[0] = dtable[1] = dtable[2] = console; ++ ++ /* Initial ports. */ ++ if (*portarraylen < INIT_PORT_MAX) ++ *portarrayP = mmap (0, INIT_PORT_MAX * sizeof (mach_port_t), ++ PROT_READ|PROT_WRITE, MAP_ANON, 0, 0); ++ portarray = *portarrayP; ++ *portarraylen = INIT_PORT_MAX; ++ memcpy (portarray, portarray_template, INIT_PORT_MAX * sizeof *portarray); ++ portarray[INIT_PORT_BOOTSTRAP] = bootstrap_port; /* use the same port */ ++ *portarraypoly = MACH_MSG_TYPE_COPY_SEND; ++ ++ /* Initial ints. */ ++ *intarrayP = NULL; ++ *intarraylen = 0; ++ ++ return 0; ++} ++ ++boolean_t ++exec_startup_get_info_demuxer (mach_msg_header_t *request, ++ mach_msg_header_t *reply) ++{ ++ extern boolean_t exec_startup_server (mach_msg_header_t *, ++ mach_msg_header_t *); ++ if (request->msgh_id != 30500) /* XXX hardcoded msgh_id */ ++ { ++ /* Return MIG_BAD_ID. */ ++ mig_reply_setup (request, reply); ++ return FALSE; ++ } ++ return exec_startup_server (request, reply); ++} ++ ++error_t ++service_exec_startup_request (mach_port_t bootstrap, ++ char *argz, ++ size_t argz_len, ++ mach_msg_timeout_t timeout) ++{ ++ error_t err; ++ mach_msg_id_t msgh_id; ++ ++ if (! MACH_PORT_VALID (bootstrap)) ++ return EINVAL; ++ ++ exec_startup_get_info_args.bootstrap_port = bootstrap; ++ exec_startup_get_info_args.argz = argz; ++ exec_startup_get_info_args.argz_len = argz_len; ++ ++ err = mach_msg_server_timeout_once (exec_startup_get_info_demuxer, ++ 0, bootstrap, ++ MACH_RCV_TIMEOUT|MACH_SEND_TIMEOUT, ++ timeout, &msgh_id); ++ if (err != MACH_MSG_SUCCESS) ++ return err; ++ ++ return 0; ++} ++ ++pointer ++do__handle_exec_startup (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("handle-exec-startup"); ++ SC_ARG (sc, mach_port_t, bootstrap, number, args); ++ SC_ARG (sc, pointer, arguments, list, args); ++ SC_ARG (sc, mach_msg_timeout_t, timeout, number, args); ++ SC_ARGS_DONE (sc); ++ char *argz = NULL; ++ size_t argz_len = 0; ++ ffi_list2argz (sc, &argz, &argz_len, arguments); ++ err = service_exec_startup_request (bootstrap, argz, argz_len, timeout); ++ free (argz); ++ SC_RETURN (sc); ++} +diff --git a/bootshell/ffi.c b/bootshell/ffi.c +new file mode 100644 +index 0000000..8cee903 +--- /dev/null ++++ b/bootshell/ffi.c +@@ -0,0 +1,819 @@ ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++ ++#include "bootshell.h" ++#include "ffi.h" ++ ++#include "startup.h" ++ ++#define is_false(p) ((p) == sc->F) ++ ++pointer ++do_mach_print (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("mach_print"); ++ int dirty = 0; ++ while (args && is_string (pair_car (args))) ++ { ++ const char *v = string_value (pair_car (args)); ++ if (dirty) ++ mach_print (" "); ++ mach_print (v); ++ dirty = 1; ++ args = pair_cdr (args); ++ } ++ SC_RETURN (sc); ++} ++ ++char *rl_gets (const char *prompt); ++ ++pointer ++do__prompt (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("prompt"); ++ SC_ARG (sc, char *, prompt, string, args); ++ SC_ARGS_DONE (sc); ++ const char *line = rl_gets (prompt); ++ ffi_update (sc); ++ SC_RETURN_STRING (sc, line); ++} ++ ++pointer ++do_trace (scheme *sc, pointer args) ++{ ++ sc->tracing = args != sc->NIL && ! is_false (pair_car (args)); ++ return sc->NIL; ++} ++ ++pointer ++do__host_reboot (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("host-reboot"); ++ SC_ARG (sc, mach_port_t, host_priv, number, args); ++ SC_ARG (sc, int, flags, number, args); ++ SC_ARGS_DONE (sc); ++ err = host_reboot (host_priv, flags); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__task_create (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("task-create"); ++ SC_ARG (sc, task_t, parent, number, args); ++ SC_ARG (sc, boolean_t, inherit_memory, number, args); ++ SC_ARGS_DONE (sc); ++ task_t task; ++ err = task_create (parent, inherit_memory, &task); ++ SC_RETURN_INT (sc, task); ++} ++ ++pointer ++do__task_resume (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("task-resume"); ++ SC_ARG (sc, task_t, task, number, args); ++ SC_ARGS_DONE (sc); ++ err = task_resume (task); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__task_terminate (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("task-terminate"); ++ SC_ARG (sc, task_t, task, number, args); ++ SC_ARGS_DONE (sc); ++ err = task_terminate (task); ++ SC_RETURN (sc); ++} ++ ++pointer ++do_sleep (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("sleep"); ++ SC_ARG (sc, unsigned int, seconds, number, args); ++ SC_ARGS_DONE (sc); ++ sleep (seconds); ++ ffi_update (sc); ++ SC_RETURN (sc); ++} ++ ++pointer ++do_usleep (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("usleep"); ++ SC_ARG (sc, useconds_t, microseconds, number, args); ++ SC_ARGS_DONE (sc); ++ usleep (microseconds); ++ ffi_update (sc); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__file_name_lookup (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("file-name-lookup"); ++ SC_ARG (sc, char *, name, string, args); ++ SC_ARG (sc, int, flags, number, args); ++ SC_ARG (sc, mode_t, mode, number, args); ++ SC_ARGS_DONE (sc); ++ file_t file = file_name_lookup (name, flags, mode); ++ if (! MACH_PORT_VALID (file)) ++ SC_RETURN_ERR (sc, errno); ++ SC_RETURN_INT (sc, file); ++} ++ ++pointer ++do__chdir (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("chdir"); ++ SC_ARG (sc, char *, name, string, args); ++ SC_ARGS_DONE (sc); ++ if (chdir (name)) ++ SC_RETURN_ERR (sc, errno); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__strerror (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("strerror"); ++ SC_ARG (sc, int, error, number, args); ++ SC_ARGS_DONE (sc); ++ char *s, buf[128]; ++ s = strerror_r (error, buf, sizeof buf); ++ SC_RETURN_STRING (sc, s); ++} ++ ++pointer ++do__getproc (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("getproc"); ++ SC_ARGS_DONE (sc); ++ SC_RETURN_INT (sc, getproc ()); ++} ++ ++pointer ++do__getcwd (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("getcwd"); ++ SC_ARGS_DONE (sc); ++ SC_RETURN_STRING (sc, get_current_dir_name ()); ++} ++ ++pointer ++do__mach_port_allocate (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("mach-port-allocate"); ++ SC_ARG (sc, task_t, task, number, args); ++ SC_ARG (sc, mach_port_t, right, number, args); ++ SC_ARGS_DONE (sc); ++ mach_port_t name; ++ err = mach_port_allocate (task, right, &name); ++ SC_RETURN_INT (sc, name); ++} ++ ++pointer ++do__mach_port_deallocate (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("mach-port-deallocate"); ++ SC_ARG (sc, task_t, task, number, args); ++ SC_ARG (sc, mach_port_t, right, number, args); ++ SC_ARGS_DONE (sc); ++ err = mach_port_deallocate (task, right); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__mach_port_destroy (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("mach-port-destroy"); ++ SC_ARG (sc, task_t, task, number, args); ++ SC_ARG (sc, mach_port_t, right, number, args); ++ SC_ARGS_DONE (sc); ++ err = mach_port_destroy (task, right); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__mach_port_insert_right (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("mach-port-insert-right"); ++ SC_ARG (sc, task_t, task, number, args); ++ SC_ARG (sc, mach_port_t, name, number, args); ++ SC_ARG (sc, mach_port_t, right, number, args); ++ SC_ARG (sc, mach_msg_type_name_t, right_type, number, args); ++ SC_ARGS_DONE (sc); ++ err = mach_port_insert_right (task, name, right, right_type); ++ SC_RETURN_INT (sc, right); ++} ++ ++pointer ++do__task_get_special_port (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("task-get-special-port"); ++ SC_ARG (sc, task_t, task, number, args); ++ SC_ARG (sc, int, which, number, args); ++ SC_ARGS_DONE (sc); ++ mach_port_t special_port; ++ err = task_get_special_port (task, which, &special_port); ++ SC_RETURN_INT (sc, special_port); ++} ++ ++pointer ++do__task_set_special_port (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("task-set-special-port"); ++ SC_ARG (sc, task_t, task, number, args); ++ SC_ARG (sc, int, which, number, args); ++ SC_ARG (sc, mach_port_t, special_port, number, args); ++ SC_ARGS_DONE (sc); ++ err = task_set_special_port (task, which, special_port); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__device_open (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("device-open"); ++ SC_ARG (sc, mach_port_t, master, number, args); ++ SC_ARG (sc, int, flags, number, args); ++ SC_ARG (sc, char *, name, string, args); ++ SC_ARGS_DONE (sc); ++ mach_port_t device; ++ err = device_open (master, flags, name, &device); ++ SC_RETURN_INT (sc, device); ++} ++ ++/* Hurd functions. */ ++pointer ++do__handle_fsys_startup (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("handle-fsys-startup"); ++ SC_ARG (sc, mach_port_t, bootstrap, number, args); ++ SC_ARG (sc, mach_port_t, realnode, number, args); ++ SC_ARG (sc, mach_msg_type_name_t, realnodePoly, number, args); ++ SC_ARG (sc, mach_msg_timeout_t, timeout, number, args); ++ SC_ARGS_DONE (sc); ++ mach_port_t control; ++ err = service_fsys_request (bootstrap, ++ realnode, ++ realnodePoly, ++ timeout, ++ &control); ++ SC_RETURN_INT (sc, control); ++} ++ ++pointer ++do__bind_root (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("_bind-root"); ++ SC_ARG (sc, mach_port_t, control, number, args); ++ SC_ARG (sc, file_t, dotdot_node, number, args); ++ SC_ARGS_DONE (sc); ++ if (! MACH_PORT_VALID (control) ++ || ! MACH_PORT_VALID (dotdot_node)) ++ SC_RETURN_ERR (sc, EINVAL); ++ ++ if (_hurd_ports) ++ SC_RETURN_ERR (sc, EPERM); /* XXX */ ++ ++ uid_t uids[1] = { 0 }; ++ size_t uids_len = 1; ++ gid_t gids[1] = { 0 }; ++ size_t gids_len = 1; ++ ++ retry_type retry; ++ char retryname[1024]; /* XXX */ ++ file_t root; ++ err = fsys_getroot (control, ++ dotdot_node, ++ MACH_MSG_TYPE_MAKE_SEND, ++ uids, uids_len, ++ gids, gids_len, ++ (O_READ|O_EXEC), ++ &retry, ++ retryname, ++ &root); ++ if (err) ++ SC_RETURN (sc); ++ ++ // XXX check root ++ portarray_template[INIT_PORT_CRDIR] = root; ++ portarray_template[INIT_PORT_CWDIR] = root; ++ ++ err = mach_port_mod_refs (mach_task_self (), ++ root, MACH_PORT_RIGHT_SEND, +2); ++ assert_perror (err); ++ ++ /* We have no portarray or intarray because there was no ++ exec_startup data; _hurd_init was never called. We now have the ++ crucial ports, so create a portarray and call _hurd_init. */ ++ mach_port_t *portarray; ++ portarray = mmap (0, INIT_PORT_MAX * sizeof *portarray, ++ PROT_READ|PROT_WRITE, MAP_ANON, 0, 0); ++ memcpy (portarray, portarray_template, INIT_PORT_MAX * sizeof *portarray); ++ _hurd_init (0, NULL, portarray, INIT_PORT_MAX, NULL, 0); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__bind_proc (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("bind-proc"); ++ SC_ARG (sc, mach_port_t, procserver, number, args); ++ SC_ARGS_DONE (sc); ++ /* Give the library our proc server port. */ ++ _hurd_port_set (&_hurd_ports[INIT_PORT_PROC], procserver); ++ err = mach_port_mod_refs (mach_task_self (), ++ procserver, MACH_PORT_RIGHT_SEND, +1); ++ assert_perror (err); ++ // dealloc ? ++ SC_RETURN (sc); ++} ++ ++pointer ++do__bind_auth (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("bind-auth"); ++ SC_ARG (sc, mach_port_t, authserver, number, args); ++ SC_ARGS_DONE (sc); ++ /* Give the library our auth and proc server ports. */ ++ _hurd_port_set (&_hurd_ports[INIT_PORT_AUTH], authserver); ++ portarray_template[INIT_PORT_AUTH] = authserver; ++ // dealloc ? ++ SC_RETURN (sc); ++} ++ ++pointer ++do__fsys_init (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("fsys-init!"); ++ SC_ARG (sc, mach_port_t, fsys, number, args); ++ SC_ARG (sc, mach_port_t, proc, number, args); ++ SC_ARG (sc, mach_port_t, auth, number, args); ++ SC_ARGS_DONE (sc); ++ err = fsys_init (fsys, proc, MACH_MSG_TYPE_COPY_SEND, auth); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__proc_task2proc (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("proc-task2proc"); ++ SC_ARG (sc, mach_port_t, proc, number, args); ++ SC_ARG (sc, task_t, task, number, args); ++ SC_ARGS_DONE (sc); ++ mach_port_t result; ++ err = proc_task2proc (proc, task, &result); ++ SC_RETURN_INT (sc, result); ++} ++ ++pointer ++do__proc_mark_exec (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("proc-mark-exec!"); ++ SC_ARG (sc, mach_port_t, proc, number, args); ++ SC_ARGS_DONE (sc); ++ err = proc_mark_exec (proc); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__proc_mark_important (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("proc->mark-important!"); ++ SC_ARG (sc, mach_port_t, proc, number, args); ++ SC_ARGS_DONE (sc); ++ err = proc_mark_important (proc); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__proc_child (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("proc->proc->child!"); ++ SC_ARG (sc, mach_port_t, proc, number, args); ++ SC_ARG (sc, mach_port_t, child, number, args); ++ SC_ARGS_DONE (sc); ++ err = proc_child (proc, child); ++ if (err) error (0, err, "proc_child"); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__proc_set_init_task (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("proc->task->set-init-task!"); ++ SC_ARG (sc, mach_port_t, proc, number, args); ++ SC_ARG (sc, mach_port_t, task, number, args); ++ SC_ARGS_DONE (sc); ++ err = proc_set_init_task (proc, task); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__file_set_translator (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("file-set-translator"); ++ SC_ARG (sc, file_t, node, number, args); ++ SC_ARG (sc, int, passive_flags, number, args); ++ SC_ARG (sc, int, active_flags, number, args); ++ SC_ARG (sc, int, goaway_flags, number, args); ++ SC_ARG (sc, int, argz, number, args); //XXX ++ SC_ARG (sc, int, argz_len, number, args); //XXX ++ argz = argz_len = 0; ++ ++ SC_ARG (sc, mach_port_t, active_control, number, args); ++ SC_ARG (sc, mach_msg_type_name_t, active_controlPoly, number, args); ++ SC_ARGS_DONE (sc); ++ err = file_set_translator (node, ++ passive_flags, active_flags, goaway_flags, ++ argz, argz_len, ++ active_control, active_controlPoly); ++ SC_RETURN (sc); ++} ++ ++pointer ++ffi_argz2list (scheme *sc, const char *argz, size_t argz_len, const char *entry) ++{ ++ entry = argz_next (argz, argz_len, entry); ++ if (argz == NULL || argz_len == 0 || entry == NULL) ++ return sc->NIL; ++ return _cons (sc, ++ mk_string (sc, entry), ++ ffi_argz2list (sc, argz, argz_len, entry), ++ 1); ++} ++ ++void ++ffi_list2argz (scheme *sc, char **argz, size_t *argz_len, pointer list) ++{ ++ while (sc->vptr->is_pair (list)) ++ { ++ argz_add (argz, argz_len, string_value (sc->vptr->pair_car (list))); ++ list = sc->vptr->pair_cdr (list); ++ } ++} ++ ++// XXX ++pointer ++do___exec (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("_exec"); ++ process_t proc, child_proc = MACH_PORT_NULL; ++ mach_port_t dtable[STDERR_FILENO+1]; ++ mach_port_t portarray[INIT_PORT_MAX]; ++ int default_ints[INIT_INT_MAX]; ++ char *argz = NULL; ++ size_t argz_len = 0; ++ int i; ++ ++ SC_ARG (sc, file_t, file, number, args); ++ SC_ARG (sc, task_t, task, number, args); ++ SC_ARG (sc, pointer, arguments, list, args); ++ ffi_list2argz (sc, &argz, &argz_len, arguments); ++ SC_ARG (sc, mach_port_t, bootstrap, number, args); ++ SC_ARGS_DONE (sc); ++ ++ proc = getproc (); ++ if (MACH_PORT_VALID (proc)) ++ { ++ err = proc_task2proc (proc, task, &child_proc); ++ if (err) ++ SC_RETURN (sc); ++ } ++ ++ dtable[STDIN_FILENO] = getdport (STDIN_FILENO); ++ dtable[STDOUT_FILENO] = getdport (STDOUT_FILENO); ++ dtable[STDERR_FILENO] = getdport (STDERR_FILENO); ++ ++ memcpy (portarray, portarray_template, INIT_PORT_MAX * sizeof *portarray); ++ portarray[INIT_PORT_CWDIR] = getcwdir (); ++ portarray[INIT_PORT_CRDIR] = getcrdir (); ++ portarray[INIT_PORT_PROC] = child_proc; ++ portarray[INIT_PORT_BOOTSTRAP] = bootstrap; ++ ++ memset (default_ints, 0, INIT_INT_MAX * sizeof *default_ints); ++ /* All programs we start should ignore job control stop signals. ++ That way Posix.1 B.2.2.2 is satisfied where it says that programs ++ not run under job control shells are protected. */ ++ default_ints[INIT_SIGIGN] = (sigmask (SIGTSTP) ++ | sigmask (SIGTTIN) ++ | sigmask (SIGTTOU)); ++ ++ err = task_set_name (task, argz); ++ if (err) ++ { ++ error (0, err, "task_set_name"); ++ goto lose; ++ } ++ ++ err = file_exec (file, task, 0, ++ argz, argz_len, ++ NULL, 0, /* env, env_len */ ++ dtable, MACH_MSG_TYPE_COPY_SEND, 3, ++ portarray, MACH_MSG_TYPE_COPY_SEND, INIT_PORT_MAX, ++ default_ints, INIT_INT_MAX, ++ NULL, 0, NULL, 0); ++ SC_RETURN_INT (sc, task); ++ ++ lose: ++ for (i = 0; i < STDERR_FILENO+1; i++) ++ if (MACH_PORT_VALID (dtable[i])) ++ { ++ error_t err = mach_port_deallocate (mach_task_self (), dtable[i]); ++ assert_perror (err); ++ } ++ for (i = 0; i < INIT_PORT_MAX; i++) ++ if (MACH_PORT_VALID (portarray[i])) ++ { ++ error_t err = mach_port_deallocate (mach_task_self (), portarray[i]); ++ assert_perror (err); ++ } ++ ++ SC_RETURN (sc); ++} ++ ++pointer ++do__file_get_fs_options (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("file-get-fs-options"); ++ SC_ARG (sc, file_t, node, number, args); ++ SC_ARGS_DONE (sc); ++ char *argz = NULL; ++ size_t argz_len = 0; ++ pointer result; ++ err = file_get_fs_options (node, &argz, &argz_len); ++ if (err) ++ SC_RETURN (sc); ++ result = ffi_argz2list (sc, argz, argz_len, NULL); ++ vm_deallocate (mach_task_self (), (vm_address_t) argz, argz_len); ++ SC_RETURN_POINTER (sc, result); ++} ++ ++const char * ++schemify_name (const char *s, int macro) ++{ ++ char *n = strdup (s), *p; ++ if (n == NULL) ++ return s; ++ for (p = n; *p; p++) ++ { ++ *p = (char) tolower (*p); ++ /* We convert _ to - in identifiers. We allow, however, for ++ function names to start with a leading _. The functions in ++ this namespace are not yet finalized and might change or ++ vanish without warning. Use them with care. */ ++ if (! macro ++ && p != n ++ && *p == '_') ++ *p = '-'; ++ } ++ return n; ++} ++ ++void ++ffi_update (scheme *sc) ++{ ++ // XXX nothng ++} ++ ++void ++ffi_init (scheme *sc) ++{ ++ define_constant (sc, MACH_PORT_NULL); ++ define_constant (sc, MACH_PORT_DEAD); // XXX signedness ++ ++ define_constant (sc, MACH_MSG_TYPE_UNSTRUCTURED); ++ define_constant (sc, MACH_MSG_TYPE_BIT); ++ define_constant (sc, MACH_MSG_TYPE_BOOLEAN); ++ define_constant (sc, MACH_MSG_TYPE_INTEGER_16); ++ define_constant (sc, MACH_MSG_TYPE_INTEGER_32); ++ define_constant (sc, MACH_MSG_TYPE_CHAR); ++ define_constant (sc, MACH_MSG_TYPE_BYTE); ++ define_constant (sc, MACH_MSG_TYPE_INTEGER_8); ++ define_constant (sc, MACH_MSG_TYPE_REAL); ++ define_constant (sc, MACH_MSG_TYPE_INTEGER_64); ++ define_constant (sc, MACH_MSG_TYPE_STRING); ++ define_constant (sc, MACH_MSG_TYPE_STRING_C); ++ define_constant (sc, MACH_MSG_TYPE_MOVE_RECEIVE); ++ define_constant (sc, MACH_MSG_TYPE_MOVE_SEND); ++ define_constant (sc, MACH_MSG_TYPE_MOVE_SEND_ONCE); ++ define_constant (sc, MACH_MSG_TYPE_COPY_SEND); ++ define_constant (sc, MACH_MSG_TYPE_MAKE_SEND); ++ define_constant (sc, MACH_MSG_TYPE_MAKE_SEND_ONCE); ++ define_constant (sc, MACH_MSG_TYPE_PORT_NAME); ++ define_constant (sc, MACH_MSG_TYPE_PORT_RECEIVE); ++ define_constant (sc, MACH_MSG_TYPE_PORT_SEND); ++ define_constant (sc, MACH_MSG_TYPE_PORT_SEND_ONCE); ++ define_constant (sc, MACH_MSG_TYPE_PROTECTED_PAYLOAD); ++ define_constant (sc, MACH_MSG_TYPE_LAST); ++ define_constant (sc, MACH_MSG_TYPE_POLYMORPHIC); ++ ++ define_constant (sc, MACH_PORT_RIGHT_SEND); ++ define_constant (sc, MACH_PORT_RIGHT_RECEIVE); ++ define_constant (sc, MACH_PORT_RIGHT_SEND_ONCE); ++ define_constant (sc, MACH_PORT_RIGHT_PORT_SET); ++ define_constant (sc, MACH_PORT_RIGHT_DEAD_NAME); ++ define_constant (sc, MACH_PORT_RIGHT_NUMBER); ++ ++ define_constant (sc, KERN_SUCCESS); ++ define_constant (sc, KERN_INVALID_ADDRESS); ++ define_constant (sc, KERN_PROTECTION_FAILURE); ++ define_constant (sc, KERN_NO_SPACE); ++ define_constant (sc, KERN_INVALID_ARGUMENT); ++ define_constant (sc, KERN_FAILURE); ++ define_constant (sc, KERN_RESOURCE_SHORTAGE); ++ define_constant (sc, KERN_NOT_RECEIVER); ++ define_constant (sc, KERN_NO_ACCESS); ++ define_constant (sc, KERN_MEMORY_FAILURE); ++ define_constant (sc, KERN_MEMORY_ERROR); ++ define_constant (sc, KERN_NOT_IN_SET); ++ define_constant (sc, KERN_NAME_EXISTS); ++ define_constant (sc, KERN_ABORTED); ++ define_constant (sc, KERN_INVALID_NAME); ++ define_constant (sc, KERN_INVALID_TASK); ++ define_constant (sc, KERN_INVALID_RIGHT); ++ define_constant (sc, KERN_INVALID_VALUE); ++ define_constant (sc, KERN_UREFS_OVERFLOW); ++ define_constant (sc, KERN_INVALID_CAPABILITY); ++ define_constant (sc, KERN_RIGHT_EXISTS); ++ define_constant (sc, KERN_INVALID_HOST); ++ define_constant (sc, KERN_MEMORY_PRESENT); ++ define_constant (sc, KERN_WRITE_PROTECTION_FAILURE); ++ define_constant (sc, KERN_TERMINATED); ++ define_constant (sc, MACH_MSG_SUCCESS); ++ define_constant (sc, MACH_MSG_MASK); ++ define_constant (sc, MACH_MSG_IPC_SPACE); ++ define_constant (sc, MACH_MSG_VM_SPACE); ++ define_constant (sc, MACH_MSG_IPC_KERNEL); ++ define_constant (sc, MACH_MSG_VM_KERNEL); ++ define_constant (sc, MACH_SEND_IN_PROGRESS); ++ define_constant (sc, MACH_SEND_INVALID_DATA); ++ define_constant (sc, MACH_SEND_INVALID_DEST); ++ define_constant (sc, MACH_SEND_TIMED_OUT); ++ define_constant (sc, MACH_SEND_WILL_NOTIFY); ++ define_constant (sc, MACH_SEND_NOTIFY_IN_PROGRESS); ++ define_constant (sc, MACH_SEND_INTERRUPTED); ++ define_constant (sc, MACH_SEND_MSG_TOO_SMALL); ++ define_constant (sc, MACH_SEND_INVALID_REPLY); ++ define_constant (sc, MACH_SEND_INVALID_RIGHT); ++ define_constant (sc, MACH_SEND_INVALID_NOTIFY); ++ define_constant (sc, MACH_SEND_INVALID_MEMORY); ++ define_constant (sc, MACH_SEND_NO_BUFFER); ++ define_constant (sc, MACH_SEND_NO_NOTIFY); ++ define_constant (sc, MACH_SEND_INVALID_TYPE); ++ define_constant (sc, MACH_SEND_INVALID_HEADER); ++ define_constant (sc, MACH_RCV_IN_PROGRESS); ++ define_constant (sc, MACH_RCV_INVALID_NAME); ++ define_constant (sc, MACH_RCV_TIMED_OUT); ++ define_constant (sc, MACH_RCV_TOO_LARGE); ++ define_constant (sc, MACH_RCV_INTERRUPTED); ++ define_constant (sc, MACH_RCV_PORT_CHANGED); ++ define_constant (sc, MACH_RCV_INVALID_NOTIFY); ++ define_constant (sc, MACH_RCV_INVALID_DATA); ++ define_constant (sc, MACH_RCV_PORT_DIED); ++ define_constant (sc, MACH_RCV_IN_SET); ++ define_constant (sc, MACH_RCV_HEADER_ERROR); ++ define_constant (sc, MACH_RCV_BODY_ERROR); ++ ++ define_constant (sc, TASK_KERNEL_PORT); ++ define_constant (sc, TASK_EXCEPTION_PORT); ++ define_constant (sc, TASK_BOOTSTRAP_PORT); ++ ++ define_constant (sc, RB_DEBUGGER); ++ define_constant (sc, RB_HALT); ++ define_constant (sc, RB_AUTOBOOT); ++ ++ define_ (sc, "mach-task-self", mk_integer (sc, mach_task_self ())); ++ ++ define_ffi_function (sc, "mach-port-allocate", _mach_port_allocate); ++ define_ffi_function (sc, "mach-port-deallocate", _mach_port_deallocate); ++ define_ffi_function (sc, "mach-port-destroy", _mach_port_destroy); ++ //define_function (sc, mach_port_get_refs); ++ //define_function (sc, mach_port_mod_refs); ++ define_ffi_function (sc, "mach-port-insert-right", _mach_port_insert_right); ++ //define_function (sc, mach_port_extract_right); ++ ++ define_function (sc, mach_print); ++ define_ffi_function (sc, "task-create", _task_create); ++ define_ffi_function (sc, "task-resume", _task_resume); ++ define_ffi_function (sc, "task-terminate", _task_terminate); ++ define_ffi_function (sc, "task-get-special-port", _task_get_special_port); ++ define_ffi_function (sc, "task-set-special-port", _task_set_special_port); ++ define_ffi_function (sc, "host-reboot", _host_reboot); ++ ++ /* Device protocol. */ ++ define_constant (sc, D_READ); ++ define_constant (sc, D_WRITE); ++ define_ffi_function (sc, "device-open", _device_open); ++ ++ /* Hurd stuff. */ ++ define_constant (sc, EXEC_NEWTASK); ++ define_constant (sc, EXEC_SECURE); ++ define_constant (sc, EXEC_DEFAULTS); ++ define_constant (sc, EXEC_SIGTRAP); ++ define_constant (sc, EXEC_STACK_ARGS); ++ define_constant (sc, FS_TRANS_FORCE); ++ define_constant (sc, FS_TRANS_EXCL); ++ define_constant (sc, FS_TRANS_SET); ++ define_constant (sc, FS_TRANS_ORPHAN); ++ define_constant (sc, FS_RETRY_NORMAL); ++ define_constant (sc, FS_RETRY_REAUTH); ++ define_constant (sc, FS_RETRY_MAGICAL); ++ define_constant (sc, FSYS_GOAWAY_NOWAIT); ++ define_constant (sc, FSYS_GOAWAY_NOSYNC); ++ define_constant (sc, FSYS_GOAWAY_FORCE); ++ define_constant (sc, FSYS_GOAWAY_UNLINK); ++ define_constant (sc, FSYS_GOAWAY_RECURSE); ++ define_constant (sc, INIT_PORT_CWDIR); ++ define_constant (sc, INIT_PORT_CRDIR); ++ define_constant (sc, INIT_PORT_AUTH); ++ define_constant (sc, INIT_PORT_PROC); ++ define_constant (sc, INIT_PORT_CTTYID); ++ define_constant (sc, INIT_PORT_BOOTSTRAP); ++ define_constant (sc, INIT_PORT_MAX); ++ define_constant (sc, INIT_UMASK); ++ define_constant (sc, INIT_SIGMASK); ++ define_constant (sc, INIT_SIGIGN); ++ define_constant (sc, INIT_SIGPENDING); ++ define_constant (sc, INIT_TRACEMASK); ++ define_constant (sc, INIT_INT_MAX); ++ ++ define_constant (sc, O_RDONLY); ++ define_constant (sc, O_WRONLY); ++ define_constant (sc, O_RDWR); ++ define_constant (sc, O_EXEC); ++ define_constant (sc, O_CREAT); ++ define_constant (sc, O_NOTRANS); ++ ++ define_variable (sc, exception_port); ++ define_variable (sc, rootnode); ++ ++ define_function (sc, trace); ++ define_ffi_function (sc, "prompt", _prompt); ++ ++ /* glibc. */ ++ define_function (sc, sleep); ++ define_function (sc, usleep); ++ define_ffi_function (sc, "getcwd", _getcwd); ++ define_ffi_function (sc, "chdir", _chdir); ++ define_ffi_function (sc, "strerror", _strerror); ++ define_ffi_function (sc, "getproc", _getproc); ++ ++ /* Boot process */ ++ define_ffi_function (sc, "bind-root", _bind_root); ++ define_ffi_function (sc, "bind-proc", _bind_proc); ++ define_ffi_function (sc, "bind-auth", _bind_auth); ++ define_ffi_function (sc, "fsys-init", _fsys_init); ++ ++ /* Early bootstrap protocols. */ ++ define_ffi_function (sc, "handle-startup-procinit", _handle_startup_procinit); ++ define_ffi_function (sc, "handle-startup-authinit", _handle_startup_authinit); ++ define_ffi_function (sc, "startup-procinit-reply", _startup_procinit_reply); ++ define_ffi_function (sc, "startup-authinit-reply", _startup_authinit_reply); ++ ++ define_ffi_function (sc, "startup-essential-task", _startup_essential_task); ++ define_ffi_function (sc, "startup-request-notification", ++ _startup_request_notification); ++ define_ffi_function (sc, "startup-reboot", _startup_reboot); ++ ++ /* Process and translator startup. */ ++ define_ffi_function (sc, "handle-exec-startup", _handle_exec_startup); ++ define_ffi_function (sc, "handle-fsys-startup", _handle_fsys_startup); ++ ++ /* Hurd fs API */ ++ define_ffi_function (sc, "file-name-lookup", _file_name_lookup); ++ define_ffi_function (sc, "file-set-translator", _file_set_translator); ++ define_ffi_function (sc, "file-get-fs-options", _file_get_fs_options); ++ ++ /* Hurd process API */ ++ define_ffi_function (sc, "proc->task->proc", _proc_task2proc); ++ define_ffi_function (sc, "proc->mark-important!", _proc_mark_important); ++ define_ffi_function (sc, "proc->mark-exec!", _proc_mark_exec); ++ define_ffi_function (sc, "proc->task->child!", _proc_child); ++ define_ffi_function (sc, "proc->task->set-init-task!", _proc_set_init_task); ++ ++ /* Hurd hacks. */ ++ define_ffi_function (sc, "_exec", __exec); ++ define_ffi_function (sc, "start-handling-early-startup", ++ _start_handling_early_startup); ++ define_ffi_function (sc, "get-essential-tasks", _get_essential_tasks); ++ define_ffi_function (sc, "get-registered-tasks", _get_registered_tasks); ++ ffi_update (sc); ++} +diff --git a/bootshell/ffi.h b/bootshell/ffi.h +new file mode 100644 +index 0000000..b1b3f97 +--- /dev/null ++++ b/bootshell/ffi.h +@@ -0,0 +1,130 @@ ++#ifndef _HURD_BOOTSHELL_FFI_H ++#define _HURD_BOOTSHELL_FFI_H ++ ++#include ++#include ++ ++#include "scheme.h" ++#include "scheme-private.h" ++ ++#define SC_FFI_PROLOG(NAME) \ ++ const char *__ffi_name __attribute__ ((unused)) = NAME; \ ++ unsigned int __ffi_arg_index __attribute__ ((unused)) = 1; \ ++ error_t err = 0; \ ++ ++#define CONVERSION_number ivalue ++#define CONVERSION_string string_value ++#define CONVERSION_list ++#define IS_A_number(SC, X) (SC)->vptr->is_number (X) ++#define IS_A_string(SC, X) (SC)->vptr->is_string (X) ++#define IS_A_list(SC, X) (SC)->vptr->is_list (SC, X) ++ ++#define SC_ARG(SC, CTYPE, TARGET, WANT, ARGS) \ ++ if ((ARGS) == (SC)->NIL) { \ ++ fprintf (stderr, "Error: %s: too few arguments: " \ ++ "want " #TARGET "("#WANT"/"#CTYPE")\n", __ffi_name); \ ++ return (SC)->NIL; \ ++ } \ ++ if (! IS_A_##WANT ((SC), pair_car (ARGS))) { \ ++ fprintf (stderr, "Error: %s: argument %d must be: " \ ++ #WANT "\n", __ffi_name, __ffi_arg_index++); \ ++ return (SC)->NIL; \ ++ } \ ++ CTYPE TARGET = CONVERSION_##WANT (pair_car (ARGS)); \ ++ ARGS = pair_cdr (ARGS); \ ++ ++#define SC_ARGS_DONE(SC) \ ++ /* XXX */ ++ ++#define SC_RETURN_ERR(SC, ERR) \ ++ return _cons ((SC), mk_integer ((SC), (ERR)), (SC)->NIL, 1) ++ ++#define SC_RETURN(SC) SC_RETURN_ERR (SC, err) ++ ++#define SC_RETURN_POINTER(SC, X) \ ++ return _cons ((SC), mk_integer ((SC), err), \ ++ _cons ((SC), (X), (SC)->NIL, 1), 1) ++#define SC_RETURN_INT(SC, X) \ ++ SC_RETURN_POINTER ((SC), mk_integer ((SC), (X))) ++#define SC_RETURN_STRING(SC, X) \ ++ SC_RETURN_POINTER ((SC), mk_string ((SC), (X))) ++ ++#define define_function(S, F) \ ++ scheme_define ((S), \ ++ (S)->global_env, \ ++ mk_symbol ((S), schemify_name (#F, 0)), \ ++ mk_foreign_func ((S), (do_##F))) ++ ++#define define_ffi_function(S, P, F) \ ++ ({ \ ++ char _sc_buf[256]; \ ++ define_function (S, F); \ ++ snprintf (_sc_buf, sizeof _sc_buf, \ ++ "(define (%1$s . a) (ffi-apply \"%1$s\" %2$s a))", \ ++ P, schemify_name (#F, 0)); \ ++ scheme_load_string (S, _sc_buf); \ ++ }) ++ ++#define define_constant(S, C) \ ++ scheme_define ((S), \ ++ (S)->global_env, \ ++ mk_symbol ((S), schemify_name (#C, 1)), \ ++ mk_integer ((S), (C))) ++ ++#define define_(S, SYM, EXP) \ ++ scheme_define ((S), (S)->global_env, mk_symbol ((S), (SYM)), EXP) ++ ++#define define_variable(S, C) \ ++ scheme_define ((S), \ ++ (S)->global_env, \ ++ mk_symbol ((S), schemify_name (#C, 0)), \ ++ mk_integer ((S), (C))) ++ ++#define define_variable_pointer(S, C, P) \ ++ scheme_define ((S), \ ++ (S)->global_env, \ ++ mk_symbol ((S), schemify_name (#C, 0)), \ ++ (P)) ++ ++#define define_variable_string(S, C) \ ++ define_variable_pointer (S, C, (S)->vptr->mk_string (S, C ?: "")) ++ ++/* A variant of scheme_load_string that does not require the string to ++ be zero-terminated. */ ++void scheme_load_mem (scheme *, const char *, const char *); ++ ++#define declare_embedded_script(X) \ ++ extern char X##_start[] asm("_binary_"#X"_start"); \ ++ extern char X##_end[] asm("_binary_"#X"_end") ++ ++#define load_embedded_script(S, X) \ ++ ({ \ ++ scheme_load_mem ((S), X##_start, X##_end); \ ++ if ((S)->retcode != 0) \ ++ fprintf (stderr, "Errors encountered evaluating %s\n", #X); \ ++ }) ++ ++declare_embedded_script (init_scm); ++declare_embedded_script (boot_scm); ++declare_embedded_script (runsystem_scm); ++ ++void ffi_update (scheme *sc); ++void ffi_init (scheme *sc); ++ ++pointer ffi_argz2list (scheme *sc, ++ const char *argz, size_t argz_len, const char *entry); ++void ffi_list2argz (scheme *sc, char **argz, size_t *argz_len, pointer list); ++ ++// XXX ++error_t service_fsys_request (mach_port_t bootstrap, ++ mach_port_t realnode, ++ mach_msg_type_name_t realnodePoly, ++ mach_msg_timeout_t timeout, ++ mach_port_t *control); ++ ++/* Forward declarations. */ ++ ++/* exec-startup.c */ ++pointer do__handle_exec_startup (scheme *sc, pointer args); ++ ++#endif /* _HURD_BOOTSHELL_FFI_H */ +diff --git a/bootshell/fs.c b/bootshell/fs.c +new file mode 100644 +index 0000000..3c8deb3 +--- /dev/null ++++ b/bootshell/fs.c +@@ -0,0 +1,91 @@ ++#include ++#include ++#include ++#include ++#include ++#include ++ ++// eek #include "fs_S.h" ++ ++#include "bootshell.h" ++ ++mach_port_t rootnode; ++ ++/* A top-level function for the paging thread that just services paging ++ requests. */ ++static void * ++service_fs_requests (void *arg) ++{ ++ extern boolean_t fs_server (); ++ ++ int trace_demuxer (mach_msg_header_t *inp, ++ mach_msg_header_t *outp) ++ { ++ error (0, 0, "(fs-server: %d)", inp->msgh_id); ++ int i = fs_server (inp, outp); ++ return i; ++ } ++ ++ while (1) ++ mach_msg_server (0? trace_demuxer: fs_server, 0, rootnode); ++ ++ /* Not reached. */ ++ return NULL; ++} ++ ++error_t ++init_fs_server (void) ++{ ++ error_t err; ++ pthread_t t; ++ ++ err = mach_port_allocate (mach_task_self (), ++ MACH_PORT_RIGHT_RECEIVE, ++ &rootnode); ++ if (err) ++ return err; ++ ++ /* Make a thread to service the fs protocol. */ ++ err = pthread_create (&t, NULL, service_fs_requests, NULL); ++ if (err) ++ return err; ++ pthread_detach (t); ++ ++ err = mach_port_insert_right (mach_task_self (), ++ rootnode, ++ rootnode, ++ MACH_MSG_TYPE_MAKE_SEND); ++ if (err) ++ return err; ++ ++ setcrdir (rootnode); // XXX do we want this? not sure what for tbh. ++ setcwdir (rootnode); ++ portarray_template[INIT_PORT_CRDIR] = rootnode; ++ portarray_template[INIT_PORT_CWDIR] = rootnode; ++ ++ return err; ++} ++ ++error_t ++S_dir_lookup (file_t file, ++ char *path, ++ int flags, ++ mode_t mode, ++ enum retry_type *retry, ++ char *retryname, ++ file_t *returned_port, ++ mach_msg_type_name_t *returned_port_poly) ++{ ++ if (file != rootnode) ++ return EOPNOTSUPP; ++ ++ if (portarray_template[INIT_PORT_CRDIR] == rootnode) ++ /* Still no root filesystem. */ ++ return EOPNOTSUPP; ++ ++ *retry = FS_RETRY_NORMAL; ++ strncpy (retryname, path, sizeof (string_t)); ++ *returned_port = portarray_template[INIT_PORT_CRDIR]; ++ *returned_port_poly = MACH_MSG_TYPE_COPY_SEND; ++ return 0; ++} +diff --git a/bootshell/fsys.c b/bootshell/fsys.c +new file mode 100644 +index 0000000..3c5afa2 +--- /dev/null ++++ b/bootshell/fsys.c +@@ -0,0 +1,74 @@ ++#include ++#include ++#include ++#include ++#include ++ ++// eek #include "fsys_S.h" ++ ++#include "bootshell.h" ++ ++/* XXX would be nice not to use a global variable, maybe with ++ payloads. */ ++static struct ++{ ++ /* Filled by caller. */ ++ mach_port_t bootstrap_port; ++ mach_port_t realnode; ++ mach_msg_type_name_t realnodePoly; ++ ++ /* Filled by the server function. */ ++ mach_port_t control_port; ++} fsys_startup_args; ++ ++error_t ++S_fsys_startup (mach_port_t bootstrap, ++ int openflags, ++ mach_port_t control_port, ++ mach_port_t *realnode, ++ mach_msg_type_name_t *realnodePoly) ++{ ++ assert (MACH_PORT_VALID (fsys_startup_args.bootstrap_port)); ++ if (bootstrap != fsys_startup_args.bootstrap_port) ++ return EOPNOTSUPP; ++ ++ fsys_startup_args.control_port = control_port; ++ *realnode = fsys_startup_args.realnode; ++ *realnodePoly = fsys_startup_args.realnodePoly; ++ return 0; ++} ++ ++error_t ++service_fsys_request (mach_port_t bootstrap, ++ mach_port_t realnode, ++ mach_msg_type_name_t realnodePoly, ++ mach_msg_timeout_t timeout, ++ mach_port_t *control) ++{ ++ error_t err; ++ extern boolean_t fsys_server (); ++ mach_msg_id_t msgh_id; ++ ++ if (! MACH_PORT_VALID (bootstrap)) ++ return EINVAL; ++ ++ fsys_startup_args.bootstrap_port = bootstrap; ++ fsys_startup_args.realnode = realnode; ++ fsys_startup_args.realnodePoly = realnodePoly; ++ fsys_startup_args.control_port = MACH_PORT_NULL; ++ ++ err = mach_msg_server_timeout_once (fsys_server, 0, bootstrap, ++ MACH_RCV_TIMEOUT|MACH_SEND_TIMEOUT, ++ timeout, &msgh_id); ++ if (err != MACH_MSG_SUCCESS) ++ return err; ++ ++ if (msgh_id != 22000) ++ { ++ fprintf (stderr, " (XXy:%d)", msgh_id); //XXX ++ return EINVAL; ++ } ++ ++ *control = fsys_startup_args.control_port; ++ return 0; ++} +diff --git a/bootshell/hack.txt b/bootshell/hack.txt +new file mode 100644 +index 0000000..f3ee648 +--- /dev/null ++++ b/bootshell/hack.txt +@@ -0,0 +1,244 @@ ++ ++ How to hack TinyScheme ++ ---------------------- ++ ++ TinyScheme is easy to learn and modify. It is structured like a ++ meta-interpreter, only it is written in C. All data are Scheme ++ objects, which facilitates both understanding/modifying the ++ code and reifying the interpreter workings. ++ ++ In place of a dry description, we will pace through the addition ++ of a useful new datatype: garbage-collected memory blocks. ++ The interface will be: ++ ++ (make-block []) makes a new block of the specified size ++ optionally filling it with a specified byte ++ (block? ) ++ (block-length ) ++ (block-ref ) retrieves byte at location ++ (block-set! ) modifies byte at location ++ ++ In the sequel, lines that begin with '>' denote lines to add to the ++ code. Lines that begin with '|' are just citations of existing code. ++ Lines that begin with X denote lines to be removed from the code. ++ ++ First of all, we need to assign a typeid to our new type. Typeids ++ in TinyScheme are small integers declared in the scheme_types enum ++ located near the top of the scheme.c file; it begins with T_STRING. ++ Add a new entry at the end, say T_MEMBLOCK. Remember to adjust the ++ value of T_LAST_SYTEM_TYPE when adding new entries. There can be at ++ most 31 types, but you don't have to worry about that limit yet. ++ ++| T_ENVIRONMENT=14, ++X T_LAST_SYSTEM_TYPE=14 ++> T_MEMBLOCK=15, ++> T_LAST_SYSTEM_TYPE=15 ++| }; ++ ++ ++ Then, some helper macros would be useful. Go to where is_string() ++ and the rest are defined and add: ++ ++> INTERFACE INLINE int is_memblock(pointer p) { return (type(p)==T_MEMBLOCK); } ++ ++ This actually is a function, because it is meant to be exported by ++ scheme.h. If no foreign function will ever manipulate a memory block, ++ you can instead define it as a macro: ++ ++> #define is_memblock(p) (type(p)==T_MEMBLOCK) ++ ++ Then we make space for the new type in the main data structure: ++ struct cell. As it happens, the _string part of the union _object ++ (that is used to hold character strings) has two fields that suit us: ++ ++| struct { ++| char *_svalue; ++| int _keynum; ++| } _string; ++ ++ We can use _svalue to hold the actual pointer and _keynum to hold its ++ length. If we couln't reuse existing fields, we could always add other ++ alternatives in union _object. ++ ++ We then proceed to write the function that actually makes a new block. ++ For conformance reasons, we name it mk_memblock ++ ++> static pointer mk_memblock(scheme *sc, int len, char fill) { ++> pointer x; ++> char *p=(char*)sc->malloc(len); ++> ++> if(p==0) { ++> return sc->NIL; ++> } ++> x = get_cell(sc, sc->NIL, sc->NIL); ++> ++> typeflag(x) = T_MEMBLOCK|T_ATOM; ++> strvalue(x)=p; ++> keynum(x)=len; ++> memset(p,fill,len); ++> return (x); ++> } ++ ++ The memory used by the MEMBLOCK will have to be freed when the cell ++ is reclaimed during garbage collection. There is a placeholder for ++ that staff, function finalize_cell(), currently handling strings only. ++ ++| static void finalize_cell(scheme *sc, pointer a) { ++| if(is_string(a)) { ++| sc->free(strvalue(a)); ++> } else if(is_memblock(a)) { ++> sc->free(strvalue(a)); ++| } else if(is_port(a)) { ++ ++ There are no MEMBLOCK literals, so we don't concern ourselves with ++ the READER part (yet!). We must cater to the PRINTER, though. We ++ add one case more in atom2str(). ++ ++| } else if (iscontinuation(l)) { ++| p = "#"; ++> } else if (is_memblock(l)) { ++> p = "#"; ++| } else { ++ ++ Whenever a MEMBLOCK is displayed, it will look like that. ++ Now, we must add the interface functions: constructor, predicate, ++ accessor, modifier. We must in fact create new op-codes for the virtual ++ machine underlying TinyScheme. Since version 1.30, TinyScheme uses ++ macros and a single source text to keep the enums and the dispatch table ++ in sync. The op-codes are defined in the opdefines.h file with one line ++ for each op-code. The lines in the file have six columns between the ++ starting _OPDEF( and ending ): A, B, C, D, E, and OP. ++ Note that this file uses unusually long lines to accomodate all the ++ information; adjust your editor to handle this. ++ ++ The purpose of the columns is: ++ - Column A is the name of the subroutine that handles the op-code. ++ - Column B is the name of the op-code function. ++ - Columns C and D are the minimum and maximum number of arguments ++ that are accepted by the op-code. ++ - Column E is a set of flags that tells the interpreter the type of ++ each of the arguments expected by the op-code. ++ - Column OP is used in the scheme_opcodes enum located in the ++ scheme-private.h file. ++ ++ Op-codes are really just tags for a huge C switch, only this switch ++ is broken up in to a number of different opexe_X functions. The ++ correspondence is made in table "dispatch_table". There, we assign ++ the new op-codes to opexe_2, where the equivalent ones for vectors ++ are situated. We also assign a name for them, and specify the minimum ++ and maximum arity (number of expected arguments). INF_ARG as a maximum ++ arity means "unlimited". ++ ++ For reasons of consistency, we add the new op-codes right after those ++ for vectors: ++ ++| _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) ++> _OP_DEF(opexe_2, "make-block", 1, 2, TST_NATURAL TST_CHAR, OP_MKBLOCK ) ++> _OP_DEF(opexe_2, "block-length", 1, 1, T_MEMBLOCK, OP_BLOCKLEN ) ++> _OP_DEF(opexe_2, "block-ref", 2, 2, T_MEMBLOCK TST_NATURAL, OP_BLOCKREF ) ++> _OP_DEF(opexe_2, "block-set!", 1, 1, T_MEMBLOCK TST_NATURAL TST_CHAR, OP_BLOCKSET ) ++| _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT ) ++ ++ We add the predicate along with the other predicates in opexe_3: ++ ++| _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP ) ++> _OP_DEF(opexe_3, "block?", 1, 1, TST_ANY, OP_BLOCKP ) ++| _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ ) ++ ++ All that remains is to write the actual code to do the processing and ++ add it to the switch statement in opexe_2, after the OP_VECSET case. ++ ++> case OP_MKBLOCK: { /* make-block */ ++> int fill=0; ++> int len; ++> ++> if(!isnumber(car(sc->args))) { ++> Error_1(sc,"make-block: not a number:",car(sc->args)); ++> } ++> len=ivalue(car(sc->args)); ++> if(len<=0) { ++> Error_1(sc,"make-block: not positive:",car(sc->args)); ++> } ++> ++> if(cdr(sc->args)!=sc->NIL) { ++> if(!isnumber(cadr(sc->args)) || ivalue(cadr(sc->args))<0) { ++> Error_1(sc,"make-block: not a positive number:",cadr(sc->args)); ++> } ++> fill=charvalue(cadr(sc->args))%255; ++> } ++> s_return(sc,mk_memblock(sc,len,(char)fill)); ++> } ++> ++> case OP_BLOCKLEN: /* block-length */ ++> if(!ismemblock(car(sc->args))) { ++> Error_1(sc,"block-length: not a memory block:",car(sc->args)); ++> } ++> s_return(sc,mk_integer(sc,keynum(car(sc->args)))); ++> ++> case OP_BLOCKREF: { /* block-ref */ ++> char *str; ++> int index; ++> ++> if(!ismemblock(car(sc->args))) { ++> Error_1(sc,"block-ref: not a memory block:",car(sc->args)); ++> } ++> str=strvalue(car(sc->args)); ++> ++> if(cdr(sc->args)==sc->NIL) { ++> Error_0(sc,"block-ref: needs two arguments"); ++> } ++> if(!isnumber(cadr(sc->args))) { ++> Error_1(sc,"block-ref: not a number:",cadr(sc->args)); ++> } ++> index=ivalue(cadr(sc->args)); ++> ++> if(index<0 || index>=keynum(car(sc->args))) { ++> Error_1(sc,"block-ref: out of bounds:",cadr(sc->args)); ++> } ++> ++> s_return(sc,mk_integer(sc,str[index])); ++> } ++> ++> case OP_BLOCKSET: { /* block-set! */ ++> char *str; ++> int index; ++> int c; ++> ++> if(!ismemblock(car(sc->args))) { ++> Error_1(sc,"block-set!: not a memory block:",car(sc->args)); ++> } ++> if(isimmutable(car(sc->args))) { ++> Error_1(sc,"block-set!: unable to alter immutable memory block:",car(sc->args)); ++> } ++> str=strvalue(car(sc->args)); ++> ++> if(cdr(sc->args)==sc->NIL) { ++> Error_0(sc,"block-set!: needs three arguments"); ++> } ++> if(!isnumber(cadr(sc->args))) { ++> Error_1(sc,"block-set!: not a number:",cadr(sc->args)); ++> } ++> index=ivalue(cadr(sc->args)); ++> if(index<0 || index>=keynum(car(sc->args))) { ++> Error_1(sc,"block-set!: out of bounds:",cadr(sc->args)); ++> } ++> ++> if(cddr(sc->args)==sc->NIL) { ++> Error_0(sc,"block-set!: needs three arguments"); ++> } ++> if(!isinteger(caddr(sc->args))) { ++> Error_1(sc,"block-set!: not an integer:",caddr(sc->args)); ++> } ++> c=ivalue(caddr(sc->args))%255; ++> ++> str[index]=(char)c; ++> s_return(sc,car(sc->args)); ++> } ++ ++ Finally, do the same for the predicate in opexe_3. ++ ++| case OP_VECTORP: /* vector? */ ++| s_retbool(is_vector(car(sc->args))); ++> case OP_BLOCKP: /* block? */ ++> s_retbool(is_memblock(car(sc->args))); ++| case OP_EQ: /* eq? */ +diff --git a/bootshell/init.scm b/bootshell/init.scm +new file mode 100644 +index 0000000..223e421 +--- /dev/null ++++ b/bootshell/init.scm +@@ -0,0 +1,716 @@ ++; Initialization file for TinySCHEME 1.41 ++ ++; Per R5RS, up to four deep compositions should be defined ++(define (caar x) (car (car x))) ++(define (cadr x) (car (cdr x))) ++(define (cdar x) (cdr (car x))) ++(define (cddr x) (cdr (cdr x))) ++(define (caaar x) (car (car (car x)))) ++(define (caadr x) (car (car (cdr x)))) ++(define (cadar x) (car (cdr (car x)))) ++(define (caddr x) (car (cdr (cdr x)))) ++(define (cdaar x) (cdr (car (car x)))) ++(define (cdadr x) (cdr (car (cdr x)))) ++(define (cddar x) (cdr (cdr (car x)))) ++(define (cdddr x) (cdr (cdr (cdr x)))) ++(define (caaaar x) (car (car (car (car x))))) ++(define (caaadr x) (car (car (car (cdr x))))) ++(define (caadar x) (car (car (cdr (car x))))) ++(define (caaddr x) (car (car (cdr (cdr x))))) ++(define (cadaar x) (car (cdr (car (car x))))) ++(define (cadadr x) (car (cdr (car (cdr x))))) ++(define (caddar x) (car (cdr (cdr (car x))))) ++(define (cadddr x) (car (cdr (cdr (cdr x))))) ++(define (cdaaar x) (cdr (car (car (car x))))) ++(define (cdaadr x) (cdr (car (car (cdr x))))) ++(define (cdadar x) (cdr (car (cdr (car x))))) ++(define (cdaddr x) (cdr (car (cdr (cdr x))))) ++(define (cddaar x) (cdr (cdr (car (car x))))) ++(define (cddadr x) (cdr (cdr (car (cdr x))))) ++(define (cdddar x) (cdr (cdr (cdr (car x))))) ++(define (cddddr x) (cdr (cdr (cdr (cdr x))))) ++ ++;;;; Utility to ease macro creation ++(define (macro-expand form) ++ ((eval (get-closure-code (eval (car form)))) form)) ++ ++(define (macro-expand-all form) ++ (if (macro? form) ++ (macro-expand-all (macro-expand form)) ++ form)) ++ ++(define *compile-hook* macro-expand-all) ++ ++ ++(macro (unless form) ++ `(if (not ,(cadr form)) (begin ,@(cddr form)))) ++ ++(macro (when form) ++ `(if ,(cadr form) (begin ,@(cddr form)))) ++ ++; DEFINE-MACRO Contributed by Andy Gaynor ++(macro (define-macro dform) ++ (if (symbol? (cadr dform)) ++ `(macro ,@(cdr dform)) ++ (let ((form (gensym))) ++ `(macro (,(caadr dform) ,form) ++ (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form)))))) ++ ++; Utilities for math. Notice that inexact->exact is primitive, ++; but exact->inexact is not. ++(define exact? integer?) ++(define (inexact? x) (and (real? x) (not (integer? x)))) ++(define (even? n) (= (remainder n 2) 0)) ++(define (odd? n) (not (= (remainder n 2) 0))) ++(define (zero? n) (= n 0)) ++(define (positive? n) (> n 0)) ++(define (negative? n) (< n 0)) ++(define complex? number?) ++(define rational? real?) ++(define (abs n) (if (>= n 0) n (- n))) ++(define (exact->inexact n) (* n 1.0)) ++(define (<> n1 n2) (not (= n1 n2))) ++ ++; min and max must return inexact if any arg is inexact; use (+ n 0.0) ++(define (max . lst) ++ (foldr (lambda (a b) ++ (if (> a b) ++ (if (exact? b) a (+ a 0.0)) ++ (if (exact? a) b (+ b 0.0)))) ++ (car lst) (cdr lst))) ++(define (min . lst) ++ (foldr (lambda (a b) ++ (if (< a b) ++ (if (exact? b) a (+ a 0.0)) ++ (if (exact? a) b (+ b 0.0)))) ++ (car lst) (cdr lst))) ++ ++(define (succ x) (+ x 1)) ++(define (pred x) (- x 1)) ++(define gcd ++ (lambda a ++ (if (null? a) ++ 0 ++ (let ((aa (abs (car a))) ++ (bb (abs (cadr a)))) ++ (if (= bb 0) ++ aa ++ (gcd bb (remainder aa bb))))))) ++(define lcm ++ (lambda a ++ (if (null? a) ++ 1 ++ (let ((aa (abs (car a))) ++ (bb (abs (cadr a)))) ++ (if (or (= aa 0) (= bb 0)) ++ 0 ++ (abs (* (quotient aa (gcd aa bb)) bb))))))) ++ ++ ++(define (string . charlist) ++ (list->string charlist)) ++ ++(define (list->string charlist) ++ (let* ((len (length charlist)) ++ (newstr (make-string len)) ++ (fill-string! ++ (lambda (str i len charlist) ++ (if (= i len) ++ str ++ (begin (string-set! str i (car charlist)) ++ (fill-string! str (+ i 1) len (cdr charlist))))))) ++ (fill-string! newstr 0 len charlist))) ++ ++(define (string-fill! s e) ++ (let ((n (string-length s))) ++ (let loop ((i 0)) ++ (if (= i n) ++ s ++ (begin (string-set! s i e) (loop (succ i))))))) ++ ++(define (string->list s) ++ (let loop ((n (pred (string-length s))) (l '())) ++ (if (= n -1) ++ l ++ (loop (pred n) (cons (string-ref s n) l))))) ++ ++(define (string-copy str) ++ (string-append str)) ++ ++(define (string->anyatom str pred) ++ (let* ((a (string->atom str))) ++ (if (pred a) a ++ (error "string->xxx: not a xxx" a)))) ++ ++(define (string->number str . base) ++ (let ((n (string->atom str (if (null? base) 10 (car base))))) ++ (if (number? n) n #f))) ++ ++(define (anyatom->string n pred) ++ (if (pred n) ++ (atom->string n) ++ (error "xxx->string: not a xxx" n))) ++ ++(define (number->string n . base) ++ (atom->string n (if (null? base) 10 (car base)))) ++ ++ ++(define (char-cmp? cmp a b) ++ (cmp (char->integer a) (char->integer b))) ++(define (char-ci-cmp? cmp a b) ++ (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b)))) ++ ++(define (char=? a b) (char-cmp? = a b)) ++(define (char? a b) (char-cmp? > a b)) ++(define (char<=? a b) (char-cmp? <= a b)) ++(define (char>=? a b) (char-cmp? >= a b)) ++ ++(define (char-ci=? a b) (char-ci-cmp? = a b)) ++(define (char-ci? a b) (char-ci-cmp? > a b)) ++(define (char-ci<=? a b) (char-ci-cmp? <= a b)) ++(define (char-ci>=? a b) (char-ci-cmp? >= a b)) ++ ++; Note the trick of returning (cmp x y) ++(define (string-cmp? chcmp cmp a b) ++ (let ((na (string-length a)) (nb (string-length b))) ++ (let loop ((i 0)) ++ (cond ++ ((= i na) ++ (if (= i nb) (cmp 0 0) (cmp 0 1))) ++ ((= i nb) ++ (cmp 1 0)) ++ ((chcmp = (string-ref a i) (string-ref b i)) ++ (loop (succ i))) ++ (else ++ (chcmp cmp (string-ref a i) (string-ref b i))))))) ++ ++ ++(define (string=? a b) (string-cmp? char-cmp? = a b)) ++(define (string? a b) (string-cmp? char-cmp? > a b)) ++(define (string<=? a b) (string-cmp? char-cmp? <= a b)) ++(define (string>=? a b) (string-cmp? char-cmp? >= a b)) ++ ++(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b)) ++(define (string-ci? a b) (string-cmp? char-ci-cmp? > a b)) ++(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b)) ++(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b)) ++ ++(define (list . x) x) ++ ++(define (foldr f x lst) ++ (if (null? lst) ++ x ++ (foldr f (f x (car lst)) (cdr lst)))) ++ ++(define (unzip1-with-cdr . lists) ++ (unzip1-with-cdr-iterative lists '() '())) ++ ++(define (unzip1-with-cdr-iterative lists cars cdrs) ++ (if (null? lists) ++ (cons cars cdrs) ++ (let ((car1 (caar lists)) ++ (cdr1 (cdar lists))) ++ (unzip1-with-cdr-iterative ++ (cdr lists) ++ (append cars (list car1)) ++ (append cdrs (list cdr1)))))) ++ ++(define (map proc . lists) ++ (if (null? lists) ++ (apply proc) ++ (if (null? (car lists)) ++ '() ++ (let* ((unz (apply unzip1-with-cdr lists)) ++ (cars (car unz)) ++ (cdrs (cdr unz))) ++ (cons (apply proc cars) (apply map (cons proc cdrs))))))) ++ ++(define (for-each proc . lists) ++ (if (null? lists) ++ (apply proc) ++ (if (null? (car lists)) ++ #t ++ (let* ((unz (apply unzip1-with-cdr lists)) ++ (cars (car unz)) ++ (cdrs (cdr unz))) ++ (apply proc cars) (apply map (cons proc cdrs)))))) ++ ++(define (list-tail x k) ++ (if (zero? k) ++ x ++ (list-tail (cdr x) (- k 1)))) ++ ++(define (list-ref x k) ++ (car (list-tail x k))) ++ ++(define (last-pair x) ++ (if (pair? (cdr x)) ++ (last-pair (cdr x)) ++ x)) ++ ++(define (head stream) (car stream)) ++ ++(define (tail stream) (force (cdr stream))) ++ ++(define (vector-equal? x y) ++ (and (vector? x) (vector? y) (= (vector-length x) (vector-length y)) ++ (let ((n (vector-length x))) ++ (let loop ((i 0)) ++ (if (= i n) ++ #t ++ (and (equal? (vector-ref x i) (vector-ref y i)) ++ (loop (succ i)))))))) ++ ++(define (list->vector x) ++ (apply vector x)) ++ ++(define (vector-fill! v e) ++ (let ((n (vector-length v))) ++ (let loop ((i 0)) ++ (if (= i n) ++ v ++ (begin (vector-set! v i e) (loop (succ i))))))) ++ ++(define (vector->list v) ++ (let loop ((n (pred (vector-length v))) (l '())) ++ (if (= n -1) ++ l ++ (loop (pred n) (cons (vector-ref v n) l))))) ++ ++;; The following quasiquote macro is due to Eric S. Tiedemann. ++;; Copyright 1988 by Eric S. Tiedemann; all rights reserved. ++;; ++;; Subsequently modified to handle vectors: D. Souflis ++ ++(macro ++ quasiquote ++ (lambda (l) ++ (define (mcons f l r) ++ (if (and (pair? r) ++ (eq? (car r) 'quote) ++ (eq? (car (cdr r)) (cdr f)) ++ (pair? l) ++ (eq? (car l) 'quote) ++ (eq? (car (cdr l)) (car f))) ++ (if (or (procedure? f) (number? f) (string? f)) ++ f ++ (list 'quote f)) ++ (if (eqv? l vector) ++ (apply l (eval r)) ++ (list 'cons l r) ++ ))) ++ (define (mappend f l r) ++ (if (or (null? (cdr f)) ++ (and (pair? r) ++ (eq? (car r) 'quote) ++ (eq? (car (cdr r)) '()))) ++ l ++ (list 'append l r))) ++ (define (foo level form) ++ (cond ((not (pair? form)) ++ (if (or (procedure? form) (number? form) (string? form)) ++ form ++ (list 'quote form)) ++ ) ++ ((eq? 'quasiquote (car form)) ++ (mcons form ''quasiquote (foo (+ level 1) (cdr form)))) ++ (#t (if (zero? level) ++ (cond ((eq? (car form) 'unquote) (car (cdr form))) ++ ((eq? (car form) 'unquote-splicing) ++ (error "Unquote-splicing wasn't in a list:" ++ form)) ++ ((and (pair? (car form)) ++ (eq? (car (car form)) 'unquote-splicing)) ++ (mappend form (car (cdr (car form))) ++ (foo level (cdr form)))) ++ (#t (mcons form (foo level (car form)) ++ (foo level (cdr form))))) ++ (cond ((eq? (car form) 'unquote) ++ (mcons form ''unquote (foo (- level 1) ++ (cdr form)))) ++ ((eq? (car form) 'unquote-splicing) ++ (mcons form ''unquote-splicing ++ (foo (- level 1) (cdr form)))) ++ (#t (mcons form (foo level (car form)) ++ (foo level (cdr form))))))))) ++ (foo 0 (car (cdr l))))) ++ ++;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom) ++(define (shared-tail x y) ++ (let ((len-x (length x)) ++ (len-y (length y))) ++ (define (shared-tail-helper x y) ++ (if ++ (eq? x y) ++ x ++ (shared-tail-helper (cdr x) (cdr y)))) ++ ++ (cond ++ ((> len-x len-y) ++ (shared-tail-helper ++ (list-tail x (- len-x len-y)) ++ y)) ++ ((< len-x len-y) ++ (shared-tail-helper ++ x ++ (list-tail y (- len-y len-x)))) ++ (#t (shared-tail-helper x y))))) ++ ++;;;;;Dynamic-wind by Tom Breton (Tehom) ++ ++;;Guarded because we must only eval this once, because doing so ++;;redefines call/cc in terms of old call/cc ++(unless (defined? 'dynamic-wind) ++ (let ++ ;;These functions are defined in the context of a private list of ++ ;;pairs of before/after procs. ++ ( (*active-windings* '()) ++ ;;We'll define some functions into the larger environment, so ++ ;;we need to know it. ++ (outer-env (current-environment))) ++ ++ ;;Poor-man's structure operations ++ (define before-func car) ++ (define after-func cdr) ++ (define make-winding cons) ++ ++ ;;Manage active windings ++ (define (activate-winding! new) ++ ((before-func new)) ++ (set! *active-windings* (cons new *active-windings*))) ++ (define (deactivate-top-winding!) ++ (let ((old-top (car *active-windings*))) ++ ;;Remove it from the list first so it's not active during its ++ ;;own exit. ++ (set! *active-windings* (cdr *active-windings*)) ++ ((after-func old-top)))) ++ ++ (define (set-active-windings! new-ws) ++ (unless (eq? new-ws *active-windings*) ++ (let ((shared (shared-tail new-ws *active-windings*))) ++ ++ ;;Define the looping functions. ++ ;;Exit the old list. Do deeper ones last. Don't do ++ ;;any shared ones. ++ (define (pop-many) ++ (unless (eq? *active-windings* shared) ++ (deactivate-top-winding!) ++ (pop-many))) ++ ;;Enter the new list. Do deeper ones first so that the ++ ;;deeper windings will already be active. Don't do any ++ ;;shared ones. ++ (define (push-many new-ws) ++ (unless (eq? new-ws shared) ++ (push-many (cdr new-ws)) ++ (activate-winding! (car new-ws)))) ++ ++ ;;Do it. ++ (pop-many) ++ (push-many new-ws)))) ++ ++ ;;The definitions themselves. ++ (eval ++ `(define call-with-current-continuation ++ ;;It internally uses the built-in call/cc, so capture it. ++ ,(let ((old-c/cc call-with-current-continuation)) ++ (lambda (func) ++ ;;Use old call/cc to get the continuation. ++ (old-c/cc ++ (lambda (continuation) ++ ;;Call func with not the continuation itself ++ ;;but a procedure that adjusts the active ++ ;;windings to what they were when we made ++ ;;this, and only then calls the ++ ;;continuation. ++ (func ++ (let ((current-ws *active-windings*)) ++ (lambda (x) ++ (set-active-windings! current-ws) ++ (continuation x))))))))) ++ outer-env) ++ ;;We can't just say "define (dynamic-wind before thunk after)" ++ ;;because the lambda it's defined to lives in this environment, ++ ;;not in the global environment. ++ (eval ++ `(define dynamic-wind ++ ,(lambda (before thunk after) ++ ;;Make a new winding ++ (activate-winding! (make-winding before after)) ++ (let ((result (thunk))) ++ ;;Get rid of the new winding. ++ (deactivate-top-winding!) ++ ;;The return value is that of thunk. ++ result))) ++ outer-env))) ++ ++(define call/cc call-with-current-continuation) ++ ++ ++;;;;; atom? and equal? written by a.k ++ ++;;;; atom? ++(define (atom? x) ++ (not (pair? x))) ++ ++;;;; equal? ++(define (equal? x y) ++ (cond ++ ((pair? x) ++ (and (pair? y) ++ (equal? (car x) (car y)) ++ (equal? (cdr x) (cdr y)))) ++ ((vector? x) ++ (and (vector? y) (vector-equal? x y))) ++ ((string? x) ++ (and (string? y) (string=? x y))) ++ (else (eqv? x y)))) ++ ++;;;; (do ((var init inc) ...) (endtest result ...) body ...) ++;; ++(macro do ++ (lambda (do-macro) ++ (apply (lambda (do vars endtest . body) ++ (let ((do-loop (gensym))) ++ `(letrec ((,do-loop ++ (lambda ,(map (lambda (x) ++ (if (pair? x) (car x) x)) ++ `,vars) ++ (if ,(car endtest) ++ (begin ,@(cdr endtest)) ++ (begin ++ ,@body ++ (,do-loop ++ ,@(map (lambda (x) ++ (cond ++ ((not (pair? x)) x) ++ ((< (length x) 3) (car x)) ++ (else (car (cdr (cdr x)))))) ++ `,vars))))))) ++ (,do-loop ++ ,@(map (lambda (x) ++ (if (and (pair? x) (cdr x)) ++ (car (cdr x)) ++ '())) ++ `,vars))))) ++ do-macro))) ++ ++;;;; generic-member ++(define (generic-member cmp obj lst) ++ (cond ++ ((null? lst) #f) ++ ((cmp obj (car lst)) lst) ++ (else (generic-member cmp obj (cdr lst))))) ++ ++(define (memq obj lst) ++ (generic-member eq? obj lst)) ++(define (memv obj lst) ++ (generic-member eqv? obj lst)) ++(define (member obj lst) ++ (generic-member equal? obj lst)) ++ ++;;;; generic-assoc ++(define (generic-assoc cmp obj alst) ++ (cond ++ ((null? alst) #f) ++ ((cmp obj (caar alst)) (car alst)) ++ (else (generic-assoc cmp obj (cdr alst))))) ++ ++(define (assq obj alst) ++ (generic-assoc eq? obj alst)) ++(define (assv obj alst) ++ (generic-assoc eqv? obj alst)) ++(define (assoc obj alst) ++ (generic-assoc equal? obj alst)) ++ ++(define (acons x y z) (cons (cons x y) z)) ++ ++;;;; Handy for imperative programs ++;;;; Used as: (define-with-return (foo x y) .... (return z) ...) ++(macro (define-with-return form) ++ `(define ,(cadr form) ++ (call/cc (lambda (return) ,@(cddr form))))) ++ ++;;;; Simple exception handling ++; ++; Exceptions are caught as follows: ++; ++; (catch (do-something to-recover and-return meaningful-value) ++; (if-something goes-wrong) ++; (with-these calls)) ++; ++; "Catch" establishes a scope spanning multiple call-frames ++; until another "catch" is encountered. ++; ++; Exceptions are thrown with: ++; ++; (throw "message") ++; ++; If used outside a (catch ...), reverts to (error "message) ++ ++(define *handlers* (list)) ++ ++(define (push-handler proc) ++ (set! *handlers* (cons proc *handlers*))) ++ ++(define (pop-handler) ++ (let ((h (car *handlers*))) ++ (set! *handlers* (cdr *handlers*)) ++ h)) ++ ++(define (more-handlers?) ++ (pair? *handlers*)) ++ ++(define (throw . x) ++ (if (more-handlers?) ++ (apply (pop-handler)) ++ (apply error x))) ++ ++(macro (catch form) ++ (let ((label (gensym))) ++ `(call/cc (lambda (exit) ++ (push-handler (lambda () (exit ,(cadr form)))) ++ (let ((,label (begin ,@(cddr form)))) ++ (pop-handler) ++ ,label))))) ++ ++(define *error-hook* throw) ++ ++ ++;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL ++ ++(macro (make-environment form) ++ `(apply (lambda () ++ ,@(cdr form) ++ (current-environment)))) ++ ++(define-macro (eval-polymorphic x . envl) ++ (display envl) ++ (let* ((env (if (null? envl) (current-environment) (eval (car envl)))) ++ (xval (eval x env))) ++ (if (closure? xval) ++ (make-closure (get-closure-code xval) env) ++ xval))) ++ ++; Redefine this if you install another package infrastructure ++; Also redefine 'package' ++(define *colon-hook* eval) ++ ++;;;;; I/O ++ ++(define (input-output-port? p) ++ (and (input-port? p) (output-port? p))) ++ ++(define (close-port p) ++ (cond ++ ((input-output-port? p) (close-input-port (close-output-port p))) ++ ((input-port? p) (close-input-port p)) ++ ((output-port? p) (close-output-port p)) ++ (else (throw "Not a port" p)))) ++ ++(define (call-with-input-file s p) ++ (let ((inport (open-input-file s))) ++ (if (eq? inport #f) ++ #f ++ (let ((res (p inport))) ++ (close-input-port inport) ++ res)))) ++ ++(define (call-with-output-file s p) ++ (let ((outport (open-output-file s))) ++ (if (eq? outport #f) ++ #f ++ (let ((res (p outport))) ++ (close-output-port outport) ++ res)))) ++ ++(define (with-input-from-file s p) ++ (let ((inport (open-input-file s))) ++ (if (eq? inport #f) ++ #f ++ (let ((prev-inport (current-input-port))) ++ (set-input-port inport) ++ (let ((res (p))) ++ (close-input-port inport) ++ (set-input-port prev-inport) ++ res))))) ++ ++(define (with-output-to-file s p) ++ (let ((outport (open-output-file s))) ++ (if (eq? outport #f) ++ #f ++ (let ((prev-outport (current-output-port))) ++ (set-output-port outport) ++ (let ((res (p))) ++ (close-output-port outport) ++ (set-output-port prev-outport) ++ res))))) ++ ++(define (with-input-output-from-to-files si so p) ++ (let ((inport (open-input-file si)) ++ (outport (open-input-file so))) ++ (if (not (and inport outport)) ++ (begin ++ (close-input-port inport) ++ (close-output-port outport) ++ #f) ++ (let ((prev-inport (current-input-port)) ++ (prev-outport (current-output-port))) ++ (set-input-port inport) ++ (set-output-port outport) ++ (let ((res (p))) ++ (close-input-port inport) ++ (close-output-port outport) ++ (set-input-port prev-inport) ++ (set-output-port prev-outport) ++ res))))) ++ ++; Random number generator (maximum cycle) ++(define *seed* 1) ++(define (random-next) ++ (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a))) ++ (set! *seed* ++ (- (* a (- *seed* ++ (* (quotient *seed* q) q))) ++ (* (quotient *seed* q) r))) ++ (if (< *seed* 0) (set! *seed* (+ *seed* m))) ++ *seed*)) ++;; SRFI-0 ++;; COND-EXPAND ++;; Implemented as a macro ++(define *features* '(srfi-0)) ++ ++(define-macro (cond-expand . cond-action-list) ++ (cond-expand-runtime cond-action-list)) ++ ++(define (cond-expand-runtime cond-action-list) ++ (if (null? cond-action-list) ++ #t ++ (if (cond-eval (caar cond-action-list)) ++ `(begin ,@(cdar cond-action-list)) ++ (cond-expand-runtime (cdr cond-action-list))))) ++ ++(define (cond-eval-and cond-list) ++ (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list)) ++ ++(define (cond-eval-or cond-list) ++ (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list)) ++ ++(define (cond-eval condition) ++ (cond ++ ((symbol? condition) ++ (if (member condition *features*) #t #f)) ++ ((eq? condition #t) #t) ++ ((eq? condition #f) #f) ++ (else (case (car condition) ++ ((and) (cond-eval-and (cdr condition))) ++ ((or) (cond-eval-or (cdr condition))) ++ ((not) (if (not (null? (cddr condition))) ++ (error "cond-expand : 'not' takes 1 argument") ++ (not (cond-eval (cadr condition))))) ++ (else (error "cond-expand : unknown operator" (car condition))))))) ++ ++(gc-verbose #f) +diff --git a/bootshell/main.c b/bootshell/main.c +new file mode 100644 +index 0000000..f5f3ab5 +--- /dev/null ++++ b/bootshell/main.c +@@ -0,0 +1,296 @@ ++/* Standard startup-time command line parser ++ ++ Copyright (C) 1995, 1996, 1997, 1998, 1999, 2001, 2007 ++ Free Software Foundation, Inc. ++*/ ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++ ++#if LIBREADLINE_LINKS ++#include ++#include ++#endif ++ ++#include "scheme.h" ++#include "scheme-private.h" ++ ++#include "bootshell.h" ++#include "ffi.h" ++ ++task_t bootscript_task; ++task_t rootfs_server_task; ++task_t exec_server_task; ++ ++#define _HURD_RUNSYSTEM "/hurd/runsystem.scm" ++#define _BOOT_COMMAND "(boot)" ++ ++char *multiboot_command_line; ++char *boot_init_program; ++boolean_t boot_pause; ++char *boot_command = _BOOT_COMMAND; ++char **global_argv; ++boolean_t booted; ++boolean_t interactive; ++ ++scheme scm; ++ ++/* We catch exceptions using this port. */ ++mach_port_t exception_port; ++ ++mach_port_t console; ++ ++mach_port_t portarray_template[INIT_PORT_MAX]; ++ ++const char *argp_program_version = STANDARD_HURD_VERSION (bootshell); ++ ++#define OPT_HOST_PRIV_PORT (-1) ++#define OPT_DEVICE_MASTER_PORT (-2) ++#define OPT_BOOTSCRIPT_TASK (-3) ++#define OPT_ROOTFS_SERVER_TASK (-4) ++#define OPT_EXEC_SERVER_TASK (-5) ++#define OPT_BOOT_CMDLINE (-6) ++#define OPT_BOOT_COMMAND (-7) ++#define OPT_BOOT_INIT_PROGRAM (-8) ++#define OPT_BOOT_PAUSE (-9) ++ ++static const struct argp_option options[] = ++{ ++ {"interactive", 'I', NULL, 0, "start interactive repl"}, ++ {0,0,0,0, "Boot options:", -2}, ++ {"multiboot-command-line", OPT_BOOT_CMDLINE, "ARGS", 0, ++ "The multiboot kernel command line"}, ++ {"bootflags", 0, 0, OPTION_ALIAS|OPTION_HIDDEN}, ++ {"boot-debug-pause", OPT_BOOT_PAUSE, NULL, 0, ++ "Pause for keystroke before starting bootstrap programs"}, ++ {"boot-command", OPT_BOOT_COMMAND, "S-EXPRESSION", 0, ++ "Command to run, default: " _BOOT_COMMAND}, ++ {"host-priv-port", OPT_HOST_PRIV_PORT, "PORT"}, ++ {"device-master-port", OPT_DEVICE_MASTER_PORT, "PORT"}, ++ {"bootscript-task", OPT_BOOTSCRIPT_TASK, "PORT"}, ++ {"rootfs-server-task", OPT_ROOTFS_SERVER_TASK, "PORT"}, ++ {"exec-server-task", OPT_EXEC_SERVER_TASK, "PORT"}, ++ {0} ++}; ++ ++static error_t ++parse_opt (int opt, char *arg, struct argp_state *state) ++{ ++ switch (opt) ++ { ++ /* Boot options */ ++ case 'I': ++ interactive = 1; ++ break; ++ case OPT_DEVICE_MASTER_PORT: ++ _hurd_device_master = atoi (arg); break; ++ case OPT_HOST_PRIV_PORT: ++ _hurd_host_priv = atoi (arg); break; ++ case OPT_BOOTSCRIPT_TASK: ++ bootscript_task = atoi (arg); break; ++ case OPT_ROOTFS_SERVER_TASK: ++ rootfs_server_task = atoi (arg); break; ++ case OPT_EXEC_SERVER_TASK: ++ exec_server_task = atoi (arg); break; ++ case OPT_BOOT_CMDLINE: ++ multiboot_command_line = arg; break; ++ case OPT_BOOT_INIT_PROGRAM: ++ boot_init_program = arg; break; ++ case OPT_BOOT_PAUSE: ++ boot_pause = 1; break; ++ case OPT_BOOT_COMMAND: ++ boot_command = arg; break; ++ case ARGP_KEY_END: ++ global_argv = state->argv; break; ++ default: ++ return ARGP_ERR_UNKNOWN; ++ case ARGP_KEY_INIT: ++ case ARGP_KEY_SUCCESS: ++ case ARGP_KEY_ERROR: ++ break; ++ } ++ return 0; ++} ++ ++static const char doc[] = ++ "Start and maintain hurd core servers and system run state"; ++ ++static const struct argp argp = ++{ options, parse_opt, 0, doc }; ++ ++void ++panic (const char *msg) ++{ ++ mach_printf ("%s\n", msg); ++ _exit (127); ++} ++ ++void ffi_update (scheme *sc); //XXX ++ ++ ++/* A static variable for holding the line. */ ++static char *line_read = (char *)NULL; ++ ++/* Read a string, and return a pointer to it. ++ Returns NULL on EOF. */ ++char * ++rl_gets (const char *prompt) ++{ ++ /* If the buffer has already been allocated, ++ return the memory to the free pool. */ ++ if (line_read) ++ { ++ free (line_read); ++ line_read = (char *)NULL; ++ } ++ ++#if 0 ++ /* Get a line from the user. */ ++ line_read = readline (prompt); ++ ++ /* If the line has any text in it, ++ save it on the history. */ ++ if (line_read && *line_read) ++ add_history (line_read); ++#else ++ printf ("%s", prompt); ++ fflush (stdout); ++ line_read = malloc (80); ++ if (line_read != NULL) ++ fgets (line_read, 80, stdin); ++#endif ++ ++ /* rstrip line */ ++ if (line_read && strlen (line_read) > 0) ++ for (char *p = &line_read[strlen (line_read) - 1]; isspace (*p); p--) ++ *p = 0; ++ ++ return line_read; ++} ++ ++int ++main (int argc, char **argv) ++{ ++ error_t err; ++ /* XXX */ ++ setenv ("TERM", "mach", 1); ++ setenv ("COLS", "80", 1); ++ setenv ("LINES", "25", 1); ++ ++ argp_parse (&argp, argc, argv, /*ARGP_NO_ERRS|*/ARGP_IN_ORDER, 0, 0); ++ ++ { ++ mach_port_t proc = getproc (); ++ if (MACH_PORT_VALID (proc)) ++ { ++ booted = 1; ++ err = mach_port_deallocate (mach_task_self (), proc); ++ assert_perror (err); ++ } ++ } ++ ++ if (! booted) ++ { ++ err = init_exception_handling (); ++ if (err) ++ error (1, err, "init_exception_handling"); ++ } ++ ++ err = init_fs_server (); // XXX don't start automatically ++ if (err) ++ error (1, err, "init_fs_server"); ++ ++ if (MACH_PORT_VALID (_hurd_device_master)) ++ { ++ err = device_open (_hurd_device_master, D_READ|D_WRITE, ++ "console", &console); ++ if (err) ++ panic ("Failed to open console."); ++ ++ stdin = mach_open_devstream (console, "r"); ++ stdout = stderr = mach_open_devstream (console, "w"); ++ if (! stdin || ! stdout) ++ panic ("Failed to open device stream."); ++ ++ setvbuf (stdout, NULL, _IONBF, 0); ++ } ++ ++ if (! scheme_init (&scm)) ++ error (1, errno, "scheme_init"); ++ ++ scheme_set_input_port_file(&scm, stdin); ++ scheme_set_output_port_file(&scm, stdout); ++ ++ ffi_init (&scm); ++ ++ load_embedded_script (&scm, init_scm); ++ load_embedded_script (&scm, boot_scm); ++ load_embedded_script (&scm, runsystem_scm); ++ ++ define_variable (&scm, bootscript_task); ++ define_variable (&scm, rootfs_server_task); ++ define_variable (&scm, exec_server_task); ++ define_variable (&scm, boot_pause); ++ ++ define_ (&scm, "host-priv", ++ scm.vptr->mk_integer (&scm, _hurd_host_priv)); ++ define_ (&scm, "device-master", ++ scm.vptr->mk_integer (&scm, _hurd_device_master)); ++ ++ define_variable_string (&scm, multiboot_command_line); ++ define_variable_string (&scm, boot_init_program); ++ define_variable_string (&scm, boot_command); ++ define_variable (&scm, boot_pause); ++ { ++ char *argz = NULL; ++ size_t argz_len = 0; ++ err = argz_create (argv, &argz, &argz_len); ++ assert_perror (err); ++ define_ (&scm, "argv", ffi_argz2list (&scm, argz, argz_len, NULL)); ++ } ++ ++ if (MACH_PORT_VALID (bootscript_task)) ++ { ++ vm_size_t size; ++ vm_prot_t prot, max_prot; ++ mach_port_t obj; ++ vm_offset_t addr = 0, offs; ++ vm_inherit_t inh; ++ int shared; ++ ++ err = ++ vm_region (bootscript_task, &addr, &size, &prot, &max_prot, &inh, &shared, ++ &obj, &offs); ++ if (err) ++ error (12, err, "vm_region"); ++ ++ vm_offset_t script; ++ size_t count; ++ err = vm_read (bootscript_task, addr, size, &script, &count); ++ if (err) ++ error (12, err, "vm_read"); ++ scheme_load_mem (&scm, (char *) script, (char *) script + size); ++ if (scm.retcode) { ++ fprintf (stderr, "Error: %d\n", scm.retcode); ++ } ++ } ++ ++ if (! interactive) ++ scheme_load_string (&scm, boot_command); ++ ++ while (1) ++ scheme_load_string (&scm, "(interactive-repl)"); ++ ++ /* Not reached. */ ++ scheme_deinit(&scm); ++ return 0; ++} +diff --git a/bootshell/mig-decls.h b/bootshell/mig-decls.h +new file mode 100644 +index 0000000..120778d +--- /dev/null ++++ b/bootshell/mig-decls.h +@@ -0,0 +1,3 @@ ++#include ++ ++#define MIG_EOPNOTSUPP ({ abort (); EOPNOTSUPP; }) +diff --git a/bootshell/mig-mutate.h b/bootshell/mig-mutate.h +new file mode 100644 +index 0000000..eadcbc9 +--- /dev/null ++++ b/bootshell/mig-mutate.h +@@ -0,0 +1,27 @@ ++/* ++ Copyright (C) 2014 Free Software Foundation, Inc. ++ Written by Justus Winter. ++ ++ This file is part of the GNU Hurd. ++ ++ The GNU Hurd is free software; you can redistribute it and/or ++ modify it under the terms of the GNU General Public License as ++ published by the Free Software Foundation; either version 2, or (at ++ your option) any later version. ++ ++ The GNU Hurd is distributed in the hope that it will be useful, but ++ WITHOUT ANY WARRANTY; without even the implied warranty of ++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ++ General Public License for more details. ++ ++ You should have received a copy of the GNU General Public License ++ along with the GNU Hurd. If not, see . */ ++ ++#define HURD_DEFAULT_PAYLOAD_TO_PORT 1 ++ ++#define FILE_IMPORTS \ ++ import "mig-decls.h"; ++#define FSYS_IMPORTS \ ++ import "mig-decls.h"; ++#define STARTUP_IMPORTS \ ++ import "mig-decls.h"; +diff --git a/bootshell/opdefines.h b/bootshell/opdefines.h +new file mode 100644 +index 0000000..ceb4d0e +--- /dev/null ++++ b/bootshell/opdefines.h +@@ -0,0 +1,195 @@ ++ _OP_DEF(opexe_0, "load", 1, 1, TST_STRING, OP_LOAD ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T0LVL ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_T1LVL ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_READ_INTERNAL ) ++ _OP_DEF(opexe_0, "gensym", 0, 0, 0, OP_GENSYM ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_VALUEPRINT ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_EVAL ) ++#if USE_TRACING ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_EVAL ) ++#endif ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E0ARGS ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_E1ARGS ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_APPLY ) ++#if USE_TRACING ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_REAL_APPLY ) ++ _OP_DEF(opexe_0, "tracing", 1, 1, TST_NATURAL, OP_TRACING ) ++#endif ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DOMACRO ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LAMBDA1 ) ++ _OP_DEF(opexe_0, "make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_QUOTE ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF0 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_DEF1 ) ++ _OP_DEF(opexe_0, "defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_BEGIN ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF0 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_IF1 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET0 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_SET1 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2 ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET0AST ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET1AST ) ++ _OP_DEF(opexe_0, 0, 0, 0, 0, OP_LET2AST ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET0REC ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET1REC ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_LET2REC ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND0 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_COND1 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_DELAY ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND0 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_AND1 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR0 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_OR1 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C0STREAM ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_C1STREAM ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO0 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_MACRO1 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE0 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE1 ) ++ _OP_DEF(opexe_1, 0, 0, 0, 0, OP_CASE2 ) ++ _OP_DEF(opexe_1, "eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL ) ++ _OP_DEF(opexe_1, "apply", 1, INF_ARG, TST_NONE, OP_PAPPLY ) ++ _OP_DEF(opexe_1, "call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION ) ++#if USE_MATH ++ _OP_DEF(opexe_2, "inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX ) ++ _OP_DEF(opexe_2, "exp", 1, 1, TST_NUMBER, OP_EXP ) ++ _OP_DEF(opexe_2, "log", 1, 1, TST_NUMBER, OP_LOG ) ++ _OP_DEF(opexe_2, "sin", 1, 1, TST_NUMBER, OP_SIN ) ++ _OP_DEF(opexe_2, "cos", 1, 1, TST_NUMBER, OP_COS ) ++ _OP_DEF(opexe_2, "tan", 1, 1, TST_NUMBER, OP_TAN ) ++ _OP_DEF(opexe_2, "asin", 1, 1, TST_NUMBER, OP_ASIN ) ++ _OP_DEF(opexe_2, "acos", 1, 1, TST_NUMBER, OP_ACOS ) ++ _OP_DEF(opexe_2, "atan", 1, 2, TST_NUMBER, OP_ATAN ) ++ _OP_DEF(opexe_2, "sqrt", 1, 1, TST_NUMBER, OP_SQRT ) ++ _OP_DEF(opexe_2, "expt", 2, 2, TST_NUMBER, OP_EXPT ) ++ _OP_DEF(opexe_2, "floor", 1, 1, TST_NUMBER, OP_FLOOR ) ++ _OP_DEF(opexe_2, "ceiling", 1, 1, TST_NUMBER, OP_CEILING ) ++ _OP_DEF(opexe_2, "truncate", 1, 1, TST_NUMBER, OP_TRUNCATE ) ++ _OP_DEF(opexe_2, "round", 1, 1, TST_NUMBER, OP_ROUND ) ++#endif ++ _OP_DEF(opexe_2, "+", 0, INF_ARG, TST_NUMBER, OP_ADD ) ++ _OP_DEF(opexe_2, "-", 1, INF_ARG, TST_NUMBER, OP_SUB ) ++ _OP_DEF(opexe_2, "*", 0, INF_ARG, TST_NUMBER, OP_MUL ) ++ _OP_DEF(opexe_2, "/", 1, INF_ARG, TST_NUMBER, OP_DIV ) ++ _OP_DEF(opexe_2, "quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV ) ++ _OP_DEF(opexe_2, "remainder", 2, 2, TST_INTEGER, OP_REM ) ++ _OP_DEF(opexe_2, "modulo", 2, 2, TST_INTEGER, OP_MOD ) ++ _OP_DEF(opexe_2, "car", 1, 1, TST_PAIR, OP_CAR ) ++ _OP_DEF(opexe_2, "cdr", 1, 1, TST_PAIR, OP_CDR ) ++ _OP_DEF(opexe_2, "cons", 2, 2, TST_NONE, OP_CONS ) ++ _OP_DEF(opexe_2, "set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR ) ++ _OP_DEF(opexe_2, "set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR ) ++ _OP_DEF(opexe_2, "char->integer", 1, 1, TST_CHAR, OP_CHAR2INT ) ++ _OP_DEF(opexe_2, "integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR ) ++ _OP_DEF(opexe_2, "char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE ) ++ _OP_DEF(opexe_2, "char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE ) ++ _OP_DEF(opexe_2, "symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR ) ++ _OP_DEF(opexe_2, "atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR ) ++ _OP_DEF(opexe_2, "string->symbol", 1, 1, TST_STRING, OP_STR2SYM ) ++ _OP_DEF(opexe_2, "string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM ) ++ _OP_DEF(opexe_2, "make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING ) ++ _OP_DEF(opexe_2, "string-length", 1, 1, TST_STRING, OP_STRLEN ) ++ _OP_DEF(opexe_2, "string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF ) ++ _OP_DEF(opexe_2, "string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET ) ++ _OP_DEF(opexe_2, "string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND ) ++ _OP_DEF(opexe_2, "substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR ) ++ _OP_DEF(opexe_2, "vector", 0, INF_ARG, TST_NONE, OP_VECTOR ) ++ _OP_DEF(opexe_2, "make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR ) ++ _OP_DEF(opexe_2, "vector-length", 1, 1, TST_VECTOR, OP_VECLEN ) ++ _OP_DEF(opexe_2, "vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF ) ++ _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET ) ++ _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT ) ++ _OP_DEF(opexe_3, "boolean?", 1, 1, TST_NONE, OP_BOOLP ) ++ _OP_DEF(opexe_3, "eof-object?", 1, 1, TST_NONE, OP_EOFOBJP ) ++ _OP_DEF(opexe_3, "null?", 1, 1, TST_NONE, OP_NULLP ) ++ _OP_DEF(opexe_3, "=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ ) ++ _OP_DEF(opexe_3, "<", 2, INF_ARG, TST_NUMBER, OP_LESS ) ++ _OP_DEF(opexe_3, ">", 2, INF_ARG, TST_NUMBER, OP_GRE ) ++ _OP_DEF(opexe_3, "<=", 2, INF_ARG, TST_NUMBER, OP_LEQ ) ++ _OP_DEF(opexe_3, ">=", 2, INF_ARG, TST_NUMBER, OP_GEQ ) ++ _OP_DEF(opexe_3, "symbol?", 1, 1, TST_ANY, OP_SYMBOLP ) ++ _OP_DEF(opexe_3, "number?", 1, 1, TST_ANY, OP_NUMBERP ) ++ _OP_DEF(opexe_3, "string?", 1, 1, TST_ANY, OP_STRINGP ) ++ _OP_DEF(opexe_3, "integer?", 1, 1, TST_ANY, OP_INTEGERP ) ++ _OP_DEF(opexe_3, "real?", 1, 1, TST_ANY, OP_REALP ) ++ _OP_DEF(opexe_3, "char?", 1, 1, TST_ANY, OP_CHARP ) ++#if USE_CHAR_CLASSIFIERS ++ _OP_DEF(opexe_3, "char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP ) ++ _OP_DEF(opexe_3, "char-numeric?", 1, 1, TST_CHAR, OP_CHARNP ) ++ _OP_DEF(opexe_3, "char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP ) ++ _OP_DEF(opexe_3, "char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP ) ++ _OP_DEF(opexe_3, "char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP ) ++#endif ++ _OP_DEF(opexe_3, "port?", 1, 1, TST_ANY, OP_PORTP ) ++ _OP_DEF(opexe_3, "input-port?", 1, 1, TST_ANY, OP_INPORTP ) ++ _OP_DEF(opexe_3, "output-port?", 1, 1, TST_ANY, OP_OUTPORTP ) ++ _OP_DEF(opexe_3, "procedure?", 1, 1, TST_ANY, OP_PROCP ) ++ _OP_DEF(opexe_3, "pair?", 1, 1, TST_ANY, OP_PAIRP ) ++ _OP_DEF(opexe_3, "list?", 1, 1, TST_ANY, OP_LISTP ) ++ _OP_DEF(opexe_3, "environment?", 1, 1, TST_ANY, OP_ENVP ) ++ _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP ) ++ _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ ) ++ _OP_DEF(opexe_3, "eqv?", 2, 2, TST_ANY, OP_EQV ) ++ _OP_DEF(opexe_4, "force", 1, 1, TST_ANY, OP_FORCE ) ++ _OP_DEF(opexe_4, 0, 0, 0, 0, OP_SAVE_FORCED ) ++ _OP_DEF(opexe_4, "write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE ) ++ _OP_DEF(opexe_4, "write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR ) ++ _OP_DEF(opexe_4, "display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY ) ++ _OP_DEF(opexe_4, "newline", 0, 1, TST_OUTPORT, OP_NEWLINE ) ++ _OP_DEF(opexe_4, "error", 1, INF_ARG, TST_NONE, OP_ERR0 ) ++ _OP_DEF(opexe_4, 0, 0, 0, 0, OP_ERR1 ) ++ _OP_DEF(opexe_4, "reverse", 1, 1, TST_LIST, OP_REVERSE ) ++ _OP_DEF(opexe_4, "list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR ) ++ _OP_DEF(opexe_4, "append", 0, INF_ARG, TST_NONE, OP_APPEND ) ++#if USE_PLIST ++ _OP_DEF(opexe_4, "put", 3, 3, TST_NONE, OP_PUT ) ++ _OP_DEF(opexe_4, "get", 2, 2, TST_NONE, OP_GET ) ++#endif ++ _OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT ) ++ _OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC ) ++ _OP_DEF(opexe_4, "gc-verbose", 0, 1, TST_NONE, OP_GCVERB ) ++ _OP_DEF(opexe_4, "new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT ) ++ _OP_DEF(opexe_4, "oblist", 0, 0, 0, OP_OBLIST ) ++ _OP_DEF(opexe_4, "current-input-port", 0, 0, 0, OP_CURR_INPORT ) ++ _OP_DEF(opexe_4, "current-output-port", 0, 0, 0, OP_CURR_OUTPORT ) ++ _OP_DEF(opexe_4, "open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE ) ++ _OP_DEF(opexe_4, "open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE ) ++ _OP_DEF(opexe_4, "open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE ) ++#if USE_STRING_PORTS ++ _OP_DEF(opexe_4, "open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING ) ++ _OP_DEF(opexe_4, "open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING ) ++ _OP_DEF(opexe_4, "open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING ) ++ _OP_DEF(opexe_4, "get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING ) ++#endif ++ _OP_DEF(opexe_4, "close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT ) ++ _OP_DEF(opexe_4, "close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT ) ++ _OP_DEF(opexe_4, "interaction-environment", 0, 0, 0, OP_INT_ENV ) ++ _OP_DEF(opexe_4, "current-environment", 0, 0, 0, OP_CURR_ENV ) ++ _OP_DEF(opexe_5, "read", 0, 1, TST_INPORT, OP_READ ) ++ _OP_DEF(opexe_5, "read-char", 0, 1, TST_INPORT, OP_READ_CHAR ) ++ _OP_DEF(opexe_5, "peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR ) ++ _OP_DEF(opexe_5, "char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY ) ++ _OP_DEF(opexe_5, "set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT ) ++ _OP_DEF(opexe_5, "set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDSEXPR ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDLIST ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDDOT ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQUOTE ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTE ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDQQUOTEVEC ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUNQUOTE ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDUQTSP ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_RDVEC ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P0LIST ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_P1LIST ) ++ _OP_DEF(opexe_5, 0, 0, 0, 0, OP_PVECFROM ) ++ _OP_DEF(opexe_6, "length", 1, 1, TST_LIST, OP_LIST_LENGTH ) ++ _OP_DEF(opexe_6, "assq", 2, 2, TST_NONE, OP_ASSQ ) ++ _OP_DEF(opexe_6, "get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE ) ++ _OP_DEF(opexe_6, "closure?", 1, 1, TST_NONE, OP_CLOSUREP ) ++ _OP_DEF(opexe_6, "macro?", 1, 1, TST_NONE, OP_MACROP ) ++#undef _OP_DEF +diff --git a/bootshell/runsystem.scm b/bootshell/runsystem.scm +new file mode 100644 +index 0000000..940b862 +--- /dev/null ++++ b/bootshell/runsystem.scm +@@ -0,0 +1,175 @@ ++;; The Hurd server bootstrap. ++;; ++;; XXX license, how to modify ++ ++(define timeout 1000) ; 1 second ++ ++(define (pause) ++ (if (= 1 boot-pause) (prompt "Press enter to continue..."))) ++ ++;; Tests if a device with the given NAME exists. ++(define (devprobe? name) ++ (letport ((device (catch MACH_PORT_NULL ++ (device-open device-master D_READ name)))) ++ (mach-port-valid? device))) ++ ++;; Insert RIGHT into TASK. Returns the name of RIGHT in TASK. ++(define (task-insert-send-right task right) ++ (let loop ((name 1)) ++ (catch (loop (+ name 1)) ++ (mach-port-insert-right task name right MACH_MSG_TYPE_COPY_SEND) ++ name))) ++ ++;; Inserts RIGHT into TASK and returns a command line argument OPTION ++;; with the value set to the name of RIGHT in TASK. ++(define (make-arg option task right) ++ (string-append "--" option "=" ++ (number->string (task-insert-send-right task right)))) ++ ++;; Returns a function that can be passed to `bootstrap-translator' to ++;; resume a translator loaded by the traditional bootscript mechanism. ++(define (resume-translator task args) ++ (lambda (bootstrap) ++ (task-set-exception-port task (make-send-right exception-port)) ++ (task-set-bootstrap-port task bootstrap) ++ (pause) ++ (task-resume task) ++ (handle-exec-startup bootstrap args timeout) ++ task)) ++ ++;; Returns a function that can be passed to `bootstrap-translator' to ++;; start a translator that is loaded from a disk. ++(define (start-translator task argv) ++ (lambda (bootstrap) ++ (letport ((proc (getproc))) ++ (pause) ++ (_exec (file-name-lookup (car argv) O_EXEC 0) task argv bootstrap) ++ (if (mach-port-valid? proc) ++ (let ((child-proc (proc->task->proc proc task))) ++ (proc->task->child! proc task) ++ (proc->mark-exec! child-proc) ++ (proc->mark-important! child-proc)))))) ++ ++;; Bootstraps a translator using the fsys protocol. ++(define (bootstrap-translator prepare-task realnode) ++ (let* ((bootstrap ++ (mach-port-allocate mach-task-self MACH_PORT_RIGHT_RECEIVE)) ++ (task ++ (prepare-task (make-send-right bootstrap)))) ++ (handle-fsys-startup bootstrap realnode MACH_MSG_TYPE_COPY_SEND timeout))) ++ ++;; Bootstraps the proc server using the startup protocol. ++(define (bootstrap-proc prepare-task) ++ (let* ((bootstrap ++ (mach-port-allocate mach-task-self MACH_PORT_RIGHT_RECEIVE)) ++ (task ++ (prepare-task (make-send-right bootstrap)))) ++ (handle-startup-procinit bootstrap timeout))) ++ ++;; Bootstraps the auth server using the startup protocol. ++(define (bootstrap-auth prepare-task) ++ (let* ((bootstrap ++ (mach-port-allocate mach-task-self MACH_PORT_RIGHT_RECEIVE)) ++ (task ++ (prepare-task (make-send-right bootstrap)))) ++ (handle-startup-authinit bootstrap timeout))) ++ ++;; Bootstraps a translator using the fsys protocol and installs it as ++;; root filesystem. ++(define (bind-root prepare-task) ++ (let ((control ++ (bootstrap-translator prepare-task (make-send-right rootnode)))) ++ (_bind-root control rootnode) ++ control)) ++ ++;; Bootstraps a translator using the fsys protocol and installs it as ++;; active translator for the node PATH. ++(define (bind path prepare-task) ++ (letport ((realnode (file-name-lookup path O_NOTRANS 438)) ++ (control (bootstrap-translator prepare-task realnode))) ++ (set-active-translator path control) ++ (copy-send-right control))) ++ ++;; We start servers when the proc server is not yet around. Once the ++;; proc server is available, we use this function to update its state ++;; related to TASK. ++(define (fixup-task task) ++ (letport ((myproc (getproc)) ++ (p (proc->task->proc myproc task))) ++ (proc->task->child! myproc task) ++ (proc->mark-important! p) ++ (proc->mark-exec! p))) ++ ++;; Perform a traditional Hurd server bootstrap. Expects suspended ++;; rootfs and exec servers, with command line arguments prepared by ++;; the kernel. ++(define (bootstrap) ++ (log "Hurd server bootstrap: ") ++ ++ (log "rootfs ") ++ (let ((rootfs-control (bind-root (resume-translator rootfs-server-task ++ '()))) ++ (startup-control (mach-port-allocate mach-task-self ++ MACH_PORT_RIGHT_RECEIVE)) ++ (proc-task (task-create mach-task-self 0)) ++ (auth-task (task-create mach-task-self 0)) ++ ;; Projections for the cookies returned by bootstrap-*. ++ (:reply car) (:replyPoly cadr) (:server caddr)) ++ (start-handling-early-startup startup-control) ++ (set-active-translator "/servers/startup" ++ (make-send-right startup-control)) ++ (log "exec ") ++ (bind "/servers/exec" (resume-translator exec-server-task '())) ++ ++ (let ((pc (bootstrap-proc (start-translator proc-task '("/hurd/proc")))) ++ (ac (bootstrap-auth (start-translator auth-task '("/hurd/auth"))))) ++ (log "proc ") ++ (startup-procinit-reply (:reply pc) (:replyPoly pc) ESUCCESS ++ mach-task-self (:server ac) ++ host-priv device-master) ++ (bind-proc (:server pc)) ++ (map fixup-task (list rootfs-server-task exec-server-task proc-task auth-task)) ++ ++ (log "auth ") ++ (startup-authinit-reply (:reply ac) (:replyPoly ac) ESUCCESS ++ (proc->task->proc (:server pc) auth-task)) ++ (bind-auth (:server ac)) ++ ++ ;; Give the rootfs its proc and auth port. ++ (fsys-init rootfs-control ++ (proc->task->proc (:server pc) rootfs-server-task) ++ (:server ac)) ++ (mach-port-deallocate mach-task-self (:server pc)) ++ (mach-port-deallocate mach-task-self (:server ac)))) ++ ++ ;; The standalone startup server watches essential servers, and ++ ;; handles the system shutdown. ++ (log "startup ") ++ (bind "/servers/startup" ++ (start-translator (task-create mach-task-self 0) ++ '("/hurd/startup-standalone"))) ++ ++ ;; Now that we have startup, register all servers to it. ++ (let ((startup (file-name-lookup "/servers/startup" 0 0)) ++ ;; Projections. ++ (:port car) (:name cdr)) ++ ;; We are essential. ++ (startup-essential-task startup mach-task-self MACH_PORT_NULL ++ "bootshell" host-priv) ++ (map (lambda (c) ++ (startup-essential-task startup (:port c) MACH_PORT_NULL ++ (:name c) host-priv)) ++ (get-essential-tasks)) ++ (map (lambda (c) ++ (startup-request-notification startup (:port c) (:name c))) ++ (get-registered-tasks)) ++ (mach-port-deallocate mach-task-self startup)) ++ ++ (log "done.\n")) ++ ++(define (boot) ++ (catch (panic "Hurd bootstrap failed: " (car last-exception) "\n") ++ (bootstrap)) ++ ++ (shell (lambda (prefix) (prompt-append-prefix ++ (string-append "runsystem@" (hostname) " " (getcwd) " ") prefix)))) +diff --git a/bootshell/scheme-config.h b/bootshell/scheme-config.h +new file mode 100644 +index 0000000..20ef332 +--- /dev/null ++++ b/bootshell/scheme-config.h +@@ -0,0 +1,11 @@ ++#define STANDALONE 0 ++#define USE_MATH 0 ++#define USE_CHAR_CLASSIFIERS 1 ++#define USE_ASCII_NAMES 1 ++#define USE_STRING_PORTS 1 ++#define USE_ERROR_HOOK 1 ++#define USE_TRACING 1 ++#define USE_COLON_HOOK 0 ++#define USE_DL 0 ++#define USE_PLIST 0 ++#define USE_INTERFACE 1 +diff --git a/bootshell/scheme-private.h b/bootshell/scheme-private.h +new file mode 100644 +index 0000000..3395328 +--- /dev/null ++++ b/bootshell/scheme-private.h +@@ -0,0 +1,210 @@ ++/* scheme-private.h */ ++ ++#ifndef _SCHEME_PRIVATE_H ++#define _SCHEME_PRIVATE_H ++ ++#include "scheme.h" ++/*------------------ Ugly internals -----------------------------------*/ ++/*------------------ Of interest only to FFI users --------------------*/ ++ ++#ifdef __cplusplus ++extern "C" { ++#endif ++ ++enum scheme_port_kind { ++ port_free=0, ++ port_file=1, ++ port_string=2, ++ port_srfi6=4, ++ port_input=16, ++ port_output=32, ++ port_saw_EOF=64 ++}; ++ ++typedef struct port { ++ unsigned char kind; ++ union { ++ struct { ++ FILE *file; ++ int closeit; ++#if SHOW_ERROR_LINE ++ int curr_line; ++ char *filename; ++#endif ++ } stdio; ++ struct { ++ char *start; ++ char *past_the_end; ++ char *curr; ++ } string; ++ } rep; ++} port; ++ ++/* cell structure */ ++struct cell { ++ unsigned int _flag; ++ union { ++ struct { ++ char *_svalue; ++ int _length; ++ } _string; ++ num _number; ++ port *_port; ++ foreign_func _ff; ++ struct { ++ struct cell *_car; ++ struct cell *_cdr; ++ } _cons; ++ } _object; ++}; ++ ++struct scheme { ++/* arrays for segments */ ++func_alloc malloc; ++func_dealloc free; ++ ++/* return code */ ++int retcode; ++int tracing; ++ ++ ++#define CELL_SEGSIZE 5000 /* # of cells in one segment */ ++#define CELL_NSEGMENT 10 /* # of segments for cells */ ++char *alloc_seg[CELL_NSEGMENT]; ++pointer cell_seg[CELL_NSEGMENT]; ++int last_cell_seg; ++ ++/* We use 4 registers. */ ++pointer args; /* register for arguments of function */ ++pointer envir; /* stack register for current environment */ ++pointer code; /* register for current code */ ++pointer dump; /* stack register for next evaluation */ ++ ++int interactive_repl; /* are we in an interactive REPL? */ ++ ++struct cell _sink; ++pointer sink; /* when mem. alloc. fails */ ++struct cell _NIL; ++pointer NIL; /* special cell representing empty cell */ ++struct cell _HASHT; ++pointer T; /* special cell representing #t */ ++struct cell _HASHF; ++pointer F; /* special cell representing #f */ ++struct cell _EOF_OBJ; ++pointer EOF_OBJ; /* special cell representing end-of-file object */ ++pointer oblist; /* pointer to symbol table */ ++pointer global_env; /* pointer to global environment */ ++pointer c_nest; /* stack for nested calls from C */ ++ ++/* global pointers to special symbols */ ++pointer LAMBDA; /* pointer to syntax lambda */ ++pointer QUOTE; /* pointer to syntax quote */ ++ ++pointer QQUOTE; /* pointer to symbol quasiquote */ ++pointer UNQUOTE; /* pointer to symbol unquote */ ++pointer UNQUOTESP; /* pointer to symbol unquote-splicing */ ++pointer FEED_TO; /* => */ ++pointer COLON_HOOK; /* *colon-hook* */ ++pointer ERROR_HOOK; /* *error-hook* */ ++pointer SHARP_HOOK; /* *sharp-hook* */ ++pointer COMPILE_HOOK; /* *compile-hook* */ ++ ++pointer free_cell; /* pointer to top of free cells */ ++long fcells; /* # of free cells */ ++ ++pointer inport; ++pointer outport; ++pointer save_inport; ++pointer loadport; ++ ++#define MAXFIL 64 ++port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */ ++int nesting_stack[MAXFIL]; ++int file_i; ++int nesting; ++ ++char gc_verbose; /* if gc_verbose is not zero, print gc status */ ++char no_memory; /* Whether mem. alloc. has failed */ ++ ++#define LINESIZE 1024 ++char linebuff[LINESIZE]; ++#define STRBUFFSIZE 256 ++char strbuff[STRBUFFSIZE]; ++ ++FILE *tmpfp; ++int tok; ++int print_flag; ++pointer value; ++int op; ++ ++void *ext_data; /* For the benefit of foreign functions */ ++long gensym_cnt; ++ ++struct scheme_interface *vptr; ++void *dump_base; /* pointer to base of allocated dump stack */ ++int dump_size; /* number of frames allocated for dump stack */ ++}; ++ ++/* operator code */ ++enum scheme_opcodes { ++#define _OP_DEF(A,B,C,D,E,OP) OP, ++#include "opdefines.h" ++ OP_MAXDEFINED ++}; ++ ++ ++#define cons(sc,a,b) _cons(sc,a,b,0) ++#define immutable_cons(sc,a,b) _cons(sc,a,b,1) ++ ++int is_string(pointer p); ++char *string_value(pointer p); ++int is_number(pointer p); ++num nvalue(pointer p); ++long ivalue(pointer p); ++double rvalue(pointer p); ++int is_integer(pointer p); ++int is_real(pointer p); ++int is_character(pointer p); ++long charvalue(pointer p); ++int is_vector(pointer p); ++ ++int is_port(pointer p); ++ ++int is_pair(pointer p); ++pointer pair_car(pointer p); ++pointer pair_cdr(pointer p); ++pointer set_car(pointer p, pointer q); ++pointer set_cdr(pointer p, pointer q); ++ ++int is_symbol(pointer p); ++char *symname(pointer p); ++int hasprop(pointer p); ++ ++int is_syntax(pointer p); ++int is_proc(pointer p); ++int is_foreign(pointer p); ++char *syntaxname(pointer p); ++int is_closure(pointer p); ++#ifdef USE_MACRO ++int is_macro(pointer p); ++#endif ++pointer closure_code(pointer p); ++pointer closure_env(pointer p); ++ ++int is_continuation(pointer p); ++int is_promise(pointer p); ++int is_environment(pointer p); ++int is_immutable(pointer p); ++void setimmutable(pointer p); ++ ++#ifdef __cplusplus ++} ++#endif ++ ++#endif ++ ++/* ++Local variables: ++c-file-style: "k&r" ++End: ++*/ +diff --git a/bootshell/scheme.c b/bootshell/scheme.c +new file mode 100644 +index 0000000..5ca5641 +--- /dev/null ++++ b/bootshell/scheme.c +@@ -0,0 +1,5075 @@ ++/* T I N Y S C H E M E 1 . 4 1 ++ * Dimitrios Souflis (dsouflis@acm.org) ++ * Based on MiniScheme (original credits follow) ++ * (MINISCM) coded by Atsushi Moriwaki (11/5/1989) ++ * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp ++ * (MINISCM) This version has been modified by R.C. Secrist. ++ * (MINISCM) ++ * (MINISCM) Mini-Scheme is now maintained by Akira KIDA. ++ * (MINISCM) ++ * (MINISCM) This is a revised and modified version by Akira KIDA. ++ * (MINISCM) current version is 0.85k4 (15 May 1994) ++ * ++ */ ++ ++#define _SCHEME_SOURCE ++#include "scheme-private.h" ++#ifndef WIN32 ++# include ++#endif ++#ifdef WIN32 ++#define snprintf _snprintf ++#endif ++#if USE_DL ++# include "dynload.h" ++#endif ++#if USE_MATH ++# include ++#endif ++ ++#include ++#include ++#include ++ ++#if USE_STRCASECMP ++#include ++# ifndef __APPLE__ ++# define stricmp strcasecmp ++# endif ++#endif ++ ++/* Used for documentation purposes, to signal functions in 'interface' */ ++#define INTERFACE ++ ++#define TOK_EOF (-1) ++#define TOK_LPAREN 0 ++#define TOK_RPAREN 1 ++#define TOK_DOT 2 ++#define TOK_ATOM 3 ++#define TOK_QUOTE 4 ++#define TOK_COMMENT 5 ++#define TOK_DQUOTE 6 ++#define TOK_BQUOTE 7 ++#define TOK_COMMA 8 ++#define TOK_ATMARK 9 ++#define TOK_SHARP 10 ++#define TOK_SHARP_CONST 11 ++#define TOK_VEC 12 ++ ++#define BACKQUOTE '`' ++#define DELIMITERS "()\";\f\t\v\n\r " ++ ++/* ++ * Basic memory allocation units ++ */ ++ ++#define banner "TinyScheme 1.41" ++ ++#include ++#include ++ ++#ifdef __APPLE__ ++static int stricmp(const char *s1, const char *s2) ++{ ++ unsigned char c1, c2; ++ do { ++ c1 = tolower(*s1); ++ c2 = tolower(*s2); ++ if (c1 < c2) ++ return -1; ++ else if (c1 > c2) ++ return 1; ++ s1++, s2++; ++ } while (c1 != 0); ++ return 0; ++} ++#endif /* __APPLE__ */ ++ ++#if USE_STRLWR ++static const char *strlwr(char *s) { ++ const char *p=s; ++ while(*s) { ++ *s=tolower(*s); ++ s++; ++ } ++ return p; ++} ++#endif ++ ++#ifndef prompt ++# define prompt "ts> " ++#endif ++ ++#ifndef InitFile ++# define InitFile "init.scm" ++#endif ++ ++#ifndef FIRST_CELLSEGS ++# define FIRST_CELLSEGS 3 ++#endif ++ ++enum scheme_types { ++ T_STRING=1, ++ T_NUMBER=2, ++ T_SYMBOL=3, ++ T_PROC=4, ++ T_PAIR=5, ++ T_CLOSURE=6, ++ T_CONTINUATION=7, ++ T_FOREIGN=8, ++ T_CHARACTER=9, ++ T_PORT=10, ++ T_VECTOR=11, ++ T_MACRO=12, ++ T_PROMISE=13, ++ T_ENVIRONMENT=14, ++ T_LAST_SYSTEM_TYPE=14 ++}; ++ ++/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */ ++#define ADJ 32 ++#define TYPE_BITS 5 ++#define T_MASKTYPE 31 /* 0000000000011111 */ ++#define T_SYNTAX 4096 /* 0001000000000000 */ ++#define T_IMMUTABLE 8192 /* 0010000000000000 */ ++#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */ ++#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */ ++#define MARK 32768 /* 1000000000000000 */ ++#define UNMARK 32767 /* 0111111111111111 */ ++ ++ ++static num num_add(num a, num b); ++static num num_mul(num a, num b); ++static num num_div(num a, num b); ++static num num_intdiv(num a, num b); ++static num num_sub(num a, num b); ++static num num_rem(num a, num b); ++static num num_mod(num a, num b); ++static int num_eq(num a, num b); ++static int num_gt(num a, num b); ++static int num_ge(num a, num b); ++static int num_lt(num a, num b); ++static int num_le(num a, num b); ++ ++#if USE_MATH ++static double round_per_R5RS(double x); ++#endif ++static int is_zero_double(double x); ++static INLINE int num_is_integer(pointer p) { ++ return ((p)->_object._number.is_fixnum); ++} ++ ++static num num_zero; ++static num num_one; ++ ++/* macros for cell operations */ ++#define typeflag(p) ((p)->_flag) ++#define type(p) (typeflag(p)&T_MASKTYPE) ++ ++INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); } ++#define strvalue(p) ((p)->_object._string._svalue) ++#define strlength(p) ((p)->_object._string._length) ++ ++INTERFACE static int is_list(scheme *sc, pointer p); ++INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); } ++INTERFACE static void fill_vector(pointer vec, pointer obj); ++INTERFACE static pointer vector_elem(pointer vec, int ielem); ++INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a); ++INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); } ++INTERFACE INLINE int is_integer(pointer p) { ++ if (!is_number(p)) ++ return 0; ++ if (num_is_integer(p) || (double)ivalue(p) == rvalue(p)) ++ return 1; ++ return 0; ++} ++ ++INTERFACE INLINE int is_real(pointer p) { ++ return is_number(p) && (!(p)->_object._number.is_fixnum); ++} ++ ++INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); } ++INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); } ++INLINE num nvalue(pointer p) { return ((p)->_object._number); } ++INTERFACE long ivalue(pointer p) { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); } ++INTERFACE double rvalue(pointer p) { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); } ++#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue) ++#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue) ++#define set_num_integer(p) (p)->_object._number.is_fixnum=1; ++#define set_num_real(p) (p)->_object._number.is_fixnum=0; ++INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); } ++ ++INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); } ++INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; } ++INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; } ++ ++INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); } ++#define car(p) ((p)->_object._cons._car) ++#define cdr(p) ((p)->_object._cons._cdr) ++INTERFACE pointer pair_car(pointer p) { return car(p); } ++INTERFACE pointer pair_cdr(pointer p) { return cdr(p); } ++INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; } ++INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; } ++ ++INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); } ++INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); } ++#if USE_PLIST ++SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); } ++#define symprop(p) cdr(p) ++#endif ++ ++INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); } ++INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); } ++INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); } ++INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); } ++#define procnum(p) ivalue(p) ++static const char *procname(pointer x); ++ ++INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); } ++INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); } ++INTERFACE INLINE pointer closure_code(pointer p) { return car(p); } ++INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); } ++ ++INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); } ++#define cont_dump(p) cdr(p) ++ ++/* To do: promise should be forced ONCE only */ ++INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); } ++ ++INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); } ++#define setenvironment(p) typeflag(p) = T_ENVIRONMENT ++ ++#define is_atom(p) (typeflag(p)&T_ATOM) ++#define setatom(p) typeflag(p) |= T_ATOM ++#define clratom(p) typeflag(p) &= CLRATOM ++ ++#define is_mark(p) (typeflag(p)&MARK) ++#define setmark(p) typeflag(p) |= MARK ++#define clrmark(p) typeflag(p) &= UNMARK ++ ++INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); } ++/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/ ++INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; } ++ ++#define caar(p) car(car(p)) ++#define cadr(p) car(cdr(p)) ++#define cdar(p) cdr(car(p)) ++#define cddr(p) cdr(cdr(p)) ++#define cadar(p) car(cdr(car(p))) ++#define caddr(p) car(cdr(cdr(p))) ++#define cdaar(p) cdr(car(car(p))) ++#define cadaar(p) car(cdr(car(car(p)))) ++#define cadddr(p) car(cdr(cdr(cdr(p)))) ++#define cddddr(p) cdr(cdr(cdr(cdr(p)))) ++ ++#if USE_CHAR_CLASSIFIERS ++static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); } ++static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); } ++static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); } ++static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); } ++static INLINE int Cislower(int c) { return isascii(c) && islower(c); } ++#endif ++ ++#if USE_ASCII_NAMES ++static const char *charnames[32]={ ++ "nul", ++ "soh", ++ "stx", ++ "etx", ++ "eot", ++ "enq", ++ "ack", ++ "bel", ++ "bs", ++ "ht", ++ "lf", ++ "vt", ++ "ff", ++ "cr", ++ "so", ++ "si", ++ "dle", ++ "dc1", ++ "dc2", ++ "dc3", ++ "dc4", ++ "nak", ++ "syn", ++ "etb", ++ "can", ++ "em", ++ "sub", ++ "esc", ++ "fs", ++ "gs", ++ "rs", ++ "us" ++}; ++ ++static int is_ascii_name(const char *name, int *pc) { ++ int i; ++ for(i=0; i<32; i++) { ++ if(stricmp(name,charnames[i])==0) { ++ *pc=i; ++ return 1; ++ } ++ } ++ if(stricmp(name,"del")==0) { ++ *pc=127; ++ return 1; ++ } ++ return 0; ++} ++ ++#endif ++ ++static int file_push(scheme *sc, const char *fname); ++static void file_pop(scheme *sc); ++static int file_interactive(scheme *sc); ++static INLINE int is_one_of(char *s, int c); ++static int alloc_cellseg(scheme *sc, int n); ++static long binary_decode(const char *s); ++static INLINE pointer get_cell(scheme *sc, pointer a, pointer b); ++static pointer _get_cell(scheme *sc, pointer a, pointer b); ++static pointer reserve_cells(scheme *sc, int n); ++static pointer get_consecutive_cells(scheme *sc, int n); ++static pointer find_consecutive_cells(scheme *sc, int n); ++static void finalize_cell(scheme *sc, pointer a); ++static int count_consecutive_cells(pointer x, int needed); ++static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all); ++static pointer mk_number(scheme *sc, num n); ++static char *store_string(scheme *sc, int len, const char *str, char fill); ++static pointer mk_vector(scheme *sc, int len); ++static pointer mk_atom(scheme *sc, char *q); ++static pointer mk_sharp_const(scheme *sc, char *name); ++static pointer mk_port(scheme *sc, port *p); ++static pointer port_from_filename(scheme *sc, const char *fn, int prop); ++static pointer port_from_file(scheme *sc, FILE *, int prop); ++static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop); ++static port *port_rep_from_filename(scheme *sc, const char *fn, int prop); ++static port *port_rep_from_file(scheme *sc, FILE *, int prop); ++static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop); ++static void port_close(scheme *sc, pointer p, int flag); ++static void mark(pointer a); ++static void gc(scheme *sc, pointer a, pointer b); ++static int basic_inchar(port *pt); ++static int inchar(scheme *sc); ++static void backchar(scheme *sc, int c); ++static char *readstr_upto(scheme *sc, char *delim); ++static pointer readstrexp(scheme *sc); ++static INLINE int skipspace(scheme *sc); ++static int token(scheme *sc); ++static void printslashstring(scheme *sc, char *s, int len); ++static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen); ++static void printatom(scheme *sc, pointer l, int f); ++static pointer mk_proc(scheme *sc, enum scheme_opcodes op); ++static pointer mk_closure(scheme *sc, pointer c, pointer e); ++static pointer mk_continuation(scheme *sc, pointer d); ++static pointer reverse(scheme *sc, pointer a); ++static pointer reverse_in_place(scheme *sc, pointer term, pointer list); ++static pointer revappend(scheme *sc, pointer a, pointer b); ++static void dump_stack_mark(scheme *); ++static pointer opexe_0(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_1(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_2(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_3(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_4(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_5(scheme *sc, enum scheme_opcodes op); ++static pointer opexe_6(scheme *sc, enum scheme_opcodes op); ++static void Eval_Cycle(scheme *sc, enum scheme_opcodes op); ++static void assign_syntax(scheme *sc, char *name); ++static int syntaxnum(pointer p); ++static void assign_proc(scheme *sc, enum scheme_opcodes, char *name); ++ ++#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue) ++#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue) ++ ++static num num_add(num a, num b) { ++ num ret; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(ret.is_fixnum) { ++ ret.value.ivalue= a.value.ivalue+b.value.ivalue; ++ } else { ++ ret.value.rvalue=num_rvalue(a)+num_rvalue(b); ++ } ++ return ret; ++} ++ ++static num num_mul(num a, num b) { ++ num ret; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(ret.is_fixnum) { ++ ret.value.ivalue= a.value.ivalue*b.value.ivalue; ++ } else { ++ ret.value.rvalue=num_rvalue(a)*num_rvalue(b); ++ } ++ return ret; ++} ++ ++static num num_div(num a, num b) { ++ num ret; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0; ++ if(ret.is_fixnum) { ++ ret.value.ivalue= a.value.ivalue/b.value.ivalue; ++ } else { ++ ret.value.rvalue=num_rvalue(a)/num_rvalue(b); ++ } ++ return ret; ++} ++ ++static num num_intdiv(num a, num b) { ++ num ret; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(ret.is_fixnum) { ++ ret.value.ivalue= a.value.ivalue/b.value.ivalue; ++ } else { ++ ret.value.rvalue=num_rvalue(a)/num_rvalue(b); ++ } ++ return ret; ++} ++ ++static num num_sub(num a, num b) { ++ num ret; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(ret.is_fixnum) { ++ ret.value.ivalue= a.value.ivalue-b.value.ivalue; ++ } else { ++ ret.value.rvalue=num_rvalue(a)-num_rvalue(b); ++ } ++ return ret; ++} ++ ++static num num_rem(num a, num b) { ++ num ret; ++ long e1, e2, res; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ e1=num_ivalue(a); ++ e2=num_ivalue(b); ++ res=e1%e2; ++ /* remainder should have same sign as second operand */ ++ if (res > 0) { ++ if (e1 < 0) { ++ res -= labs(e2); ++ } ++ } else if (res < 0) { ++ if (e1 > 0) { ++ res += labs(e2); ++ } ++ } ++ ret.value.ivalue=res; ++ return ret; ++} ++ ++static num num_mod(num a, num b) { ++ num ret; ++ long e1, e2, res; ++ ret.is_fixnum=a.is_fixnum && b.is_fixnum; ++ e1=num_ivalue(a); ++ e2=num_ivalue(b); ++ res=e1%e2; ++ /* modulo should have same sign as second operand */ ++ if (res * e2 < 0) { ++ res += e2; ++ } ++ ret.value.ivalue=res; ++ return ret; ++} ++ ++static int num_eq(num a, num b) { ++ int ret; ++ int is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(is_fixnum) { ++ ret= a.value.ivalue==b.value.ivalue; ++ } else { ++ ret=num_rvalue(a)==num_rvalue(b); ++ } ++ return ret; ++} ++ ++ ++static int num_gt(num a, num b) { ++ int ret; ++ int is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(is_fixnum) { ++ ret= a.value.ivalue>b.value.ivalue; ++ } else { ++ ret=num_rvalue(a)>num_rvalue(b); ++ } ++ return ret; ++} ++ ++static int num_ge(num a, num b) { ++ return !num_lt(a,b); ++} ++ ++static int num_lt(num a, num b) { ++ int ret; ++ int is_fixnum=a.is_fixnum && b.is_fixnum; ++ if(is_fixnum) { ++ ret= a.value.ivaluedce) { ++ return ce; ++ } else if(dfl-DBL_MIN; ++} ++ ++static long binary_decode(const char *s) { ++ long x=0; ++ ++ while(*s!=0 && (*s=='1' || *s=='0')) { ++ x<<=1; ++ x+=*s-'0'; ++ s++; ++ } ++ ++ return x; ++} ++ ++/* allocate new cell segment */ ++static int alloc_cellseg(scheme *sc, int n) { ++ pointer newp; ++ pointer last; ++ pointer p; ++ char *cp; ++ long i; ++ int k; ++ int adj=ADJ; ++ ++ if(adjlast_cell_seg >= CELL_NSEGMENT - 1) ++ return k; ++ cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj); ++ if (cp == 0) ++ return k; ++ i = ++sc->last_cell_seg ; ++ sc->alloc_seg[i] = cp; ++ /* adjust in TYPE_BITS-bit boundary */ ++ if(((unsigned long)cp)%adj!=0) { ++ cp=(char*)(adj*((unsigned long)cp/adj+1)); ++ } ++ /* insert new segment in address order */ ++ newp=(pointer)cp; ++ sc->cell_seg[i] = newp; ++ while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) { ++ p = sc->cell_seg[i]; ++ sc->cell_seg[i] = sc->cell_seg[i - 1]; ++ sc->cell_seg[--i] = p; ++ } ++ sc->fcells += CELL_SEGSIZE; ++ last = newp + CELL_SEGSIZE - 1; ++ for (p = newp; p <= last; p++) { ++ typeflag(p) = 0; ++ cdr(p) = p + 1; ++ car(p) = sc->NIL; ++ } ++ /* insert new cells in address order on free list */ ++ if (sc->free_cell == sc->NIL || p < sc->free_cell) { ++ cdr(last) = sc->free_cell; ++ sc->free_cell = newp; ++ } else { ++ p = sc->free_cell; ++ while (cdr(p) != sc->NIL && newp > cdr(p)) ++ p = cdr(p); ++ cdr(last) = cdr(p); ++ cdr(p) = newp; ++ } ++ } ++ return n; ++} ++ ++static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) { ++ if (sc->free_cell != sc->NIL) { ++ pointer x = sc->free_cell; ++ sc->free_cell = cdr(x); ++ --sc->fcells; ++ return (x); ++ } ++ return _get_cell (sc, a, b); ++} ++ ++ ++/* get new cell. parameter a, b is marked by gc. */ ++static pointer _get_cell(scheme *sc, pointer a, pointer b) { ++ pointer x; ++ ++ if(sc->no_memory) { ++ return sc->sink; ++ } ++ ++ if (sc->free_cell == sc->NIL) { ++ const int min_to_be_recovered = sc->last_cell_seg*8; ++ gc(sc,a, b); ++ if (sc->fcells < min_to_be_recovered ++ || sc->free_cell == sc->NIL) { ++ /* if only a few recovered, get more to avoid fruitless gc's */ ++ if (!alloc_cellseg(sc,1) && sc->free_cell == sc->NIL) { ++ sc->no_memory=1; ++ return sc->sink; ++ } ++ } ++ } ++ x = sc->free_cell; ++ sc->free_cell = cdr(x); ++ --sc->fcells; ++ return (x); ++} ++ ++/* make sure that there is a given number of cells free */ ++static pointer reserve_cells(scheme *sc, int n) { ++ if(sc->no_memory) { ++ return sc->NIL; ++ } ++ ++ /* Are there enough cells available? */ ++ if (sc->fcells < n) { ++ /* If not, try gc'ing some */ ++ gc(sc, sc->NIL, sc->NIL); ++ if (sc->fcells < n) { ++ /* If there still aren't, try getting more heap */ ++ if (!alloc_cellseg(sc,1)) { ++ sc->no_memory=1; ++ return sc->NIL; ++ } ++ } ++ if (sc->fcells < n) { ++ /* If all fail, report failure */ ++ sc->no_memory=1; ++ return sc->NIL; ++ } ++ } ++ return (sc->T); ++} ++ ++static pointer get_consecutive_cells(scheme *sc, int n) { ++ pointer x; ++ ++ if(sc->no_memory) { return sc->sink; } ++ ++ /* Are there any cells available? */ ++ x=find_consecutive_cells(sc,n); ++ if (x != sc->NIL) { return x; } ++ ++ /* If not, try gc'ing some */ ++ gc(sc, sc->NIL, sc->NIL); ++ x=find_consecutive_cells(sc,n); ++ if (x != sc->NIL) { return x; } ++ ++ /* If there still aren't, try getting more heap */ ++ if (!alloc_cellseg(sc,1)) ++ { ++ sc->no_memory=1; ++ return sc->sink; ++ } ++ ++ x=find_consecutive_cells(sc,n); ++ if (x != sc->NIL) { return x; } ++ ++ /* If all fail, report failure */ ++ sc->no_memory=1; ++ return sc->sink; ++} ++ ++static int count_consecutive_cells(pointer x, int needed) { ++ int n=1; ++ while(cdr(x)==x+1) { ++ x=cdr(x); ++ n++; ++ if(n>needed) return n; ++ } ++ return n; ++} ++ ++static pointer find_consecutive_cells(scheme *sc, int n) { ++ pointer *pp; ++ int cnt; ++ ++ pp=&sc->free_cell; ++ while(*pp!=sc->NIL) { ++ cnt=count_consecutive_cells(*pp,n); ++ if(cnt>=n) { ++ pointer x=*pp; ++ *pp=cdr(*pp+n-1); ++ sc->fcells -= n; ++ return x; ++ } ++ pp=&cdr(*pp+cnt-1); ++ } ++ return sc->NIL; ++} ++ ++/* To retain recent allocs before interpreter knows about them - ++ Tehom */ ++ ++static void push_recent_alloc(scheme *sc, pointer recent, pointer extra) ++{ ++ pointer holder = get_cell_x(sc, recent, extra); ++ typeflag(holder) = T_PAIR | T_IMMUTABLE; ++ car(holder) = recent; ++ cdr(holder) = car(sc->sink); ++ car(sc->sink) = holder; ++} ++ ++ ++static pointer get_cell(scheme *sc, pointer a, pointer b) ++{ ++ pointer cell = get_cell_x(sc, a, b); ++ /* For right now, include "a" and "b" in "cell" so that gc doesn't ++ think they are garbage. */ ++ /* Tentatively record it as a pair so gc understands it. */ ++ typeflag(cell) = T_PAIR; ++ car(cell) = a; ++ cdr(cell) = b; ++ push_recent_alloc(sc, cell, sc->NIL); ++ return cell; ++} ++ ++static pointer get_vector_object(scheme *sc, int len, pointer init) ++{ ++ pointer cells = get_consecutive_cells(sc,len/2+len%2+1); ++ if(sc->no_memory) { return sc->sink; } ++ /* Record it as a vector so that gc understands it. */ ++ typeflag(cells) = (T_VECTOR | T_ATOM); ++ ivalue_unchecked(cells)=len; ++ set_num_integer(cells); ++ fill_vector(cells,init); ++ push_recent_alloc(sc, cells, sc->NIL); ++ return cells; ++} ++ ++static INLINE void ok_to_freely_gc(scheme *sc) ++{ ++ car(sc->sink) = sc->NIL; ++} ++ ++ ++#if defined TSGRIND ++static void check_cell_alloced(pointer p, int expect_alloced) ++{ ++ /* Can't use putstr(sc,str) because callers have no access to ++ sc. */ ++ if(typeflag(p) & !expect_alloced) ++ { ++ fprintf(stderr,"Cell is already allocated!\n"); ++ } ++ if(!(typeflag(p)) & expect_alloced) ++ { ++ fprintf(stderr,"Cell is not allocated!\n"); ++ } ++ ++} ++static void check_range_alloced(pointer p, int n, int expect_alloced) ++{ ++ int i; ++ for(i = 0;iNIL); ++ typeflag(x) = T_SYMBOL; ++ setimmutable(car(x)); ++ ++ location = hash_fn(name, ivalue_unchecked(sc->oblist)); ++ set_vector_elem(sc->oblist, location, ++ immutable_cons(sc, x, vector_elem(sc->oblist, location))); ++ return x; ++} ++ ++static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) ++{ ++ int location; ++ pointer x; ++ char *s; ++ ++ location = hash_fn(name, ivalue_unchecked(sc->oblist)); ++ for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) { ++ s = symname(car(x)); ++ /* case-insensitive, per R5RS section 2. */ ++ if(stricmp(name, s) == 0) { ++ return car(x); ++ } ++ } ++ return sc->NIL; ++} ++ ++static pointer oblist_all_symbols(scheme *sc) ++{ ++ int i; ++ pointer x; ++ pointer ob_list = sc->NIL; ++ ++ for (i = 0; i < ivalue_unchecked(sc->oblist); i++) { ++ for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) { ++ ob_list = cons(sc, x, ob_list); ++ } ++ } ++ return ob_list; ++} ++ ++#else ++ ++static pointer oblist_initial_value(scheme *sc) ++{ ++ return sc->NIL; ++} ++ ++static INLINE pointer oblist_find_by_name(scheme *sc, const char *name) ++{ ++ pointer x; ++ char *s; ++ ++ for (x = sc->oblist; x != sc->NIL; x = cdr(x)) { ++ s = symname(car(x)); ++ /* case-insensitive, per R5RS section 2. */ ++ if(stricmp(name, s) == 0) { ++ return car(x); ++ } ++ } ++ return sc->NIL; ++} ++ ++/* returns the new symbol */ ++static pointer oblist_add_by_name(scheme *sc, const char *name) ++{ ++ pointer x; ++ ++ x = immutable_cons(sc, mk_string(sc, name), sc->NIL); ++ typeflag(x) = T_SYMBOL; ++ setimmutable(car(x)); ++ sc->oblist = immutable_cons(sc, x, sc->oblist); ++ return x; ++} ++static pointer oblist_all_symbols(scheme *sc) ++{ ++ return sc->oblist; ++} ++ ++#endif ++ ++static pointer mk_port(scheme *sc, port *p) { ++ pointer x = get_cell(sc, sc->NIL, sc->NIL); ++ ++ typeflag(x) = T_PORT|T_ATOM; ++ x->_object._port=p; ++ return (x); ++} ++ ++pointer mk_foreign_func(scheme *sc, foreign_func f) { ++ pointer x = get_cell(sc, sc->NIL, sc->NIL); ++ ++ typeflag(x) = (T_FOREIGN | T_ATOM); ++ x->_object._ff=f; ++ return (x); ++} ++ ++INTERFACE pointer mk_character(scheme *sc, int c) { ++ pointer x = get_cell(sc,sc->NIL, sc->NIL); ++ ++ typeflag(x) = (T_CHARACTER | T_ATOM); ++ ivalue_unchecked(x)= c; ++ set_num_integer(x); ++ return (x); ++} ++ ++/* get number atom (integer) */ ++INTERFACE pointer mk_integer(scheme *sc, long num) { ++ pointer x = get_cell(sc,sc->NIL, sc->NIL); ++ ++ typeflag(x) = (T_NUMBER | T_ATOM); ++ ivalue_unchecked(x)= num; ++ set_num_integer(x); ++ return (x); ++} ++ ++INTERFACE pointer mk_real(scheme *sc, double n) { ++ pointer x = get_cell(sc,sc->NIL, sc->NIL); ++ ++ typeflag(x) = (T_NUMBER | T_ATOM); ++ rvalue_unchecked(x)= n; ++ set_num_real(x); ++ return (x); ++} ++ ++static pointer mk_number(scheme *sc, num n) { ++ if(n.is_fixnum) { ++ return mk_integer(sc,n.value.ivalue); ++ } else { ++ return mk_real(sc,n.value.rvalue); ++ } ++} ++ ++/* allocate name to string area */ ++static char *store_string(scheme *sc, int len_str, const char *str, char fill) { ++ char *q; ++ ++ q=(char*)sc->malloc(len_str+1); ++ if(q==0) { ++ sc->no_memory=1; ++ return sc->strbuff; ++ } ++ if(str!=0) { ++ snprintf(q, len_str+1, "%s", str); ++ } else { ++ memset(q, fill, len_str); ++ q[len_str]=0; ++ } ++ return (q); ++} ++ ++/* get new string */ ++INTERFACE pointer mk_string(scheme *sc, const char *str) { ++ return mk_counted_string(sc,str,strlen(str)); ++} ++ ++INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) { ++ pointer x = get_cell(sc, sc->NIL, sc->NIL); ++ typeflag(x) = (T_STRING | T_ATOM); ++ strvalue(x) = store_string(sc,len,str,0); ++ strlength(x) = len; ++ return (x); ++} ++ ++INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) { ++ pointer x = get_cell(sc, sc->NIL, sc->NIL); ++ typeflag(x) = (T_STRING | T_ATOM); ++ strvalue(x) = store_string(sc,len,0,fill); ++ strlength(x) = len; ++ return (x); ++} ++ ++INTERFACE static pointer mk_vector(scheme *sc, int len) ++{ return get_vector_object(sc,len,sc->NIL); } ++ ++INTERFACE static void fill_vector(pointer vec, pointer obj) { ++ int i; ++ int num=ivalue(vec)/2+ivalue(vec)%2; ++ for(i=0; iNIL) { ++ return (x); ++ } else { ++ x = oblist_add_by_name(sc, name); ++ return (x); ++ } ++} ++ ++INTERFACE pointer gensym(scheme *sc) { ++ pointer x; ++ char name[40]; ++ ++ for(; sc->gensym_cntgensym_cnt++) { ++ snprintf(name,40,"gensym-%ld",sc->gensym_cnt); ++ ++ /* first check oblist */ ++ x = oblist_find_by_name(sc, name); ++ ++ if (x != sc->NIL) { ++ continue; ++ } else { ++ x = oblist_add_by_name(sc, name); ++ return (x); ++ } ++ } ++ ++ return sc->NIL; ++} ++ ++/* make symbol or number atom from string */ ++static pointer mk_atom(scheme *sc, char *q) { ++ char c, *p; ++ int has_dec_point=0; ++ int has_fp_exp = 0; ++ ++#if USE_COLON_HOOK ++ if((p=strstr(q,"::"))!=0) { ++ *p=0; ++ return cons(sc, sc->COLON_HOOK, ++ cons(sc, ++ cons(sc, ++ sc->QUOTE, ++ cons(sc, mk_atom(sc,p+2), sc->NIL)), ++ cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL))); ++ } ++#endif ++ ++ p = q; ++ c = *p++; ++ if ((c == '+') || (c == '-')) { ++ c = *p++; ++ if (c == '.') { ++ has_dec_point=1; ++ c = *p++; ++ } ++ if (!isdigit(c)) { ++ return (mk_symbol(sc, strlwr(q))); ++ } ++ } else if (c == '.') { ++ has_dec_point=1; ++ c = *p++; ++ if (!isdigit(c)) { ++ return (mk_symbol(sc, strlwr(q))); ++ } ++ } else if (!isdigit(c)) { ++ return (mk_symbol(sc, strlwr(q))); ++ } ++ ++ for ( ; (c = *p) != 0; ++p) { ++ if (!isdigit(c)) { ++ if(c=='.') { ++ if(!has_dec_point) { ++ has_dec_point=1; ++ continue; ++ } ++ } ++ else if ((c == 'e') || (c == 'E')) { ++ if(!has_fp_exp) { ++ has_dec_point = 1; /* decimal point illegal ++ from now on */ ++ p++; ++ if ((*p == '-') || (*p == '+') || isdigit(*p)) { ++ continue; ++ } ++ } ++ } ++ return (mk_symbol(sc, strlwr(q))); ++ } ++ } ++ if(has_dec_point) { ++ return mk_real(sc,atof(q)); ++ } ++ return (mk_integer(sc, atol(q))); ++} ++ ++/* make constant */ ++static pointer mk_sharp_const(scheme *sc, char *name) { ++ long x; ++ char tmp[STRBUFFSIZE]; ++ ++ if (!strcmp(name, "t")) ++ return (sc->T); ++ else if (!strcmp(name, "f")) ++ return (sc->F); ++ else if (*name == 'o') {/* #o (octal) */ ++ snprintf(tmp, STRBUFFSIZE, "0%s", name+1); ++ sscanf(tmp, "%lo", (long unsigned *)&x); ++ return (mk_integer(sc, x)); ++ } else if (*name == 'd') { /* #d (decimal) */ ++ sscanf(name+1, "%ld", (long int *)&x); ++ return (mk_integer(sc, x)); ++ } else if (*name == 'x') { /* #x (hex) */ ++ snprintf(tmp, STRBUFFSIZE, "0x%s", name+1); ++ sscanf(tmp, "%lx", (long unsigned *)&x); ++ return (mk_integer(sc, x)); ++ } else if (*name == 'b') { /* #b (binary) */ ++ x = binary_decode(name+1); ++ return (mk_integer(sc, x)); ++ } else if (*name == '\\') { /* #\w (character) */ ++ int c=0; ++ if(stricmp(name+1,"space")==0) { ++ c=' '; ++ } else if(stricmp(name+1,"newline")==0) { ++ c='\n'; ++ } else if(stricmp(name+1,"return")==0) { ++ c='\r'; ++ } else if(stricmp(name+1,"tab")==0) { ++ c='\t'; ++ } else if(name[1]=='x' && name[2]!=0) { ++ int c1=0; ++ if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) { ++ c=c1; ++ } else { ++ return sc->NIL; ++ } ++#if USE_ASCII_NAMES ++ } else if(is_ascii_name(name+1,&c)) { ++ /* nothing */ ++#endif ++ } else if(name[2]==0) { ++ c=name[1]; ++ } else { ++ return sc->NIL; ++ } ++ return mk_character(sc,c); ++ } else ++ return (sc->NIL); ++} ++ ++/* ========== garbage collector ========== */ ++ ++/*-- ++ * We use algorithm E (Knuth, The Art of Computer Programming Vol.1, ++ * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, ++ * for marking. ++ */ ++static void mark(pointer a) { ++ pointer t, q, p; ++ ++ t = (pointer) 0; ++ p = a; ++E2: setmark(p); ++ if(is_vector(p)) { ++ int i; ++ int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2; ++ for(i=0; igc_verbose) { ++ putstr(sc, "gc..."); ++ } ++ ++ /* mark system globals */ ++ mark(sc->oblist); ++ mark(sc->global_env); ++ ++ /* mark current registers */ ++ mark(sc->args); ++ mark(sc->envir); ++ mark(sc->code); ++ dump_stack_mark(sc); ++ mark(sc->value); ++ mark(sc->inport); ++ mark(sc->save_inport); ++ mark(sc->outport); ++ mark(sc->loadport); ++ ++ /* Mark recent objects the interpreter doesn't know about yet. */ ++ mark(car(sc->sink)); ++ /* Mark any older stuff above nested C calls */ ++ mark(sc->c_nest); ++ ++ /* mark variables a, b */ ++ mark(a); ++ mark(b); ++ ++ /* garbage collect */ ++ clrmark(sc->NIL); ++ sc->fcells = 0; ++ sc->free_cell = sc->NIL; ++ /* free-list is kept sorted by address so as to maintain consecutive ++ ranges, if possible, for use with vectors. Here we scan the cells ++ (which are also kept sorted by address) downwards to build the ++ free-list in sorted order. ++ */ ++ for (i = sc->last_cell_seg; i >= 0; i--) { ++ p = sc->cell_seg[i] + CELL_SEGSIZE; ++ while (--p >= sc->cell_seg[i]) { ++ if (is_mark(p)) { ++ clrmark(p); ++ } else { ++ /* reclaim cell */ ++ if (typeflag(p) != 0) { ++ finalize_cell(sc, p); ++ typeflag(p) = 0; ++ car(p) = sc->NIL; ++ } ++ ++sc->fcells; ++ cdr(p) = sc->free_cell; ++ sc->free_cell = p; ++ } ++ } ++ } ++ ++ if (sc->gc_verbose) { ++ char msg[80]; ++ snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells); ++ putstr(sc,msg); ++ } ++} ++ ++static void finalize_cell(scheme *sc, pointer a) { ++ if(is_string(a)) { ++ sc->free(strvalue(a)); ++ } else if(is_port(a)) { ++ if(a->_object._port->kind&port_file ++ && a->_object._port->rep.stdio.closeit) { ++ port_close(sc,a,port_input|port_output); ++ } ++ sc->free(a->_object._port); ++ } ++} ++ ++/* ========== Routines for Reading ========== */ ++ ++static int file_push(scheme *sc, const char *fname) { ++ FILE *fin = NULL; ++ ++ if (sc->file_i == MAXFIL-1) ++ return 0; ++ fin=fopen(fname,"r"); ++ if(fin!=0) { ++ sc->file_i++; ++ sc->load_stack[sc->file_i].kind=port_file|port_input; ++ sc->load_stack[sc->file_i].rep.stdio.file=fin; ++ sc->load_stack[sc->file_i].rep.stdio.closeit=1; ++ sc->nesting_stack[sc->file_i]=0; ++ sc->loadport->_object._port=sc->load_stack+sc->file_i; ++ ++#if SHOW_ERROR_LINE ++ sc->load_stack[sc->file_i].rep.stdio.curr_line = 0; ++ if(fname) ++ sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0); ++#endif ++ } ++ return fin!=0; ++} ++ ++static void file_pop(scheme *sc) { ++ if(sc->file_i != 0) { ++ sc->nesting=sc->nesting_stack[sc->file_i]; ++ port_close(sc,sc->loadport,port_input); ++ sc->file_i--; ++ sc->loadport->_object._port=sc->load_stack+sc->file_i; ++ } ++} ++ ++static int file_interactive(scheme *sc) { ++ return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin ++ && sc->inport->_object._port->kind&port_file; ++} ++ ++static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) { ++ FILE *f; ++ char *rw; ++ port *pt; ++ if(prop==(port_input|port_output)) { ++ rw="a+"; ++ } else if(prop==port_output) { ++ rw="w"; ++ } else { ++ rw="r"; ++ } ++ f=fopen(fn,rw); ++ if(f==0) { ++ return 0; ++ } ++ pt=port_rep_from_file(sc,f,prop); ++ pt->rep.stdio.closeit=1; ++ ++#if SHOW_ERROR_LINE ++ if(fn) ++ pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0); ++ ++ pt->rep.stdio.curr_line = 0; ++#endif ++ return pt; ++} ++ ++static pointer port_from_filename(scheme *sc, const char *fn, int prop) { ++ port *pt; ++ pt=port_rep_from_filename(sc,fn,prop); ++ if(pt==0) { ++ return sc->NIL; ++ } ++ return mk_port(sc,pt); ++} ++ ++static port *port_rep_from_file(scheme *sc, FILE *f, int prop) ++{ ++ port *pt; ++ ++ pt = (port *)sc->malloc(sizeof *pt); ++ if (pt == NULL) { ++ return NULL; ++ } ++ pt->kind = port_file | prop; ++ pt->rep.stdio.file = f; ++ pt->rep.stdio.closeit = 0; ++ return pt; ++} ++ ++static pointer port_from_file(scheme *sc, FILE *f, int prop) { ++ port *pt; ++ pt=port_rep_from_file(sc,f,prop); ++ if(pt==0) { ++ return sc->NIL; ++ } ++ return mk_port(sc,pt); ++} ++ ++static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) { ++ port *pt; ++ pt=(port*)sc->malloc(sizeof(port)); ++ if(pt==0) { ++ return 0; ++ } ++ pt->kind=port_string|prop; ++ pt->rep.string.start=start; ++ pt->rep.string.curr=start; ++ pt->rep.string.past_the_end=past_the_end; ++ return pt; ++} ++ ++static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) { ++ port *pt; ++ pt=port_rep_from_string(sc,start,past_the_end,prop); ++ if(pt==0) { ++ return sc->NIL; ++ } ++ return mk_port(sc,pt); ++} ++ ++#define BLOCK_SIZE 256 ++ ++static port *port_rep_from_scratch(scheme *sc) { ++ port *pt; ++ char *start; ++ pt=(port*)sc->malloc(sizeof(port)); ++ if(pt==0) { ++ return 0; ++ } ++ start=sc->malloc(BLOCK_SIZE); ++ if(start==0) { ++ return 0; ++ } ++ memset(start,' ',BLOCK_SIZE-1); ++ start[BLOCK_SIZE-1]='\0'; ++ pt->kind=port_string|port_output|port_srfi6; ++ pt->rep.string.start=start; ++ pt->rep.string.curr=start; ++ pt->rep.string.past_the_end=start+BLOCK_SIZE-1; ++ return pt; ++} ++ ++static pointer port_from_scratch(scheme *sc) { ++ port *pt; ++ pt=port_rep_from_scratch(sc); ++ if(pt==0) { ++ return sc->NIL; ++ } ++ return mk_port(sc,pt); ++} ++ ++static void port_close(scheme *sc, pointer p, int flag) { ++ port *pt=p->_object._port; ++ pt->kind&=~flag; ++ if((pt->kind & (port_input|port_output))==0) { ++ if(pt->kind&port_file) { ++ ++#if SHOW_ERROR_LINE ++ /* Cleanup is here so (close-*-port) functions could work too */ ++ pt->rep.stdio.curr_line = 0; ++ ++ if(pt->rep.stdio.filename) ++ sc->free(pt->rep.stdio.filename); ++#endif ++ ++ fclose(pt->rep.stdio.file); ++ } ++ pt->kind=port_free; ++ } ++} ++ ++/* get new character from input file */ ++static int inchar(scheme *sc) { ++ int c; ++ port *pt; ++ ++ pt = sc->inport->_object._port; ++ if(pt->kind & port_saw_EOF) ++ { return EOF; } ++ c = basic_inchar(pt); ++ if(c == EOF && sc->inport == sc->loadport) { ++ /* Instead, set port_saw_EOF */ ++ pt->kind |= port_saw_EOF; ++ ++ /* file_pop(sc); */ ++ return EOF; ++ /* NOTREACHED */ ++ } ++ return c; ++} ++ ++static int basic_inchar(port *pt) { ++ if(pt->kind & port_file) { ++ return fgetc(pt->rep.stdio.file); ++ } else { ++ if(*pt->rep.string.curr == 0 || ++ pt->rep.string.curr == pt->rep.string.past_the_end) { ++ return EOF; ++ } else { ++ return *pt->rep.string.curr++; ++ } ++ } ++} ++ ++/* back character to input buffer */ ++static void backchar(scheme *sc, int c) { ++ port *pt; ++ if(c==EOF) return; ++ pt=sc->inport->_object._port; ++ if(pt->kind&port_file) { ++ ungetc(c,pt->rep.stdio.file); ++ } else { ++ if(pt->rep.string.curr!=pt->rep.string.start) { ++ --pt->rep.string.curr; ++ } ++ } ++} ++ ++static int realloc_port_string(scheme *sc, port *p) ++{ ++ char *start=p->rep.string.start; ++ size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE; ++ char *str=sc->malloc(new_size); ++ if(str) { ++ memset(str,' ',new_size-1); ++ str[new_size-1]='\0'; ++ strcpy(str,start); ++ p->rep.string.start=str; ++ p->rep.string.past_the_end=str+new_size-1; ++ p->rep.string.curr-=start-str; ++ sc->free(start); ++ return 1; ++ } else { ++ return 0; ++ } ++} ++ ++INTERFACE void putstr(scheme *sc, const char *s) { ++ port *pt=sc->outport->_object._port; ++ if(pt->kind&port_file) { ++ fputs(s,pt->rep.stdio.file); ++ } else { ++ for(;*s;s++) { ++ if(pt->rep.string.curr!=pt->rep.string.past_the_end) { ++ *pt->rep.string.curr++=*s; ++ } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { ++ *pt->rep.string.curr++=*s; ++ } ++ } ++ } ++} ++ ++static void putchars(scheme *sc, const char *s, int len) { ++ port *pt=sc->outport->_object._port; ++ if(pt->kind&port_file) { ++ fwrite(s,1,len,pt->rep.stdio.file); ++ } else { ++ for(;len;len--) { ++ if(pt->rep.string.curr!=pt->rep.string.past_the_end) { ++ *pt->rep.string.curr++=*s++; ++ } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { ++ *pt->rep.string.curr++=*s++; ++ } ++ } ++ } ++} ++ ++INTERFACE void putcharacter(scheme *sc, int c) { ++ port *pt=sc->outport->_object._port; ++ if(pt->kind&port_file) { ++ fputc(c,pt->rep.stdio.file); ++ } else { ++ if(pt->rep.string.curr!=pt->rep.string.past_the_end) { ++ *pt->rep.string.curr++=c; ++ } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) { ++ *pt->rep.string.curr++=c; ++ } ++ } ++} ++ ++/* read characters up to delimiter, but cater to character constants */ ++static char *readstr_upto(scheme *sc, char *delim) { ++ char *p = sc->strbuff; ++ ++ while ((p - sc->strbuff < sizeof(sc->strbuff)) && ++ !is_one_of(delim, (*p++ = inchar(sc)))); ++ ++ if(p == sc->strbuff+2 && p[-2] == '\\') { ++ *p=0; ++ } else { ++ backchar(sc,p[-1]); ++ *--p = '\0'; ++ } ++ return sc->strbuff; ++} ++ ++/* read string expression "xxx...xxx" */ ++static pointer readstrexp(scheme *sc) { ++ char *p = sc->strbuff; ++ int c; ++ int c1=0; ++ enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok; ++ ++ for (;;) { ++ c=inchar(sc); ++ if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) { ++ return sc->F; ++ } ++ switch(state) { ++ case st_ok: ++ switch(c) { ++ case '\\': ++ state=st_bsl; ++ break; ++ case '"': ++ *p=0; ++ return mk_counted_string(sc,sc->strbuff,p-sc->strbuff); ++ default: ++ *p++=c; ++ break; ++ } ++ break; ++ case st_bsl: ++ switch(c) { ++ case '0': ++ case '1': ++ case '2': ++ case '3': ++ case '4': ++ case '5': ++ case '6': ++ case '7': ++ state=st_oct1; ++ c1=c-'0'; ++ break; ++ case 'x': ++ case 'X': ++ state=st_x1; ++ c1=0; ++ break; ++ case 'n': ++ *p++='\n'; ++ state=st_ok; ++ break; ++ case 't': ++ *p++='\t'; ++ state=st_ok; ++ break; ++ case 'r': ++ *p++='\r'; ++ state=st_ok; ++ break; ++ case '"': ++ *p++='"'; ++ state=st_ok; ++ break; ++ default: ++ *p++=c; ++ state=st_ok; ++ break; ++ } ++ break; ++ case st_x1: ++ case st_x2: ++ c=toupper(c); ++ if(c>='0' && c<='F') { ++ if(c<='9') { ++ c1=(c1<<4)+c-'0'; ++ } else { ++ c1=(c1<<4)+c-'A'+10; ++ } ++ if(state==st_x1) { ++ state=st_x2; ++ } else { ++ *p++=c1; ++ state=st_ok; ++ } ++ } else { ++ return sc->F; ++ } ++ break; ++ case st_oct1: ++ case st_oct2: ++ if (c < '0' || c > '7') ++ { ++ *p++=c1; ++ backchar(sc, c); ++ state=st_ok; ++ } ++ else ++ { ++ if (state==st_oct2 && c1 >= 32) ++ return sc->F; ++ ++ c1=(c1<<3)+(c-'0'); ++ ++ if (state == st_oct1) ++ state=st_oct2; ++ else ++ { ++ *p++=c1; ++ state=st_ok; ++ } ++ } ++ break; ++ ++ } ++ } ++} ++ ++/* check c is in chars */ ++static INLINE int is_one_of(char *s, int c) { ++ if(c==EOF) return 1; ++ while (*s) ++ if (*s++ == c) ++ return (1); ++ return (0); ++} ++ ++/* skip white characters */ ++static INLINE int skipspace(scheme *sc) { ++ int c = 0, curr_line = 0; ++ ++ do { ++ c=inchar(sc); ++#if SHOW_ERROR_LINE ++ if(c=='\n') ++ curr_line++; ++#endif ++ } while (isspace(c)); ++ ++/* record it */ ++#if SHOW_ERROR_LINE ++ if (sc->load_stack[sc->file_i].kind & port_file) ++ sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line; ++#endif ++ ++ if(c!=EOF) { ++ backchar(sc,c); ++ return 1; ++ } ++ else ++ { return EOF; } ++} ++ ++/* get token */ ++static int token(scheme *sc) { ++ int c; ++ c = skipspace(sc); ++ if(c == EOF) { return (TOK_EOF); } ++ switch (c=inchar(sc)) { ++ case EOF: ++ return (TOK_EOF); ++ case '(': ++ return (TOK_LPAREN); ++ case ')': ++ return (TOK_RPAREN); ++ case '.': ++ c=inchar(sc); ++ if(is_one_of(" \n\t",c)) { ++ return (TOK_DOT); ++ } else { ++ backchar(sc,c); ++ backchar(sc,'.'); ++ return TOK_ATOM; ++ } ++ case '\'': ++ return (TOK_QUOTE); ++ case ';': ++ while ((c=inchar(sc)) != '\n' && c!=EOF) ++ ; ++ ++#if SHOW_ERROR_LINE ++ if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) ++ sc->load_stack[sc->file_i].rep.stdio.curr_line++; ++#endif ++ ++ if(c == EOF) ++ { return (TOK_EOF); } ++ else ++ { return (token(sc));} ++ case '"': ++ return (TOK_DQUOTE); ++ case BACKQUOTE: ++ return (TOK_BQUOTE); ++ case ',': ++ if ((c=inchar(sc)) == '@') { ++ return (TOK_ATMARK); ++ } else { ++ backchar(sc,c); ++ return (TOK_COMMA); ++ } ++ case '#': ++ c=inchar(sc); ++ if (c == '(') { ++ return (TOK_VEC); ++ } else if(c == '!') { ++ while ((c=inchar(sc)) != '\n' && c!=EOF) ++ ; ++ ++#if SHOW_ERROR_LINE ++ if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file) ++ sc->load_stack[sc->file_i].rep.stdio.curr_line++; ++#endif ++ ++ if(c == EOF) ++ { return (TOK_EOF); } ++ else ++ { return (token(sc));} ++ } else { ++ backchar(sc,c); ++ if(is_one_of(" tfodxb\\",c)) { ++ return TOK_SHARP_CONST; ++ } else { ++ return (TOK_SHARP); ++ } ++ } ++ default: ++ backchar(sc,c); ++ return (TOK_ATOM); ++ } ++} ++ ++/* ========== Routines for Printing ========== */ ++#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL) ++ ++static void printslashstring(scheme *sc, char *p, int len) { ++ int i; ++ unsigned char *s=(unsigned char*)p; ++ putcharacter(sc,'"'); ++ for ( i=0; iNIL) { ++ p = "()"; ++ } else if (l == sc->T) { ++ p = "#t"; ++ } else if (l == sc->F) { ++ p = "#f"; ++ } else if (l == sc->EOF_OBJ) { ++ p = "#"; ++ } else if (is_port(l)) { ++ p = sc->strbuff; ++ snprintf(p, STRBUFFSIZE, "#"); ++ } else if (is_number(l)) { ++ p = sc->strbuff; ++ if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ { ++ if(num_is_integer(l)) { ++ snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l)); ++ } else { ++ snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l)); ++ /* r5rs says there must be a '.' (unless 'e'?) */ ++ f = strcspn(p, ".e"); ++ if (p[f] == 0) { ++ p[f] = '.'; /* not found, so add '.0' at the end */ ++ p[f+1] = '0'; ++ p[f+2] = 0; ++ } ++ } ++ } else { ++ long v = ivalue(l); ++ if (f == 16) { ++ if (v >= 0) ++ snprintf(p, STRBUFFSIZE, "%lx", v); ++ else ++ snprintf(p, STRBUFFSIZE, "-%lx", -v); ++ } else if (f == 8) { ++ if (v >= 0) ++ snprintf(p, STRBUFFSIZE, "%lo", v); ++ else ++ snprintf(p, STRBUFFSIZE, "-%lo", -v); ++ } else if (f == 2) { ++ unsigned long b = (v < 0) ? -v : v; ++ p = &p[STRBUFFSIZE-1]; ++ *p = 0; ++ do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0); ++ if (v < 0) *--p = '-'; ++ } ++ } ++ } else if (is_string(l)) { ++ if (!f) { ++ p = strvalue(l); ++ } else { /* Hack, uses the fact that printing is needed */ ++ *pp=sc->strbuff; ++ *plen=0; ++ printslashstring(sc, strvalue(l), strlength(l)); ++ return; ++ } ++ } else if (is_character(l)) { ++ int c=charvalue(l); ++ p = sc->strbuff; ++ if (!f) { ++ p[0]=c; ++ p[1]=0; ++ } else { ++ switch(c) { ++ case ' ': ++ snprintf(p,STRBUFFSIZE,"#\\space"); break; ++ case '\n': ++ snprintf(p,STRBUFFSIZE,"#\\newline"); break; ++ case '\r': ++ snprintf(p,STRBUFFSIZE,"#\\return"); break; ++ case '\t': ++ snprintf(p,STRBUFFSIZE,"#\\tab"); break; ++ default: ++#if USE_ASCII_NAMES ++ if(c==127) { ++ snprintf(p,STRBUFFSIZE, "#\\del"); ++ break; ++ } else if(c<32) { ++ snprintf(p, STRBUFFSIZE, "#\\%s", charnames[c]); ++ break; ++ } ++#else ++ if(c<32) { ++ snprintf(p,STRBUFFSIZE,"#\\x%x",c); break; ++ break; ++ } ++#endif ++ snprintf(p,STRBUFFSIZE,"#\\%c",c); break; ++ break; ++ } ++ } ++ } else if (is_symbol(l)) { ++ p = symname(l); ++ } else if (is_proc(l)) { ++ p = sc->strbuff; ++ snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l)); ++ } else if (is_macro(l)) { ++ p = "#"; ++ } else if (is_closure(l)) { ++ p = "#"; ++ } else if (is_promise(l)) { ++ p = "#"; ++ } else if (is_foreign(l)) { ++ p = sc->strbuff; ++ snprintf(p,STRBUFFSIZE,"#", procnum(l)); ++ } else if (is_continuation(l)) { ++ p = "#"; ++ } else { ++ p = "#"; ++ } ++ *pp=p; ++ *plen=strlen(p); ++} ++/* ========== Routines for Evaluation Cycle ========== */ ++ ++/* make closure. c is code. e is environment */ ++static pointer mk_closure(scheme *sc, pointer c, pointer e) { ++ pointer x = get_cell(sc, c, e); ++ ++ typeflag(x) = T_CLOSURE; ++ car(x) = c; ++ cdr(x) = e; ++ return (x); ++} ++ ++/* make continuation. */ ++static pointer mk_continuation(scheme *sc, pointer d) { ++ pointer x = get_cell(sc, sc->NIL, d); ++ ++ typeflag(x) = T_CONTINUATION; ++ cont_dump(x) = d; ++ return (x); ++} ++ ++static pointer list_star(scheme *sc, pointer d) { ++ pointer p, q; ++ if(cdr(d)==sc->NIL) { ++ return car(d); ++ } ++ p=cons(sc,car(d),cdr(d)); ++ q=p; ++ while(cdr(cdr(p))!=sc->NIL) { ++ d=cons(sc,car(p),cdr(p)); ++ if(cdr(cdr(p))!=sc->NIL) { ++ p=cdr(d); ++ } ++ } ++ cdr(p)=car(cdr(p)); ++ return q; ++} ++ ++/* reverse list -- produce new list */ ++static pointer reverse(scheme *sc, pointer a) { ++/* a must be checked by gc */ ++ pointer p = sc->NIL; ++ ++ for ( ; is_pair(a); a = cdr(a)) { ++ p = cons(sc, car(a), p); ++ } ++ return (p); ++} ++ ++/* reverse list --- in-place */ ++static pointer reverse_in_place(scheme *sc, pointer term, pointer list) { ++ pointer p = list, result = term, q; ++ ++ while (p != sc->NIL) { ++ q = cdr(p); ++ cdr(p) = result; ++ result = p; ++ p = q; ++ } ++ return (result); ++} ++ ++/* append list -- produce new list (in reverse order) */ ++static pointer revappend(scheme *sc, pointer a, pointer b) { ++ pointer result = a; ++ pointer p = b; ++ ++ while (is_pair(p)) { ++ result = cons(sc, car(p), result); ++ p = cdr(p); ++ } ++ ++ if (p == sc->NIL) { ++ return result; ++ } ++ ++ return sc->F; /* signal an error */ ++} ++ ++/* equivalence of atoms */ ++int eqv(pointer a, pointer b) { ++ if (is_string(a)) { ++ if (is_string(b)) ++ return (strvalue(a) == strvalue(b)); ++ else ++ return (0); ++ } else if (is_number(a)) { ++ if (is_number(b)) { ++ if (num_is_integer(a) == num_is_integer(b)) ++ return num_eq(nvalue(a),nvalue(b)); ++ } ++ return (0); ++ } else if (is_character(a)) { ++ if (is_character(b)) ++ return charvalue(a)==charvalue(b); ++ else ++ return (0); ++ } else if (is_port(a)) { ++ if (is_port(b)) ++ return a==b; ++ else ++ return (0); ++ } else if (is_proc(a)) { ++ if (is_proc(b)) ++ return procnum(a)==procnum(b); ++ else ++ return (0); ++ } else { ++ return (a == b); ++ } ++} ++ ++/* true or false value macro */ ++/* () is #t in R5RS */ ++#define is_true(p) ((p) != sc->F) ++#define is_false(p) ((p) == sc->F) ++ ++/* ========== Environment implementation ========== */ ++ ++#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) ++ ++static int hash_fn(const char *key, int table_size) ++{ ++ unsigned int hashed = 0; ++ const char *c; ++ int bits_per_int = sizeof(unsigned int)*8; ++ ++ for (c = key; *c; c++) { ++ /* letters have about 5 bits in them */ ++ hashed = (hashed<<5) | (hashed>>(bits_per_int-5)); ++ hashed ^= *c; ++ } ++ return hashed % table_size; ++} ++#endif ++ ++#ifndef USE_ALIST_ENV ++ ++/* ++ * In this implementation, each frame of the environment may be ++ * a hash table: a vector of alists hashed by variable name. ++ * In practice, we use a vector only for the initial frame; ++ * subsequent frames are too small and transient for the lookup ++ * speed to out-weigh the cost of making a new vector. ++ */ ++ ++static void new_frame_in_env(scheme *sc, pointer old_env) ++{ ++ pointer new_frame; ++ ++ /* The interaction-environment has about 300 variables in it. */ ++ if (old_env == sc->NIL) { ++ new_frame = mk_vector(sc, 461); ++ } else { ++ new_frame = sc->NIL; ++ } ++ ++ sc->envir = immutable_cons(sc, new_frame, old_env); ++ setenvironment(sc->envir); ++} ++ ++static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, ++ pointer variable, pointer value) ++{ ++ pointer slot = immutable_cons(sc, variable, value); ++ ++ if (is_vector(car(env))) { ++ int location = hash_fn(symname(variable), ivalue_unchecked(car(env))); ++ ++ set_vector_elem(car(env), location, ++ immutable_cons(sc, slot, vector_elem(car(env), location))); ++ } else { ++ car(env) = immutable_cons(sc, slot, car(env)); ++ } ++} ++ ++static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) ++{ ++ pointer x,y; ++ int location; ++ ++ for (x = env; x != sc->NIL; x = cdr(x)) { ++ if (is_vector(car(x))) { ++ location = hash_fn(symname(hdl), ivalue_unchecked(car(x))); ++ y = vector_elem(car(x), location); ++ } else { ++ y = car(x); ++ } ++ for ( ; y != sc->NIL; y = cdr(y)) { ++ if (caar(y) == hdl) { ++ break; ++ } ++ } ++ if (y != sc->NIL) { ++ break; ++ } ++ if(!all) { ++ return sc->NIL; ++ } ++ } ++ if (x != sc->NIL) { ++ return car(y); ++ } ++ return sc->NIL; ++} ++ ++#else /* USE_ALIST_ENV */ ++ ++static INLINE void new_frame_in_env(scheme *sc, pointer old_env) ++{ ++ sc->envir = immutable_cons(sc, sc->NIL, old_env); ++ setenvironment(sc->envir); ++} ++ ++static INLINE void new_slot_spec_in_env(scheme *sc, pointer env, ++ pointer variable, pointer value) ++{ ++ car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env)); ++} ++ ++static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all) ++{ ++ pointer x,y; ++ for (x = env; x != sc->NIL; x = cdr(x)) { ++ for (y = car(x); y != sc->NIL; y = cdr(y)) { ++ if (caar(y) == hdl) { ++ break; ++ } ++ } ++ if (y != sc->NIL) { ++ break; ++ } ++ if(!all) { ++ return sc->NIL; ++ } ++ } ++ if (x != sc->NIL) { ++ return car(y); ++ } ++ return sc->NIL; ++} ++ ++#endif /* USE_ALIST_ENV else */ ++ ++static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value) ++{ ++ new_slot_spec_in_env(sc, sc->envir, variable, value); ++} ++ ++static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value) ++{ ++ cdr(slot) = value; ++} ++ ++static INLINE pointer slot_value_in_env(pointer slot) ++{ ++ return cdr(slot); ++} ++ ++/* ========== Evaluation Cycle ========== */ ++ ++ ++static pointer _Error_1(scheme *sc, const char *s, pointer a) { ++ const char *str = s; ++#if USE_ERROR_HOOK ++ pointer x; ++ pointer hdl=sc->ERROR_HOOK; ++#endif ++ ++#if SHOW_ERROR_LINE ++ char sbuf[STRBUFFSIZE]; ++ ++ /* make sure error is not in REPL */ ++ if (sc->load_stack[sc->file_i].kind & port_file && ++ sc->load_stack[sc->file_i].rep.stdio.file != stdin) { ++ int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line; ++ const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename; ++ ++ /* should never happen */ ++ if(!fname) fname = ""; ++ ++ /* we started from 0 */ ++ ln++; ++ snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s); ++ ++ str = (const char*)sbuf; ++ } ++#endif ++ ++#if USE_ERROR_HOOK ++ x=find_slot_in_env(sc,sc->envir,hdl,1); ++ if (x != sc->NIL) { ++ if(a!=0) { ++ sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL); ++ } else { ++ sc->code = sc->NIL; ++ } ++ sc->code = cons(sc, mk_string(sc, str), sc->code); ++ setimmutable(car(sc->code)); ++ sc->code = cons(sc, slot_value_in_env(x), sc->code); ++ sc->op = (int)OP_EVAL; ++ return sc->T; ++ } ++#endif ++ ++ if(a!=0) { ++ sc->args = cons(sc, (a), sc->NIL); ++ } else { ++ sc->args = sc->NIL; ++ } ++ sc->args = cons(sc, mk_string(sc, str), sc->args); ++ setimmutable(car(sc->args)); ++ sc->op = (int)OP_ERR0; ++ return sc->T; ++} ++#define Error_1(sc,s, a) return _Error_1(sc,s,a) ++#define Error_0(sc,s) return _Error_1(sc,s,0) ++ ++/* Too small to turn into function */ ++# define BEGIN do { ++# define END } while (0) ++#define s_goto(sc,a) BEGIN \ ++ sc->op = (int)(a); \ ++ return sc->T; END ++ ++#define s_return(sc,a) return _s_return(sc,a) ++ ++#ifndef USE_SCHEME_STACK ++ ++/* this structure holds all the interpreter's registers */ ++struct dump_stack_frame { ++ enum scheme_opcodes op; ++ pointer args; ++ pointer envir; ++ pointer code; ++}; ++ ++#define STACK_GROWTH 3 ++ ++static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) ++{ ++ int nframes = (int)sc->dump; ++ struct dump_stack_frame *next_frame; ++ ++ /* enough room for the next frame? */ ++ if (nframes >= sc->dump_size) { ++ sc->dump_size += STACK_GROWTH; ++ /* alas there is no sc->realloc */ ++ sc->dump_base = realloc(sc->dump_base, ++ sizeof(struct dump_stack_frame) * sc->dump_size); ++ } ++ next_frame = (struct dump_stack_frame *)sc->dump_base + nframes; ++ next_frame->op = op; ++ next_frame->args = args; ++ next_frame->envir = sc->envir; ++ next_frame->code = code; ++ sc->dump = (pointer)(nframes+1); ++} ++ ++static pointer _s_return(scheme *sc, pointer a) ++{ ++ int nframes = (int)sc->dump; ++ struct dump_stack_frame *frame; ++ ++ sc->value = (a); ++ if (nframes <= 0) { ++ return sc->NIL; ++ } ++ nframes--; ++ frame = (struct dump_stack_frame *)sc->dump_base + nframes; ++ sc->op = frame->op; ++ sc->args = frame->args; ++ sc->envir = frame->envir; ++ sc->code = frame->code; ++ sc->dump = (pointer)nframes; ++ return sc->T; ++} ++ ++static INLINE void dump_stack_reset(scheme *sc) ++{ ++ /* in this implementation, sc->dump is the number of frames on the stack */ ++ sc->dump = (pointer)0; ++} ++ ++static INLINE void dump_stack_initialize(scheme *sc) ++{ ++ sc->dump_size = 0; ++ sc->dump_base = NULL; ++ dump_stack_reset(sc); ++} ++ ++static void dump_stack_free(scheme *sc) ++{ ++ free(sc->dump_base); ++ sc->dump_base = NULL; ++ sc->dump = (pointer)0; ++ sc->dump_size = 0; ++} ++ ++static INLINE void dump_stack_mark(scheme *sc) ++{ ++ int nframes = (int)sc->dump; ++ int i; ++ for(i=0; idump_base + i; ++ mark(frame->args); ++ mark(frame->envir); ++ mark(frame->code); ++ } ++} ++ ++#else ++ ++static INLINE void dump_stack_reset(scheme *sc) ++{ ++ sc->dump = sc->NIL; ++} ++ ++static INLINE void dump_stack_initialize(scheme *sc) ++{ ++ dump_stack_reset(sc); ++} ++ ++static void dump_stack_free(scheme *sc) ++{ ++ sc->dump = sc->NIL; ++} ++ ++static pointer _s_return(scheme *sc, pointer a) { ++ sc->value = (a); ++ if(sc->dump==sc->NIL) return sc->NIL; ++ sc->op = ivalue(car(sc->dump)); ++ sc->args = cadr(sc->dump); ++ sc->envir = caddr(sc->dump); ++ sc->code = cadddr(sc->dump); ++ sc->dump = cddddr(sc->dump); ++ return sc->T; ++} ++ ++static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) { ++ sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump)); ++ sc->dump = cons(sc, (args), sc->dump); ++ sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump); ++} ++ ++static INLINE void dump_stack_mark(scheme *sc) ++{ ++ mark(sc->dump); ++} ++#endif ++ ++#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F) ++ ++static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { ++ pointer x, y; ++ ++ switch (op) { ++ case OP_LOAD: /* load */ ++ if(file_interactive(sc)) { ++ fprintf(sc->outport->_object._port->rep.stdio.file, ++ "Loading %s\n", strvalue(car(sc->args))); ++ } ++ if (!file_push(sc,strvalue(car(sc->args)))) { ++ Error_1(sc,"unable to open", car(sc->args)); ++ } ++ else ++ { ++ sc->args = mk_integer(sc,sc->file_i); ++ s_goto(sc,OP_T0LVL); ++ } ++ ++ case OP_T0LVL: /* top level */ ++ /* If we reached the end of file, this loop is done. */ ++ if(sc->loadport->_object._port->kind & port_saw_EOF) ++ { ++ if(sc->file_i == 0) ++ { ++ sc->args=sc->NIL; ++ s_goto(sc,OP_QUIT); ++ } ++ else ++ { ++ file_pop(sc); ++ s_return(sc,sc->value); ++ } ++ /* NOTREACHED */ ++ } ++ ++ /* If interactive, be nice to user. */ ++ if(file_interactive(sc)) ++ { ++ sc->envir = sc->global_env; ++ dump_stack_reset(sc); ++ putstr(sc,"\n"); ++ putstr(sc,prompt); ++ } ++ ++ /* Set up another iteration of REPL */ ++ sc->nesting=0; ++ sc->save_inport=sc->inport; ++ sc->inport = sc->loadport; ++ s_save(sc,OP_T0LVL, sc->NIL, sc->NIL); ++ s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL); ++ s_save(sc,OP_T1LVL, sc->NIL, sc->NIL); ++ s_goto(sc,OP_READ_INTERNAL); ++ ++ case OP_T1LVL: /* top level */ ++ sc->code = sc->value; ++ sc->inport=sc->save_inport; ++ s_goto(sc,OP_EVAL); ++ ++ case OP_READ_INTERNAL: /* internal read */ ++ sc->tok = token(sc); ++ if(sc->tok==TOK_EOF) ++ { s_return(sc,sc->EOF_OBJ); } ++ s_goto(sc,OP_RDSEXPR); ++ ++ case OP_GENSYM: ++ s_return(sc, gensym(sc)); ++ ++ case OP_VALUEPRINT: /* print evaluation result */ ++ /* OP_VALUEPRINT is always pushed, because when changing from ++ non-interactive to interactive mode, it needs to be ++ already on the stack */ ++ if(sc->tracing) { ++ putstr(sc,"\nGives: "); ++ } ++ if(file_interactive(sc)) { ++ sc->print_flag = 1; ++ sc->args = sc->value; ++ s_goto(sc,OP_P0LIST); ++ } else { ++ s_return(sc,sc->value); ++ } ++ ++ case OP_EVAL: /* main part of evaluation */ ++#if USE_TRACING ++ if(sc->tracing) { ++ /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/ ++ s_save(sc,OP_REAL_EVAL,sc->args,sc->code); ++ sc->args=sc->code; ++ putstr(sc,"\nEval: "); ++ s_goto(sc,OP_P0LIST); ++ } ++ /* fall through */ ++ case OP_REAL_EVAL: ++#endif ++ if (is_symbol(sc->code)) { /* symbol */ ++ x=find_slot_in_env(sc,sc->envir,sc->code,1); ++ if (x != sc->NIL) { ++ s_return(sc,slot_value_in_env(x)); ++ } else { ++ Error_1(sc,"eval: unbound variable:", sc->code); ++ } ++ } else if (is_pair(sc->code)) { ++ if (is_syntax(x = car(sc->code))) { /* SYNTAX */ ++ sc->code = cdr(sc->code); ++ s_goto(sc,syntaxnum(x)); ++ } else {/* first, eval top element and eval arguments */ ++ s_save(sc,OP_E0ARGS, sc->NIL, sc->code); ++ /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/ ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ } ++ } else { ++ s_return(sc,sc->code); ++ } ++ ++ case OP_E0ARGS: /* eval arguments */ ++ if (is_macro(sc->value)) { /* macro expansion */ ++ s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL); ++ sc->args = cons(sc,sc->code, sc->NIL); ++ sc->code = sc->value; ++ s_goto(sc,OP_APPLY); ++ } else { ++ sc->code = cdr(sc->code); ++ s_goto(sc,OP_E1ARGS); ++ } ++ ++ case OP_E1ARGS: /* eval arguments */ ++ sc->args = cons(sc, sc->value, sc->args); ++ if (is_pair(sc->code)) { /* continue */ ++ s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code)); ++ sc->code = car(sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_EVAL); ++ } else { /* end */ ++ sc->args = reverse_in_place(sc, sc->NIL, sc->args); ++ sc->code = car(sc->args); ++ sc->args = cdr(sc->args); ++ s_goto(sc,OP_APPLY); ++ } ++ ++#if USE_TRACING ++ case OP_TRACING: { ++ int tr=sc->tracing; ++ sc->tracing=ivalue(car(sc->args)); ++ s_return(sc,mk_integer(sc,tr)); ++ } ++#endif ++ ++ case OP_APPLY: /* apply 'code' to 'args' */ ++#if USE_TRACING ++ if(sc->tracing) { ++ s_save(sc,OP_REAL_APPLY,sc->args,sc->code); ++ sc->print_flag = 1; ++ /* sc->args=cons(sc,sc->code,sc->args);*/ ++ putstr(sc,"\nApply to: "); ++ s_goto(sc,OP_P0LIST); ++ } ++ /* fall through */ ++ case OP_REAL_APPLY: ++#endif ++ if (is_proc(sc->code)) { ++ s_goto(sc,procnum(sc->code)); /* PROCEDURE */ ++ } else if (is_foreign(sc->code)) ++ { ++ /* Keep nested calls from GC'ing the arglist */ ++ push_recent_alloc(sc,sc->args,sc->NIL); ++ x=sc->code->_object._ff(sc,sc->args); ++ s_return(sc,x); ++ } else if (is_closure(sc->code) || is_macro(sc->code) ++ || is_promise(sc->code)) { /* CLOSURE */ ++ /* Should not accept promise */ ++ /* make environment */ ++ new_frame_in_env(sc, closure_env(sc->code)); ++ for (x = car(closure_code(sc->code)), y = sc->args; ++ is_pair(x); x = cdr(x), y = cdr(y)) { ++ if (y == sc->NIL) { ++ Error_0(sc,"not enough arguments"); ++ } else { ++ new_slot_in_env(sc, car(x), car(y)); ++ } ++ } ++ if (x == sc->NIL) { ++ /*-- ++ * if (y != sc->NIL) { ++ * Error_0(sc,"too many arguments"); ++ * } ++ */ ++ } else if (is_symbol(x)) ++ new_slot_in_env(sc, x, y); ++ else { ++ Error_1(sc,"syntax error in closure: not a symbol:", x); ++ } ++ sc->code = cdr(closure_code(sc->code)); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_BEGIN); ++ } else if (is_continuation(sc->code)) { /* CONTINUATION */ ++ sc->dump = cont_dump(sc->code); ++ s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); ++ } else { ++ Error_0(sc,"illegal function"); ++ } ++ ++ case OP_DOMACRO: /* do macro */ ++ sc->code = sc->value; ++ s_goto(sc,OP_EVAL); ++ ++#if 1 ++ case OP_LAMBDA: /* lambda */ ++ /* If the hook is defined, apply it to sc->code, otherwise ++ set sc->value fall thru */ ++ { ++ pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1); ++ if(f==sc->NIL) { ++ sc->value = sc->code; ++ /* Fallthru */ ++ } else { ++ s_save(sc,OP_LAMBDA1,sc->args,sc->code); ++ sc->args=cons(sc,sc->code,sc->NIL); ++ sc->code=slot_value_in_env(f); ++ s_goto(sc,OP_APPLY); ++ } ++ } ++ ++ case OP_LAMBDA1: ++ s_return(sc,mk_closure(sc, sc->value, sc->envir)); ++ ++#else ++ case OP_LAMBDA: /* lambda */ ++ s_return(sc,mk_closure(sc, sc->code, sc->envir)); ++ ++#endif ++ ++ case OP_MKCLOSURE: /* make-closure */ ++ x=car(sc->args); ++ if(car(x)==sc->LAMBDA) { ++ x=cdr(x); ++ } ++ if(cdr(sc->args)==sc->NIL) { ++ y=sc->envir; ++ } else { ++ y=cadr(sc->args); ++ } ++ s_return(sc,mk_closure(sc, x, y)); ++ ++ case OP_QUOTE: /* quote */ ++ s_return(sc,car(sc->code)); ++ ++ case OP_DEF0: /* define */ ++ if(is_immutable(car(sc->code))) ++ Error_1(sc,"define: unable to alter immutable", car(sc->code)); ++ ++ if (is_pair(car(sc->code))) { ++ x = caar(sc->code); ++ sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); ++ } else { ++ x = car(sc->code); ++ sc->code = cadr(sc->code); ++ } ++ if (!is_symbol(x)) { ++ Error_0(sc,"variable is not a symbol"); ++ } ++ s_save(sc,OP_DEF1, sc->NIL, x); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_DEF1: /* define */ ++ x=find_slot_in_env(sc,sc->envir,sc->code,0); ++ if (x != sc->NIL) { ++ set_slot_in_env(sc, x, sc->value); ++ } else { ++ new_slot_in_env(sc, sc->code, sc->value); ++ } ++ s_return(sc,sc->code); ++ ++ ++ case OP_DEFP: /* defined? */ ++ x=sc->envir; ++ if(cdr(sc->args)!=sc->NIL) { ++ x=cadr(sc->args); ++ } ++ s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL); ++ ++ case OP_SET0: /* set! */ ++ if(is_immutable(car(sc->code))) ++ Error_1(sc,"set!: unable to alter immutable variable",car(sc->code)); ++ s_save(sc,OP_SET1, sc->NIL, car(sc->code)); ++ sc->code = cadr(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_SET1: /* set! */ ++ y=find_slot_in_env(sc,sc->envir,sc->code,1); ++ if (y != sc->NIL) { ++ set_slot_in_env(sc, y, sc->value); ++ s_return(sc,sc->value); ++ } else { ++ Error_1(sc,"set!: unbound variable:", sc->code); ++ } ++ ++ ++ case OP_BEGIN: /* begin */ ++ if (!is_pair(sc->code)) { ++ s_return(sc,sc->code); ++ } ++ if (cdr(sc->code) != sc->NIL) { ++ s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code)); ++ } ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_IF0: /* if */ ++ s_save(sc,OP_IF1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_IF1: /* if */ ++ if (is_true(sc->value)) ++ sc->code = car(sc->code); ++ else ++ sc->code = cadr(sc->code); /* (if #f 1) ==> () because ++ * car(sc->NIL) = sc->NIL */ ++ s_goto(sc,OP_EVAL); ++ ++ case OP_LET0: /* let */ ++ sc->args = sc->NIL; ++ sc->value = sc->code; ++ sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code); ++ s_goto(sc,OP_LET1); ++ ++ case OP_LET1: /* let (calculate parameters) */ ++ sc->args = cons(sc, sc->value, sc->args); ++ if (is_pair(sc->code)) { /* continue */ ++ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { ++ Error_1(sc, "Bad syntax of binding spec in let :", ++ car(sc->code)); ++ } ++ s_save(sc,OP_LET1, sc->args, cdr(sc->code)); ++ sc->code = cadar(sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_EVAL); ++ } else { /* end */ ++ sc->args = reverse_in_place(sc, sc->NIL, sc->args); ++ sc->code = car(sc->args); ++ sc->args = cdr(sc->args); ++ s_goto(sc,OP_LET2); ++ } ++ ++ case OP_LET2: /* let */ ++ new_frame_in_env(sc, sc->envir); ++ for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args; ++ y != sc->NIL; x = cdr(x), y = cdr(y)) { ++ new_slot_in_env(sc, caar(x), car(y)); ++ } ++ if (is_symbol(car(sc->code))) { /* named let */ ++ for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) { ++ if (!is_pair(x)) ++ Error_1(sc, "Bad syntax of binding in let :", x); ++ if (!is_list(sc, car(x))) ++ Error_1(sc, "Bad syntax of binding in let :", car(x)); ++ sc->args = cons(sc, caar(x), sc->args); ++ } ++ x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir); ++ new_slot_in_env(sc, car(sc->code), x); ++ sc->code = cddr(sc->code); ++ sc->args = sc->NIL; ++ } else { ++ sc->code = cdr(sc->code); ++ sc->args = sc->NIL; ++ } ++ s_goto(sc,OP_BEGIN); ++ ++ case OP_LET0AST: /* let* */ ++ if (car(sc->code) == sc->NIL) { ++ new_frame_in_env(sc, sc->envir); ++ sc->code = cdr(sc->code); ++ s_goto(sc,OP_BEGIN); ++ } ++ if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) { ++ Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code)); ++ } ++ s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code)); ++ sc->code = cadaar(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_LET1AST: /* let* (make new frame) */ ++ new_frame_in_env(sc, sc->envir); ++ s_goto(sc,OP_LET2AST); ++ ++ case OP_LET2AST: /* let* (calculate parameters) */ ++ new_slot_in_env(sc, caar(sc->code), sc->value); ++ sc->code = cdr(sc->code); ++ if (is_pair(sc->code)) { /* continue */ ++ s_save(sc,OP_LET2AST, sc->args, sc->code); ++ sc->code = cadar(sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_EVAL); ++ } else { /* end */ ++ sc->code = sc->args; ++ sc->args = sc->NIL; ++ s_goto(sc,OP_BEGIN); ++ } ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ } ++ return sc->T; ++} ++ ++static pointer opexe_1(scheme *sc, enum scheme_opcodes op) { ++ pointer x, y; ++ ++ switch (op) { ++ case OP_LET0REC: /* letrec */ ++ new_frame_in_env(sc, sc->envir); ++ sc->args = sc->NIL; ++ sc->value = sc->code; ++ sc->code = car(sc->code); ++ s_goto(sc,OP_LET1REC); ++ ++ case OP_LET1REC: /* letrec (calculate parameters) */ ++ sc->args = cons(sc, sc->value, sc->args); ++ if (is_pair(sc->code)) { /* continue */ ++ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) { ++ Error_1(sc, "Bad syntax of binding spec in letrec :", ++ car(sc->code)); ++ } ++ s_save(sc,OP_LET1REC, sc->args, cdr(sc->code)); ++ sc->code = cadar(sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_EVAL); ++ } else { /* end */ ++ sc->args = reverse_in_place(sc, sc->NIL, sc->args); ++ sc->code = car(sc->args); ++ sc->args = cdr(sc->args); ++ s_goto(sc,OP_LET2REC); ++ } ++ ++ case OP_LET2REC: /* letrec */ ++ for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) { ++ new_slot_in_env(sc, caar(x), car(y)); ++ } ++ sc->code = cdr(sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_BEGIN); ++ ++ case OP_COND0: /* cond */ ++ if (!is_pair(sc->code)) { ++ Error_0(sc,"syntax error in cond"); ++ } ++ s_save(sc,OP_COND1, sc->NIL, sc->code); ++ sc->code = caar(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_COND1: /* cond */ ++ if (is_true(sc->value)) { ++ if ((sc->code = cdar(sc->code)) == sc->NIL) { ++ s_return(sc,sc->value); ++ } ++ if(car(sc->code)==sc->FEED_TO) { ++ if(!is_pair(cdr(sc->code))) { ++ Error_0(sc,"syntax error in cond"); ++ } ++ x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)); ++ sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL)); ++ s_goto(sc,OP_EVAL); ++ } ++ s_goto(sc,OP_BEGIN); ++ } else { ++ if ((sc->code = cdr(sc->code)) == sc->NIL) { ++ s_return(sc,sc->NIL); ++ } else { ++ s_save(sc,OP_COND1, sc->NIL, sc->code); ++ sc->code = caar(sc->code); ++ s_goto(sc,OP_EVAL); ++ } ++ } ++ ++ case OP_DELAY: /* delay */ ++ x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); ++ typeflag(x)=T_PROMISE; ++ s_return(sc,x); ++ ++ case OP_AND0: /* and */ ++ if (sc->code == sc->NIL) { ++ s_return(sc,sc->T); ++ } ++ s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_AND1: /* and */ ++ if (is_false(sc->value)) { ++ s_return(sc,sc->value); ++ } else if (sc->code == sc->NIL) { ++ s_return(sc,sc->value); ++ } else { ++ s_save(sc,OP_AND1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ } ++ ++ case OP_OR0: /* or */ ++ if (sc->code == sc->NIL) { ++ s_return(sc,sc->F); ++ } ++ s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_OR1: /* or */ ++ if (is_true(sc->value)) { ++ s_return(sc,sc->value); ++ } else if (sc->code == sc->NIL) { ++ s_return(sc,sc->value); ++ } else { ++ s_save(sc,OP_OR1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ } ++ ++ case OP_C0STREAM: /* cons-stream */ ++ s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_C1STREAM: /* cons-stream */ ++ sc->args = sc->value; /* save sc->value to register sc->args for gc */ ++ x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir); ++ typeflag(x)=T_PROMISE; ++ s_return(sc,cons(sc, sc->args, x)); ++ ++ case OP_MACRO0: /* macro */ ++ if (is_pair(car(sc->code))) { ++ x = caar(sc->code); ++ sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code))); ++ } else { ++ x = car(sc->code); ++ sc->code = cadr(sc->code); ++ } ++ if (!is_symbol(x)) { ++ Error_0(sc,"variable is not a symbol"); ++ } ++ s_save(sc,OP_MACRO1, sc->NIL, x); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_MACRO1: /* macro */ ++ typeflag(sc->value) = T_MACRO; ++ x = find_slot_in_env(sc, sc->envir, sc->code, 0); ++ if (x != sc->NIL) { ++ set_slot_in_env(sc, x, sc->value); ++ } else { ++ new_slot_in_env(sc, sc->code, sc->value); ++ } ++ s_return(sc,sc->code); ++ ++ case OP_CASE0: /* case */ ++ s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code)); ++ sc->code = car(sc->code); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_CASE1: /* case */ ++ for (x = sc->code; x != sc->NIL; x = cdr(x)) { ++ if (!is_pair(y = caar(x))) { ++ break; ++ } ++ for ( ; y != sc->NIL; y = cdr(y)) { ++ if (eqv(car(y), sc->value)) { ++ break; ++ } ++ } ++ if (y != sc->NIL) { ++ break; ++ } ++ } ++ if (x != sc->NIL) { ++ if (is_pair(caar(x))) { ++ sc->code = cdar(x); ++ s_goto(sc,OP_BEGIN); ++ } else {/* else */ ++ s_save(sc,OP_CASE2, sc->NIL, cdar(x)); ++ sc->code = caar(x); ++ s_goto(sc,OP_EVAL); ++ } ++ } else { ++ s_return(sc,sc->NIL); ++ } ++ ++ case OP_CASE2: /* case */ ++ if (is_true(sc->value)) { ++ s_goto(sc,OP_BEGIN); ++ } else { ++ s_return(sc,sc->NIL); ++ } ++ ++ case OP_PAPPLY: /* apply */ ++ sc->code = car(sc->args); ++ sc->args = list_star(sc,cdr(sc->args)); ++ /*sc->args = cadr(sc->args);*/ ++ s_goto(sc,OP_APPLY); ++ ++ case OP_PEVAL: /* eval */ ++ if(cdr(sc->args)!=sc->NIL) { ++ sc->envir=cadr(sc->args); ++ } ++ sc->code = car(sc->args); ++ s_goto(sc,OP_EVAL); ++ ++ case OP_CONTINUATION: /* call-with-current-continuation */ ++ sc->code = car(sc->args); ++ sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL); ++ s_goto(sc,OP_APPLY); ++ ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ } ++ return sc->T; ++} ++ ++static pointer opexe_2(scheme *sc, enum scheme_opcodes op) { ++ pointer x; ++ num v; ++#if USE_MATH ++ double dd; ++#endif ++ ++ switch (op) { ++#if USE_MATH ++ case OP_INEX2EX: /* inexact->exact */ ++ x=car(sc->args); ++ if(num_is_integer(x)) { ++ s_return(sc,x); ++ } else if(modf(rvalue_unchecked(x),&dd)==0.0) { ++ s_return(sc,mk_integer(sc,ivalue(x))); ++ } else { ++ Error_1(sc,"inexact->exact: not integral:",x); ++ } ++ ++ case OP_EXP: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, exp(rvalue(x)))); ++ ++ case OP_LOG: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, log(rvalue(x)))); ++ ++ case OP_SIN: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, sin(rvalue(x)))); ++ ++ case OP_COS: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, cos(rvalue(x)))); ++ ++ case OP_TAN: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, tan(rvalue(x)))); ++ ++ case OP_ASIN: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, asin(rvalue(x)))); ++ ++ case OP_ACOS: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, acos(rvalue(x)))); ++ ++ case OP_ATAN: ++ x=car(sc->args); ++ if(cdr(sc->args)==sc->NIL) { ++ s_return(sc, mk_real(sc, atan(rvalue(x)))); ++ } else { ++ pointer y=cadr(sc->args); ++ s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y)))); ++ } ++ ++ case OP_SQRT: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, sqrt(rvalue(x)))); ++ ++ case OP_EXPT: { ++ double result; ++ int real_result=1; ++ pointer y=cadr(sc->args); ++ x=car(sc->args); ++ if (num_is_integer(x) && num_is_integer(y)) ++ real_result=0; ++ /* This 'if' is an R5RS compatibility fix. */ ++ /* NOTE: Remove this 'if' fix for R6RS. */ ++ if (rvalue(x) == 0 && rvalue(y) < 0) { ++ result = 0.0; ++ } else { ++ result = pow(rvalue(x),rvalue(y)); ++ } ++ /* Before returning integer result make sure we can. */ ++ /* If the test fails, result is too big for integer. */ ++ if (!real_result) ++ { ++ long result_as_long = (long)result; ++ if (result != (double)result_as_long) ++ real_result = 1; ++ } ++ if (real_result) { ++ s_return(sc, mk_real(sc, result)); ++ } else { ++ s_return(sc, mk_integer(sc, result)); ++ } ++ } ++ ++ case OP_FLOOR: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, floor(rvalue(x)))); ++ ++ case OP_CEILING: ++ x=car(sc->args); ++ s_return(sc, mk_real(sc, ceil(rvalue(x)))); ++ ++ case OP_TRUNCATE : { ++ double rvalue_of_x ; ++ x=car(sc->args); ++ rvalue_of_x = rvalue(x) ; ++ if (rvalue_of_x > 0) { ++ s_return(sc, mk_real(sc, floor(rvalue_of_x))); ++ } else { ++ s_return(sc, mk_real(sc, ceil(rvalue_of_x))); ++ } ++ } ++ ++ case OP_ROUND: ++ x=car(sc->args); ++ if (num_is_integer(x)) ++ s_return(sc, x); ++ s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x)))); ++#endif ++ ++ case OP_ADD: /* + */ ++ v=num_zero; ++ for (x = sc->args; x != sc->NIL; x = cdr(x)) { ++ v=num_add(v,nvalue(car(x))); ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_MUL: /* * */ ++ v=num_one; ++ for (x = sc->args; x != sc->NIL; x = cdr(x)) { ++ v=num_mul(v,nvalue(car(x))); ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_SUB: /* - */ ++ if(cdr(sc->args)==sc->NIL) { ++ x=sc->args; ++ v=num_zero; ++ } else { ++ x = cdr(sc->args); ++ v = nvalue(car(sc->args)); ++ } ++ for (; x != sc->NIL; x = cdr(x)) { ++ v=num_sub(v,nvalue(car(x))); ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_DIV: /* / */ ++ if(cdr(sc->args)==sc->NIL) { ++ x=sc->args; ++ v=num_one; ++ } else { ++ x = cdr(sc->args); ++ v = nvalue(car(sc->args)); ++ } ++ for (; x != sc->NIL; x = cdr(x)) { ++ if (!is_zero_double(rvalue(car(x)))) ++ v=num_div(v,nvalue(car(x))); ++ else { ++ Error_0(sc,"/: division by zero"); ++ } ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_INTDIV: /* quotient */ ++ if(cdr(sc->args)==sc->NIL) { ++ x=sc->args; ++ v=num_one; ++ } else { ++ x = cdr(sc->args); ++ v = nvalue(car(sc->args)); ++ } ++ for (; x != sc->NIL; x = cdr(x)) { ++ if (ivalue(car(x)) != 0) ++ v=num_intdiv(v,nvalue(car(x))); ++ else { ++ Error_0(sc,"quotient: division by zero"); ++ } ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_REM: /* remainder */ ++ v = nvalue(car(sc->args)); ++ if (ivalue(cadr(sc->args)) != 0) ++ v=num_rem(v,nvalue(cadr(sc->args))); ++ else { ++ Error_0(sc,"remainder: division by zero"); ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_MOD: /* modulo */ ++ v = nvalue(car(sc->args)); ++ if (ivalue(cadr(sc->args)) != 0) ++ v=num_mod(v,nvalue(cadr(sc->args))); ++ else { ++ Error_0(sc,"modulo: division by zero"); ++ } ++ s_return(sc,mk_number(sc, v)); ++ ++ case OP_CAR: /* car */ ++ s_return(sc,caar(sc->args)); ++ ++ case OP_CDR: /* cdr */ ++ s_return(sc,cdar(sc->args)); ++ ++ case OP_CONS: /* cons */ ++ cdr(sc->args) = cadr(sc->args); ++ s_return(sc,sc->args); ++ ++ case OP_SETCAR: /* set-car! */ ++ if(!is_immutable(car(sc->args))) { ++ caar(sc->args) = cadr(sc->args); ++ s_return(sc,car(sc->args)); ++ } else { ++ Error_0(sc,"set-car!: unable to alter immutable pair"); ++ } ++ ++ case OP_SETCDR: /* set-cdr! */ ++ if(!is_immutable(car(sc->args))) { ++ cdar(sc->args) = cadr(sc->args); ++ s_return(sc,car(sc->args)); ++ } else { ++ Error_0(sc,"set-cdr!: unable to alter immutable pair"); ++ } ++ ++ case OP_CHAR2INT: { /* char->integer */ ++ char c; ++ c=(char)ivalue(car(sc->args)); ++ s_return(sc,mk_integer(sc,(unsigned char)c)); ++ } ++ ++ case OP_INT2CHAR: { /* integer->char */ ++ unsigned char c; ++ c=(unsigned char)ivalue(car(sc->args)); ++ s_return(sc,mk_character(sc,(char)c)); ++ } ++ ++ case OP_CHARUPCASE: { ++ unsigned char c; ++ c=(unsigned char)ivalue(car(sc->args)); ++ c=toupper(c); ++ s_return(sc,mk_character(sc,(char)c)); ++ } ++ ++ case OP_CHARDNCASE: { ++ unsigned char c; ++ c=(unsigned char)ivalue(car(sc->args)); ++ c=tolower(c); ++ s_return(sc,mk_character(sc,(char)c)); ++ } ++ ++ case OP_STR2SYM: /* string->symbol */ ++ s_return(sc,mk_symbol(sc,strvalue(car(sc->args)))); ++ ++ case OP_STR2ATOM: /* string->atom */ { ++ char *s=strvalue(car(sc->args)); ++ long pf = 0; ++ if(cdr(sc->args)!=sc->NIL) { ++ /* we know cadr(sc->args) is a natural number */ ++ /* see if it is 2, 8, 10, or 16, or error */ ++ pf = ivalue_unchecked(cadr(sc->args)); ++ if(pf == 16 || pf == 10 || pf == 8 || pf == 2) { ++ /* base is OK */ ++ } ++ else { ++ pf = -1; ++ } ++ } ++ if (pf < 0) { ++ Error_1(sc, "string->atom: bad base:", cadr(sc->args)); ++ } else if(*s=='#') /* no use of base! */ { ++ s_return(sc, mk_sharp_const(sc, s+1)); ++ } else { ++ if (pf == 0 || pf == 10) { ++ s_return(sc, mk_atom(sc, s)); ++ } ++ else { ++ char *ep; ++ long iv = strtol(s,&ep,(int )pf); ++ if (*ep == 0) { ++ s_return(sc, mk_integer(sc, iv)); ++ } ++ else { ++ s_return(sc, sc->F); ++ } ++ } ++ } ++ } ++ ++ case OP_SYM2STR: /* symbol->string */ ++ x=mk_string(sc,symname(car(sc->args))); ++ setimmutable(x); ++ s_return(sc,x); ++ ++ case OP_ATOM2STR: /* atom->string */ { ++ long pf = 0; ++ x=car(sc->args); ++ if(cdr(sc->args)!=sc->NIL) { ++ /* we know cadr(sc->args) is a natural number */ ++ /* see if it is 2, 8, 10, or 16, or error */ ++ pf = ivalue_unchecked(cadr(sc->args)); ++ if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) { ++ /* base is OK */ ++ } ++ else { ++ pf = -1; ++ } ++ } ++ if (pf < 0) { ++ Error_1(sc, "atom->string: bad base:", cadr(sc->args)); ++ } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) { ++ char *p; ++ int len; ++ atom2str(sc,x,(int )pf,&p,&len); ++ s_return(sc,mk_counted_string(sc,p,len)); ++ } else { ++ Error_1(sc, "atom->string: not an atom:", x); ++ } ++ } ++ ++ case OP_MKSTRING: { /* make-string */ ++ int fill=' '; ++ int len; ++ ++ len=ivalue(car(sc->args)); ++ ++ if(cdr(sc->args)!=sc->NIL) { ++ fill=charvalue(cadr(sc->args)); ++ } ++ s_return(sc,mk_empty_string(sc,len,(char)fill)); ++ } ++ ++ case OP_STRLEN: /* string-length */ ++ s_return(sc,mk_integer(sc,strlength(car(sc->args)))); ++ ++ case OP_STRREF: { /* string-ref */ ++ char *str; ++ int index; ++ ++ str=strvalue(car(sc->args)); ++ ++ index=ivalue(cadr(sc->args)); ++ ++ if(index>=strlength(car(sc->args))) { ++ Error_1(sc,"string-ref: out of bounds:",cadr(sc->args)); ++ } ++ ++ s_return(sc,mk_character(sc,((unsigned char*)str)[index])); ++ } ++ ++ case OP_STRSET: { /* string-set! */ ++ char *str; ++ int index; ++ int c; ++ ++ if(is_immutable(car(sc->args))) { ++ Error_1(sc,"string-set!: unable to alter immutable string:",car(sc->args)); ++ } ++ str=strvalue(car(sc->args)); ++ ++ index=ivalue(cadr(sc->args)); ++ if(index>=strlength(car(sc->args))) { ++ Error_1(sc,"string-set!: out of bounds:",cadr(sc->args)); ++ } ++ ++ c=charvalue(caddr(sc->args)); ++ ++ str[index]=(char)c; ++ s_return(sc,car(sc->args)); ++ } ++ ++ case OP_STRAPPEND: { /* string-append */ ++ /* in 1.29 string-append was in Scheme in init.scm but was too slow */ ++ int len = 0; ++ pointer newstr; ++ char *pos; ++ ++ /* compute needed length for new string */ ++ for (x = sc->args; x != sc->NIL; x = cdr(x)) { ++ len += strlength(car(x)); ++ } ++ newstr = mk_empty_string(sc, len, ' '); ++ /* store the contents of the argument strings into the new string */ ++ for (pos = strvalue(newstr), x = sc->args; x != sc->NIL; ++ pos += strlength(car(x)), x = cdr(x)) { ++ memcpy(pos, strvalue(car(x)), strlength(car(x))); ++ } ++ s_return(sc, newstr); ++ } ++ ++ case OP_SUBSTR: { /* substring */ ++ char *str; ++ int index0; ++ int index1; ++ int len; ++ ++ str=strvalue(car(sc->args)); ++ ++ index0=ivalue(cadr(sc->args)); ++ ++ if(index0>strlength(car(sc->args))) { ++ Error_1(sc,"substring: start out of bounds:",cadr(sc->args)); ++ } ++ ++ if(cddr(sc->args)!=sc->NIL) { ++ index1=ivalue(caddr(sc->args)); ++ if(index1>strlength(car(sc->args)) || index1args)); ++ } ++ } else { ++ index1=strlength(car(sc->args)); ++ } ++ ++ len=index1-index0; ++ x=mk_empty_string(sc,len,' '); ++ memcpy(strvalue(x),str+index0,len); ++ strvalue(x)[len]=0; ++ ++ s_return(sc,x); ++ } ++ ++ case OP_VECTOR: { /* vector */ ++ int i; ++ pointer vec; ++ int len=list_length(sc,sc->args); ++ if(len<0) { ++ Error_1(sc,"vector: not a proper list:",sc->args); ++ } ++ vec=mk_vector(sc,len); ++ if(sc->no_memory) { s_return(sc, sc->sink); } ++ for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) { ++ set_vector_elem(vec,i,car(x)); ++ } ++ s_return(sc,vec); ++ } ++ ++ case OP_MKVECTOR: { /* make-vector */ ++ pointer fill=sc->NIL; ++ int len; ++ pointer vec; ++ ++ len=ivalue(car(sc->args)); ++ ++ if(cdr(sc->args)!=sc->NIL) { ++ fill=cadr(sc->args); ++ } ++ vec=mk_vector(sc,len); ++ if(sc->no_memory) { s_return(sc, sc->sink); } ++ if(fill!=sc->NIL) { ++ fill_vector(vec,fill); ++ } ++ s_return(sc,vec); ++ } ++ ++ case OP_VECLEN: /* vector-length */ ++ s_return(sc,mk_integer(sc,ivalue(car(sc->args)))); ++ ++ case OP_VECREF: { /* vector-ref */ ++ int index; ++ ++ index=ivalue(cadr(sc->args)); ++ ++ if(index>=ivalue(car(sc->args))) { ++ Error_1(sc,"vector-ref: out of bounds:",cadr(sc->args)); ++ } ++ ++ s_return(sc,vector_elem(car(sc->args),index)); ++ } ++ ++ case OP_VECSET: { /* vector-set! */ ++ int index; ++ ++ if(is_immutable(car(sc->args))) { ++ Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args)); ++ } ++ ++ index=ivalue(cadr(sc->args)); ++ if(index>=ivalue(car(sc->args))) { ++ Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args)); ++ } ++ ++ set_vector_elem(car(sc->args),index,caddr(sc->args)); ++ s_return(sc,car(sc->args)); ++ } ++ ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ } ++ return sc->T; ++} ++ ++static int is_list(scheme *sc, pointer a) ++{ return list_length(sc,a) >= 0; } ++ ++/* Result is: ++ proper list: length ++ circular list: -1 ++ not even a pair: -2 ++ dotted list: -2 minus length before dot ++*/ ++int list_length(scheme *sc, pointer a) { ++ int i=0; ++ pointer slow, fast; ++ ++ slow = fast = a; ++ while (1) ++ { ++ if (fast == sc->NIL) ++ return i; ++ if (!is_pair(fast)) ++ return -2 - i; ++ fast = cdr(fast); ++ ++i; ++ if (fast == sc->NIL) ++ return i; ++ if (!is_pair(fast)) ++ return -2 - i; ++ ++i; ++ fast = cdr(fast); ++ ++ /* Safe because we would have already returned if `fast' ++ encountered a non-pair. */ ++ slow = cdr(slow); ++ if (fast == slow) ++ { ++ /* the fast pointer has looped back around and caught up ++ with the slow pointer, hence the structure is circular, ++ not of finite length, and therefore not a list */ ++ return -1; ++ } ++ } ++} ++ ++static pointer opexe_3(scheme *sc, enum scheme_opcodes op) { ++ pointer x; ++ num v; ++ int (*comp_func)(num,num)=0; ++ ++ switch (op) { ++ case OP_NOT: /* not */ ++ s_retbool(is_false(car(sc->args))); ++ case OP_BOOLP: /* boolean? */ ++ s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T); ++ case OP_EOFOBJP: /* boolean? */ ++ s_retbool(car(sc->args) == sc->EOF_OBJ); ++ case OP_NULLP: /* null? */ ++ s_retbool(car(sc->args) == sc->NIL); ++ case OP_NUMEQ: /* = */ ++ case OP_LESS: /* < */ ++ case OP_GRE: /* > */ ++ case OP_LEQ: /* <= */ ++ case OP_GEQ: /* >= */ ++ switch(op) { ++ case OP_NUMEQ: comp_func=num_eq; break; ++ case OP_LESS: comp_func=num_lt; break; ++ case OP_GRE: comp_func=num_gt; break; ++ case OP_LEQ: comp_func=num_le; break; ++ case OP_GEQ: comp_func=num_ge; break; ++ } ++ x=sc->args; ++ v=nvalue(car(x)); ++ x=cdr(x); ++ ++ for (; x != sc->NIL; x = cdr(x)) { ++ if(!comp_func(v,nvalue(car(x)))) { ++ s_retbool(0); ++ } ++ v=nvalue(car(x)); ++ } ++ s_retbool(1); ++ case OP_SYMBOLP: /* symbol? */ ++ s_retbool(is_symbol(car(sc->args))); ++ case OP_NUMBERP: /* number? */ ++ s_retbool(is_number(car(sc->args))); ++ case OP_STRINGP: /* string? */ ++ s_retbool(is_string(car(sc->args))); ++ case OP_INTEGERP: /* integer? */ ++ s_retbool(is_integer(car(sc->args))); ++ case OP_REALP: /* real? */ ++ s_retbool(is_number(car(sc->args))); /* All numbers are real */ ++ case OP_CHARP: /* char? */ ++ s_retbool(is_character(car(sc->args))); ++#if USE_CHAR_CLASSIFIERS ++ case OP_CHARAP: /* char-alphabetic? */ ++ s_retbool(Cisalpha(ivalue(car(sc->args)))); ++ case OP_CHARNP: /* char-numeric? */ ++ s_retbool(Cisdigit(ivalue(car(sc->args)))); ++ case OP_CHARWP: /* char-whitespace? */ ++ s_retbool(Cisspace(ivalue(car(sc->args)))); ++ case OP_CHARUP: /* char-upper-case? */ ++ s_retbool(Cisupper(ivalue(car(sc->args)))); ++ case OP_CHARLP: /* char-lower-case? */ ++ s_retbool(Cislower(ivalue(car(sc->args)))); ++#endif ++ case OP_PORTP: /* port? */ ++ s_retbool(is_port(car(sc->args))); ++ case OP_INPORTP: /* input-port? */ ++ s_retbool(is_inport(car(sc->args))); ++ case OP_OUTPORTP: /* output-port? */ ++ s_retbool(is_outport(car(sc->args))); ++ case OP_PROCP: /* procedure? */ ++ /*-- ++ * continuation should be procedure by the example ++ * (call-with-current-continuation procedure?) ==> #t ++ * in R^3 report sec. 6.9 ++ */ ++ s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args)) ++ || is_continuation(car(sc->args)) || is_foreign(car(sc->args))); ++ case OP_PAIRP: /* pair? */ ++ s_retbool(is_pair(car(sc->args))); ++ case OP_LISTP: /* list? */ ++ s_retbool(list_length(sc,car(sc->args)) >= 0); ++ ++ case OP_ENVP: /* environment? */ ++ s_retbool(is_environment(car(sc->args))); ++ case OP_VECTORP: /* vector? */ ++ s_retbool(is_vector(car(sc->args))); ++ case OP_EQ: /* eq? */ ++ s_retbool(car(sc->args) == cadr(sc->args)); ++ case OP_EQV: /* eqv? */ ++ s_retbool(eqv(car(sc->args), cadr(sc->args))); ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ } ++ return sc->T; ++} ++ ++static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { ++ pointer x, y; ++ ++ switch (op) { ++ case OP_FORCE: /* force */ ++ sc->code = car(sc->args); ++ if (is_promise(sc->code)) { ++ /* Should change type to closure here */ ++ s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code); ++ sc->args = sc->NIL; ++ s_goto(sc,OP_APPLY); ++ } else { ++ s_return(sc,sc->code); ++ } ++ ++ case OP_SAVE_FORCED: /* Save forced value replacing promise */ ++ memcpy(sc->code,sc->value,sizeof(struct cell)); ++ s_return(sc,sc->value); ++ ++ case OP_WRITE: /* write */ ++ case OP_DISPLAY: /* display */ ++ case OP_WRITE_CHAR: /* write-char */ ++ if(is_pair(cdr(sc->args))) { ++ if(cadr(sc->args)!=sc->outport) { ++ x=cons(sc,sc->outport,sc->NIL); ++ s_save(sc,OP_SET_OUTPORT, x, sc->NIL); ++ sc->outport=cadr(sc->args); ++ } ++ } ++ sc->args = car(sc->args); ++ if(op==OP_WRITE) { ++ sc->print_flag = 1; ++ } else { ++ sc->print_flag = 0; ++ } ++ s_goto(sc,OP_P0LIST); ++ ++ case OP_NEWLINE: /* newline */ ++ if(is_pair(sc->args)) { ++ if(car(sc->args)!=sc->outport) { ++ x=cons(sc,sc->outport,sc->NIL); ++ s_save(sc,OP_SET_OUTPORT, x, sc->NIL); ++ sc->outport=car(sc->args); ++ } ++ } ++ putstr(sc, "\n"); ++ s_return(sc,sc->T); ++ ++ case OP_ERR0: /* error */ ++ sc->retcode=-1; ++ if (!is_string(car(sc->args))) { ++ sc->args=cons(sc,mk_string(sc," -- "),sc->args); ++ setimmutable(car(sc->args)); ++ } ++ putstr(sc, "Error: "); ++ putstr(sc, strvalue(car(sc->args))); ++ sc->args = cdr(sc->args); ++ s_goto(sc,OP_ERR1); ++ ++ case OP_ERR1: /* error */ ++ putstr(sc, " "); ++ if (sc->args != sc->NIL) { ++ s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL); ++ sc->args = car(sc->args); ++ sc->print_flag = 1; ++ s_goto(sc,OP_P0LIST); ++ } else { ++ putstr(sc, "\n"); ++ if(sc->interactive_repl) { ++ s_goto(sc,OP_T0LVL); ++ } else { ++ return sc->NIL; ++ } ++ } ++ ++ case OP_REVERSE: /* reverse */ ++ s_return(sc,reverse(sc, car(sc->args))); ++ ++ case OP_LIST_STAR: /* list* */ ++ s_return(sc,list_star(sc,sc->args)); ++ ++ case OP_APPEND: /* append */ ++ x = sc->NIL; ++ y = sc->args; ++ if (y == x) { ++ s_return(sc, x); ++ } ++ ++ /* cdr() in the while condition is not a typo. If car() */ ++ /* is used (append '() 'a) will return the wrong result.*/ ++ while (cdr(y) != sc->NIL) { ++ x = revappend(sc, x, car(y)); ++ y = cdr(y); ++ if (x == sc->F) { ++ Error_0(sc, "non-list argument to append"); ++ } ++ } ++ ++ s_return(sc, reverse_in_place(sc, car(y), x)); ++ ++#if USE_PLIST ++ case OP_PUT: /* put */ ++ if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { ++ Error_0(sc,"illegal use of put"); ++ } ++ for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { ++ if (caar(x) == y) { ++ break; ++ } ++ } ++ if (x != sc->NIL) ++ cdar(x) = caddr(sc->args); ++ else ++ symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)), ++ symprop(car(sc->args))); ++ s_return(sc,sc->T); ++ ++ case OP_GET: /* get */ ++ if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) { ++ Error_0(sc,"illegal use of get"); ++ } ++ for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) { ++ if (caar(x) == y) { ++ break; ++ } ++ } ++ if (x != sc->NIL) { ++ s_return(sc,cdar(x)); ++ } else { ++ s_return(sc,sc->NIL); ++ } ++#endif /* USE_PLIST */ ++ case OP_QUIT: /* quit */ ++ if(is_pair(sc->args)) { ++ sc->retcode=ivalue(car(sc->args)); ++ } ++ return (sc->NIL); ++ ++ case OP_GC: /* gc */ ++ gc(sc, sc->NIL, sc->NIL); ++ s_return(sc,sc->T); ++ ++ case OP_GCVERB: /* gc-verbose */ ++ { int was = sc->gc_verbose; ++ ++ sc->gc_verbose = (car(sc->args) != sc->F); ++ s_retbool(was); ++ } ++ ++ case OP_NEWSEGMENT: /* new-segment */ ++ if (!is_pair(sc->args) || !is_number(car(sc->args))) { ++ Error_0(sc,"new-segment: argument must be a number"); ++ } ++ alloc_cellseg(sc, (int) ivalue(car(sc->args))); ++ s_return(sc,sc->T); ++ ++ case OP_OBLIST: /* oblist */ ++ s_return(sc, oblist_all_symbols(sc)); ++ ++ case OP_CURR_INPORT: /* current-input-port */ ++ s_return(sc,sc->inport); ++ ++ case OP_CURR_OUTPORT: /* current-output-port */ ++ s_return(sc,sc->outport); ++ ++ case OP_OPEN_INFILE: /* open-input-file */ ++ case OP_OPEN_OUTFILE: /* open-output-file */ ++ case OP_OPEN_INOUTFILE: /* open-input-output-file */ { ++ int prop=0; ++ pointer p; ++ switch(op) { ++ case OP_OPEN_INFILE: prop=port_input; break; ++ case OP_OPEN_OUTFILE: prop=port_output; break; ++ case OP_OPEN_INOUTFILE: prop=port_input|port_output; break; ++ } ++ p=port_from_filename(sc,strvalue(car(sc->args)),prop); ++ if(p==sc->NIL) { ++ s_return(sc,sc->F); ++ } ++ s_return(sc,p); ++ } ++ ++#if USE_STRING_PORTS ++ case OP_OPEN_INSTRING: /* open-input-string */ ++ case OP_OPEN_INOUTSTRING: /* open-input-output-string */ { ++ int prop=0; ++ pointer p; ++ switch(op) { ++ case OP_OPEN_INSTRING: prop=port_input; break; ++ case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break; ++ } ++ p=port_from_string(sc, strvalue(car(sc->args)), ++ strvalue(car(sc->args))+strlength(car(sc->args)), prop); ++ if(p==sc->NIL) { ++ s_return(sc,sc->F); ++ } ++ s_return(sc,p); ++ } ++ case OP_OPEN_OUTSTRING: /* open-output-string */ { ++ pointer p; ++ if(car(sc->args)==sc->NIL) { ++ p=port_from_scratch(sc); ++ if(p==sc->NIL) { ++ s_return(sc,sc->F); ++ } ++ } else { ++ p=port_from_string(sc, strvalue(car(sc->args)), ++ strvalue(car(sc->args))+strlength(car(sc->args)), ++ port_output); ++ if(p==sc->NIL) { ++ s_return(sc,sc->F); ++ } ++ } ++ s_return(sc,p); ++ } ++ case OP_GET_OUTSTRING: /* get-output-string */ { ++ port *p; ++ ++ if ((p=car(sc->args)->_object._port)->kind&port_string) { ++ off_t size; ++ char *str; ++ ++ size=p->rep.string.curr-p->rep.string.start+1; ++ str=sc->malloc(size); ++ if(str != NULL) { ++ pointer s; ++ ++ memcpy(str,p->rep.string.start,size-1); ++ str[size-1]='\0'; ++ s=mk_string(sc,str); ++ sc->free(str); ++ s_return(sc,s); ++ } ++ } ++ s_return(sc,sc->F); ++ } ++#endif ++ ++ case OP_CLOSE_INPORT: /* close-input-port */ ++ port_close(sc,car(sc->args),port_input); ++ s_return(sc,sc->T); ++ ++ case OP_CLOSE_OUTPORT: /* close-output-port */ ++ port_close(sc,car(sc->args),port_output); ++ s_return(sc,sc->T); ++ ++ case OP_INT_ENV: /* interaction-environment */ ++ s_return(sc,sc->global_env); ++ ++ case OP_CURR_ENV: /* current-environment */ ++ s_return(sc,sc->envir); ++ ++ } ++ return sc->T; ++} ++ ++static pointer opexe_5(scheme *sc, enum scheme_opcodes op) { ++ pointer x; ++ ++ if(sc->nesting!=0) { ++ int n=sc->nesting; ++ sc->nesting=0; ++ sc->retcode=-1; ++ Error_1(sc,"unmatched parentheses:",mk_integer(sc,n)); ++ } ++ ++ switch (op) { ++ /* ========== reading part ========== */ ++ case OP_READ: ++ if(!is_pair(sc->args)) { ++ s_goto(sc,OP_READ_INTERNAL); ++ } ++ if(!is_inport(car(sc->args))) { ++ Error_1(sc,"read: not an input port:",car(sc->args)); ++ } ++ if(car(sc->args)==sc->inport) { ++ s_goto(sc,OP_READ_INTERNAL); ++ } ++ x=sc->inport; ++ sc->inport=car(sc->args); ++ x=cons(sc,x,sc->NIL); ++ s_save(sc,OP_SET_INPORT, x, sc->NIL); ++ s_goto(sc,OP_READ_INTERNAL); ++ ++ case OP_READ_CHAR: /* read-char */ ++ case OP_PEEK_CHAR: /* peek-char */ { ++ int c; ++ if(is_pair(sc->args)) { ++ if(car(sc->args)!=sc->inport) { ++ x=sc->inport; ++ x=cons(sc,x,sc->NIL); ++ s_save(sc,OP_SET_INPORT, x, sc->NIL); ++ sc->inport=car(sc->args); ++ } ++ } ++ c=inchar(sc); ++ if(c==EOF) { ++ s_return(sc,sc->EOF_OBJ); ++ } ++ if(sc->op==OP_PEEK_CHAR) { ++ backchar(sc,c); ++ } ++ s_return(sc,mk_character(sc,c)); ++ } ++ ++ case OP_CHAR_READY: /* char-ready? */ { ++ pointer p=sc->inport; ++ int res; ++ if(is_pair(sc->args)) { ++ p=car(sc->args); ++ } ++ res=p->_object._port->kind&port_string; ++ s_retbool(res); ++ } ++ ++ case OP_SET_INPORT: /* set-input-port */ ++ sc->inport=car(sc->args); ++ s_return(sc,sc->value); ++ ++ case OP_SET_OUTPORT: /* set-output-port */ ++ sc->outport=car(sc->args); ++ s_return(sc,sc->value); ++ ++ case OP_RDSEXPR: ++ switch (sc->tok) { ++ case TOK_EOF: ++ s_return(sc,sc->EOF_OBJ); ++ /* NOTREACHED */ ++/* ++ * Commented out because we now skip comments in the scanner ++ * ++ case TOK_COMMENT: { ++ int c; ++ while ((c=inchar(sc)) != '\n' && c!=EOF) ++ ; ++ sc->tok = token(sc); ++ s_goto(sc,OP_RDSEXPR); ++ } ++*/ ++ case TOK_VEC: ++ s_save(sc,OP_RDVEC,sc->NIL,sc->NIL); ++ /* fall through */ ++ case TOK_LPAREN: ++ sc->tok = token(sc); ++ if (sc->tok == TOK_RPAREN) { ++ s_return(sc,sc->NIL); ++ } else if (sc->tok == TOK_DOT) { ++ Error_0(sc,"syntax error: illegal dot expression"); ++ } else { ++ sc->nesting_stack[sc->file_i]++; ++ s_save(sc,OP_RDLIST, sc->NIL, sc->NIL); ++ s_goto(sc,OP_RDSEXPR); ++ } ++ case TOK_QUOTE: ++ s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL); ++ sc->tok = token(sc); ++ s_goto(sc,OP_RDSEXPR); ++ case TOK_BQUOTE: ++ sc->tok = token(sc); ++ if(sc->tok==TOK_VEC) { ++ s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL); ++ sc->tok=TOK_LPAREN; ++ s_goto(sc,OP_RDSEXPR); ++ } else { ++ s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL); ++ } ++ s_goto(sc,OP_RDSEXPR); ++ case TOK_COMMA: ++ s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL); ++ sc->tok = token(sc); ++ s_goto(sc,OP_RDSEXPR); ++ case TOK_ATMARK: ++ s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL); ++ sc->tok = token(sc); ++ s_goto(sc,OP_RDSEXPR); ++ case TOK_ATOM: ++ s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS))); ++ case TOK_DQUOTE: ++ x=readstrexp(sc); ++ if(x==sc->F) { ++ Error_0(sc,"Error reading string"); ++ } ++ setimmutable(x); ++ s_return(sc,x); ++ case TOK_SHARP: { ++ pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1); ++ if(f==sc->NIL) { ++ Error_0(sc,"undefined sharp expression"); ++ } else { ++ sc->code=cons(sc,slot_value_in_env(f),sc->NIL); ++ s_goto(sc,OP_EVAL); ++ } ++ } ++ case TOK_SHARP_CONST: ++ if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) { ++ Error_0(sc,"undefined sharp expression"); ++ } else { ++ s_return(sc,x); ++ } ++ default: ++ Error_0(sc,"syntax error: illegal token"); ++ } ++ break; ++ ++ case OP_RDLIST: { ++ sc->args = cons(sc, sc->value, sc->args); ++ sc->tok = token(sc); ++/* We now skip comments in the scanner ++ while (sc->tok == TOK_COMMENT) { ++ int c; ++ while ((c=inchar(sc)) != '\n' && c!=EOF) ++ ; ++ sc->tok = token(sc); ++ } ++*/ ++ if (sc->tok == TOK_EOF) ++ { s_return(sc,sc->EOF_OBJ); } ++ else if (sc->tok == TOK_RPAREN) { ++ int c = inchar(sc); ++ if (c != '\n') ++ backchar(sc,c); ++#if SHOW_ERROR_LINE ++ else if (sc->load_stack[sc->file_i].kind & port_file) ++ sc->load_stack[sc->file_i].rep.stdio.curr_line++; ++#endif ++ sc->nesting_stack[sc->file_i]--; ++ s_return(sc,reverse_in_place(sc, sc->NIL, sc->args)); ++ } else if (sc->tok == TOK_DOT) { ++ s_save(sc,OP_RDDOT, sc->args, sc->NIL); ++ sc->tok = token(sc); ++ s_goto(sc,OP_RDSEXPR); ++ } else { ++ s_save(sc,OP_RDLIST, sc->args, sc->NIL);; ++ s_goto(sc,OP_RDSEXPR); ++ } ++ } ++ ++ case OP_RDDOT: ++ if (token(sc) != TOK_RPAREN) { ++ Error_0(sc,"syntax error: illegal dot expression"); ++ } else { ++ sc->nesting_stack[sc->file_i]--; ++ s_return(sc,reverse_in_place(sc, sc->value, sc->args)); ++ } ++ ++ case OP_RDQUOTE: ++ s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL))); ++ ++ case OP_RDQQUOTE: ++ s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL))); ++ ++ case OP_RDQQUOTEVEC: ++ s_return(sc,cons(sc, mk_symbol(sc,"apply"), ++ cons(sc, mk_symbol(sc,"vector"), ++ cons(sc,cons(sc, sc->QQUOTE, ++ cons(sc,sc->value,sc->NIL)), ++ sc->NIL)))); ++ ++ case OP_RDUNQUOTE: ++ s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL))); ++ ++ case OP_RDUQTSP: ++ s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL))); ++ ++ case OP_RDVEC: ++ /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); ++ s_goto(sc,OP_EVAL); Cannot be quoted*/ ++ /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value); ++ s_return(sc,x); Cannot be part of pairs*/ ++ /*sc->code=mk_proc(sc,OP_VECTOR); ++ sc->args=sc->value; ++ s_goto(sc,OP_APPLY);*/ ++ sc->args=sc->value; ++ s_goto(sc,OP_VECTOR); ++ ++ /* ========== printing part ========== */ ++ case OP_P0LIST: ++ if(is_vector(sc->args)) { ++ putstr(sc,"#("); ++ sc->args=cons(sc,sc->args,mk_integer(sc,0)); ++ s_goto(sc,OP_PVECFROM); ++ } else if(is_environment(sc->args)) { ++ putstr(sc,"#"); ++ s_return(sc,sc->T); ++ } else if (!is_pair(sc->args)) { ++ printatom(sc, sc->args, sc->print_flag); ++ s_return(sc,sc->T); ++ } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) { ++ putstr(sc, "'"); ++ sc->args = cadr(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) { ++ putstr(sc, "`"); ++ sc->args = cadr(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) { ++ putstr(sc, ","); ++ sc->args = cadr(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) { ++ putstr(sc, ",@"); ++ sc->args = cadr(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } else { ++ putstr(sc, "("); ++ s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); ++ sc->args = car(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } ++ ++ case OP_P1LIST: ++ if (is_pair(sc->args)) { ++ s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL); ++ putstr(sc, " "); ++ sc->args = car(sc->args); ++ s_goto(sc,OP_P0LIST); ++ } else if(is_vector(sc->args)) { ++ s_save(sc,OP_P1LIST,sc->NIL,sc->NIL); ++ putstr(sc, " . "); ++ s_goto(sc,OP_P0LIST); ++ } else { ++ if (sc->args != sc->NIL) { ++ putstr(sc, " . "); ++ printatom(sc, sc->args, sc->print_flag); ++ } ++ putstr(sc, ")"); ++ s_return(sc,sc->T); ++ } ++ case OP_PVECFROM: { ++ int i=ivalue_unchecked(cdr(sc->args)); ++ pointer vec=car(sc->args); ++ int len=ivalue_unchecked(vec); ++ if(i==len) { ++ putstr(sc,")"); ++ s_return(sc,sc->T); ++ } else { ++ pointer elem=vector_elem(vec,i); ++ ivalue_unchecked(cdr(sc->args))=i+1; ++ s_save(sc,OP_PVECFROM, sc->args, sc->NIL); ++ sc->args=elem; ++ if (i > 0) ++ putstr(sc," "); ++ s_goto(sc,OP_P0LIST); ++ } ++ } ++ ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ ++ } ++ return sc->T; ++} ++ ++static pointer opexe_6(scheme *sc, enum scheme_opcodes op) { ++ pointer x, y; ++ long v; ++ ++ switch (op) { ++ case OP_LIST_LENGTH: /* length */ /* a.k */ ++ v=list_length(sc,car(sc->args)); ++ if(v<0) { ++ Error_1(sc,"length: not a list:",car(sc->args)); ++ } ++ s_return(sc,mk_integer(sc, v)); ++ ++ case OP_ASSQ: /* assq */ /* a.k */ ++ x = car(sc->args); ++ for (y = cadr(sc->args); is_pair(y); y = cdr(y)) { ++ if (!is_pair(car(y))) { ++ Error_0(sc,"unable to handle non pair element"); ++ } ++ if (x == caar(y)) ++ break; ++ } ++ if (is_pair(y)) { ++ s_return(sc,car(y)); ++ } else { ++ s_return(sc,sc->F); ++ } ++ ++ ++ case OP_GET_CLOSURE: /* get-closure-code */ /* a.k */ ++ sc->args = car(sc->args); ++ if (sc->args == sc->NIL) { ++ s_return(sc,sc->F); ++ } else if (is_closure(sc->args)) { ++ s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); ++ } else if (is_macro(sc->args)) { ++ s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value))); ++ } else { ++ s_return(sc,sc->F); ++ } ++ case OP_CLOSUREP: /* closure? */ ++ /* ++ * Note, macro object is also a closure. ++ * Therefore, (closure? <#MACRO>) ==> #t ++ */ ++ s_retbool(is_closure(car(sc->args))); ++ case OP_MACROP: /* macro? */ ++ s_retbool(is_macro(car(sc->args))); ++ default: ++ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op); ++ Error_0(sc,sc->strbuff); ++ } ++ return sc->T; /* NOTREACHED */ ++} ++ ++typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes); ++ ++typedef int (*test_predicate)(pointer); ++static int is_any(pointer p) { return 1;} ++ ++static int is_nonneg(pointer p) { ++ return ivalue(p)>=0 && is_integer(p); ++} ++ ++/* Correspond carefully with following defines! */ ++static struct { ++ test_predicate fct; ++ const char *kind; ++} tests[]={ ++ {0,0}, /* unused */ ++ {is_any, 0}, ++ {is_string, "string"}, ++ {is_symbol, "symbol"}, ++ {is_port, "port"}, ++ {is_inport,"input port"}, ++ {is_outport,"output port"}, ++ {is_environment, "environment"}, ++ {is_pair, "pair"}, ++ {0, "pair or '()"}, ++ {is_character, "character"}, ++ {is_vector, "vector"}, ++ {is_number, "number"}, ++ {is_integer, "integer"}, ++ {is_nonneg, "non-negative integer"} ++}; ++ ++#define TST_NONE 0 ++#define TST_ANY "\001" ++#define TST_STRING "\002" ++#define TST_SYMBOL "\003" ++#define TST_PORT "\004" ++#define TST_INPORT "\005" ++#define TST_OUTPORT "\006" ++#define TST_ENVIRONMENT "\007" ++#define TST_PAIR "\010" ++#define TST_LIST "\011" ++#define TST_CHAR "\012" ++#define TST_VECTOR "\013" ++#define TST_NUMBER "\014" ++#define TST_INTEGER "\015" ++#define TST_NATURAL "\016" ++ ++typedef struct { ++ dispatch_func func; ++ char *name; ++ int min_arity; ++ int max_arity; ++ char *arg_tests_encoding; ++} op_code_info; ++ ++#define INF_ARG 0xffff ++ ++static op_code_info dispatch_table[]= { ++#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, ++#include "opdefines.h" ++ { 0 } ++}; ++ ++static const char *procname(pointer x) { ++ int n=procnum(x); ++ const char *name=dispatch_table[n].name; ++ if(name==0) { ++ name="ILLEGAL!"; ++ } ++ return name; ++} ++ ++/* kernel of this interpreter */ ++static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) { ++ sc->op = op; ++ for (;;) { ++ op_code_info *pcd=dispatch_table+sc->op; ++ if (pcd->name!=0) { /* if built-in function, check arguments */ ++ char msg[STRBUFFSIZE]; ++ int ok=1; ++ int n=list_length(sc,sc->args); ++ ++ /* Check number of arguments */ ++ if(nmin_arity) { ++ ok=0; ++ snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", ++ pcd->name, ++ pcd->min_arity==pcd->max_arity?"":" at least", ++ pcd->min_arity); ++ } ++ if(ok && n>pcd->max_arity) { ++ ok=0; ++ snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)", ++ pcd->name, ++ pcd->min_arity==pcd->max_arity?"":" at most", ++ pcd->max_arity); ++ } ++ if(ok) { ++ if(pcd->arg_tests_encoding!=0) { ++ int i=0; ++ int j; ++ const char *t=pcd->arg_tests_encoding; ++ pointer arglist=sc->args; ++ do { ++ pointer arg=car(arglist); ++ j=(int)t[0]; ++ if(j==TST_LIST[0]) { ++ if(arg!=sc->NIL && !is_pair(arg)) break; ++ } else { ++ if(!tests[j].fct(arg)) break; ++ } ++ ++ if(t[1]!=0) {/* last test is replicated as necessary */ ++ t++; ++ } ++ arglist=cdr(arglist); ++ i++; ++ } while(iname, ++ i+1, ++ tests[j].kind); ++ } ++ } ++ } ++ if(!ok) { ++ if(_Error_1(sc,msg,0)==sc->NIL) { ++ return; ++ } ++ pcd=dispatch_table+sc->op; ++ } ++ } ++ ok_to_freely_gc(sc); ++ if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) { ++ return; ++ } ++ if(sc->no_memory) { ++ fprintf(stderr,"No memory!\n"); ++ return; ++ } ++ } ++} ++ ++/* ========== Initialization of internal keywords ========== */ ++ ++static void assign_syntax(scheme *sc, char *name) { ++ pointer x; ++ ++ x = oblist_add_by_name(sc, name); ++ typeflag(x) |= T_SYNTAX; ++} ++ ++static void assign_proc(scheme *sc, enum scheme_opcodes op, char *name) { ++ pointer x, y; ++ ++ x = mk_symbol(sc, name); ++ y = mk_proc(sc,op); ++ new_slot_in_env(sc, x, y); ++} ++ ++static pointer mk_proc(scheme *sc, enum scheme_opcodes op) { ++ pointer y; ++ ++ y = get_cell(sc, sc->NIL, sc->NIL); ++ typeflag(y) = (T_PROC | T_ATOM); ++ ivalue_unchecked(y) = (long) op; ++ set_num_integer(y); ++ return y; ++} ++ ++/* Hard-coded for the given keywords. Remember to rewrite if more are added! */ ++static int syntaxnum(pointer p) { ++ const char *s=strvalue(car(p)); ++ switch(strlength(car(p))) { ++ case 2: ++ if(s[0]=='i') return OP_IF0; /* if */ ++ else return OP_OR0; /* or */ ++ case 3: ++ if(s[0]=='a') return OP_AND0; /* and */ ++ else return OP_LET0; /* let */ ++ case 4: ++ switch(s[3]) { ++ case 'e': return OP_CASE0; /* case */ ++ case 'd': return OP_COND0; /* cond */ ++ case '*': return OP_LET0AST; /* let* */ ++ default: return OP_SET0; /* set! */ ++ } ++ case 5: ++ switch(s[2]) { ++ case 'g': return OP_BEGIN; /* begin */ ++ case 'l': return OP_DELAY; /* delay */ ++ case 'c': return OP_MACRO0; /* macro */ ++ default: return OP_QUOTE; /* quote */ ++ } ++ case 6: ++ switch(s[2]) { ++ case 'm': return OP_LAMBDA; /* lambda */ ++ case 'f': return OP_DEF0; /* define */ ++ default: return OP_LET0REC; /* letrec */ ++ } ++ default: ++ return OP_C0STREAM; /* cons-stream */ ++ } ++} ++ ++/* initialization of TinyScheme */ ++#if USE_INTERFACE ++INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) { ++ return cons(sc,a,b); ++} ++INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) { ++ return immutable_cons(sc,a,b); ++} ++ ++static struct scheme_interface vtbl ={ ++ scheme_define, ++ s_cons, ++ s_immutable_cons, ++ reserve_cells, ++ mk_integer, ++ mk_real, ++ mk_symbol, ++ gensym, ++ mk_string, ++ mk_counted_string, ++ mk_character, ++ mk_vector, ++ mk_foreign_func, ++ putstr, ++ putcharacter, ++ ++ is_string, ++ string_value, ++ is_number, ++ nvalue, ++ ivalue, ++ rvalue, ++ is_integer, ++ is_real, ++ is_character, ++ charvalue, ++ is_list, ++ is_vector, ++ list_length, ++ ivalue, ++ fill_vector, ++ vector_elem, ++ set_vector_elem, ++ is_port, ++ is_pair, ++ pair_car, ++ pair_cdr, ++ set_car, ++ set_cdr, ++ ++ is_symbol, ++ symname, ++ ++ is_syntax, ++ is_proc, ++ is_foreign, ++ syntaxname, ++ is_closure, ++ is_macro, ++ closure_code, ++ closure_env, ++ ++ is_continuation, ++ is_promise, ++ is_environment, ++ is_immutable, ++ setimmutable, ++ ++ scheme_load_file, ++ scheme_load_string ++}; ++#endif ++ ++scheme *scheme_init_new() { ++ scheme *sc=(scheme*)malloc(sizeof(scheme)); ++ if(!scheme_init(sc)) { ++ free(sc); ++ return 0; ++ } else { ++ return sc; ++ } ++} ++ ++scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) { ++ scheme *sc=(scheme*)malloc(sizeof(scheme)); ++ if(!scheme_init_custom_alloc(sc,malloc,free)) { ++ free(sc); ++ return 0; ++ } else { ++ return sc; ++ } ++} ++ ++ ++int scheme_init(scheme *sc) { ++ return scheme_init_custom_alloc(sc,malloc,free); ++} ++ ++int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) { ++ int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]); ++ pointer x; ++ ++ num_zero.is_fixnum=1; ++ num_zero.value.ivalue=0; ++ num_one.is_fixnum=1; ++ num_one.value.ivalue=1; ++ ++#if USE_INTERFACE ++ sc->vptr=&vtbl; ++#endif ++ sc->gensym_cnt=0; ++ sc->malloc=malloc; ++ sc->free=free; ++ sc->last_cell_seg = -1; ++ sc->sink = &sc->_sink; ++ sc->NIL = &sc->_NIL; ++ sc->T = &sc->_HASHT; ++ sc->F = &sc->_HASHF; ++ sc->EOF_OBJ=&sc->_EOF_OBJ; ++ sc->free_cell = &sc->_NIL; ++ sc->fcells = 0; ++ sc->no_memory=0; ++ sc->inport=sc->NIL; ++ sc->outport=sc->NIL; ++ sc->save_inport=sc->NIL; ++ sc->loadport=sc->NIL; ++ sc->nesting=0; ++ sc->interactive_repl=0; ++ ++ if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) { ++ sc->no_memory=1; ++ return 0; ++ } ++ sc->gc_verbose = 0; ++ dump_stack_initialize(sc); ++ sc->code = sc->NIL; ++ sc->tracing=0; ++ ++ /* init sc->NIL */ ++ typeflag(sc->NIL) = (T_ATOM | MARK); ++ car(sc->NIL) = cdr(sc->NIL) = sc->NIL; ++ /* init T */ ++ typeflag(sc->T) = (T_ATOM | MARK); ++ car(sc->T) = cdr(sc->T) = sc->T; ++ /* init F */ ++ typeflag(sc->F) = (T_ATOM | MARK); ++ car(sc->F) = cdr(sc->F) = sc->F; ++ /* init sink */ ++ typeflag(sc->sink) = (T_PAIR | MARK); ++ car(sc->sink) = sc->NIL; ++ /* init c_nest */ ++ sc->c_nest = sc->NIL; ++ ++ sc->oblist = oblist_initial_value(sc); ++ /* init global_env */ ++ new_frame_in_env(sc, sc->NIL); ++ sc->global_env = sc->envir; ++ /* init else */ ++ x = mk_symbol(sc,"else"); ++ new_slot_in_env(sc, x, sc->T); ++ ++ assign_syntax(sc, "lambda"); ++ assign_syntax(sc, "quote"); ++ assign_syntax(sc, "define"); ++ assign_syntax(sc, "if"); ++ assign_syntax(sc, "begin"); ++ assign_syntax(sc, "set!"); ++ assign_syntax(sc, "let"); ++ assign_syntax(sc, "let*"); ++ assign_syntax(sc, "letrec"); ++ assign_syntax(sc, "cond"); ++ assign_syntax(sc, "delay"); ++ assign_syntax(sc, "and"); ++ assign_syntax(sc, "or"); ++ assign_syntax(sc, "cons-stream"); ++ assign_syntax(sc, "macro"); ++ assign_syntax(sc, "case"); ++ ++ for(i=0; iLAMBDA = mk_symbol(sc, "lambda"); ++ sc->QUOTE = mk_symbol(sc, "quote"); ++ sc->QQUOTE = mk_symbol(sc, "quasiquote"); ++ sc->UNQUOTE = mk_symbol(sc, "unquote"); ++ sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing"); ++ sc->FEED_TO = mk_symbol(sc, "=>"); ++ sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*"); ++ sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*"); ++ sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*"); ++ sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*"); ++ ++ return !sc->no_memory; ++} ++ ++void scheme_set_input_port_file(scheme *sc, FILE *fin) { ++ sc->inport=port_from_file(sc,fin,port_input); ++} ++ ++void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) { ++ sc->inport=port_from_string(sc,start,past_the_end,port_input); ++} ++ ++void scheme_set_output_port_file(scheme *sc, FILE *fout) { ++ sc->outport=port_from_file(sc,fout,port_output); ++} ++ ++void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) { ++ sc->outport=port_from_string(sc,start,past_the_end,port_output); ++} ++ ++void scheme_set_external_data(scheme *sc, void *p) { ++ sc->ext_data=p; ++} ++ ++void scheme_deinit(scheme *sc) { ++ int i; ++ ++#if SHOW_ERROR_LINE ++ char *fname; ++#endif ++ ++ sc->oblist=sc->NIL; ++ sc->global_env=sc->NIL; ++ dump_stack_free(sc); ++ sc->envir=sc->NIL; ++ sc->code=sc->NIL; ++ sc->args=sc->NIL; ++ sc->value=sc->NIL; ++ if(is_port(sc->inport)) { ++ typeflag(sc->inport) = T_ATOM; ++ } ++ sc->inport=sc->NIL; ++ sc->outport=sc->NIL; ++ if(is_port(sc->save_inport)) { ++ typeflag(sc->save_inport) = T_ATOM; ++ } ++ sc->save_inport=sc->NIL; ++ if(is_port(sc->loadport)) { ++ typeflag(sc->loadport) = T_ATOM; ++ } ++ sc->loadport=sc->NIL; ++ sc->gc_verbose=0; ++ gc(sc,sc->NIL,sc->NIL); ++ ++ for(i=0; i<=sc->last_cell_seg; i++) { ++ sc->free(sc->alloc_seg[i]); ++ } ++ ++#if SHOW_ERROR_LINE ++ for(i=0; i<=sc->file_i; i++) { ++ if (sc->load_stack[i].kind & port_file) { ++ fname = sc->load_stack[i].rep.stdio.filename; ++ if(fname) ++ sc->free(fname); ++ } ++ } ++#endif ++} ++ ++void scheme_load_file(scheme *sc, FILE *fin) ++{ scheme_load_named_file(sc,fin,0); } ++ ++void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) { ++ dump_stack_reset(sc); ++ sc->envir = sc->global_env; ++ sc->file_i=0; ++ sc->load_stack[0].kind=port_input|port_file; ++ sc->load_stack[0].rep.stdio.file=fin; ++ sc->loadport=mk_port(sc,sc->load_stack); ++ sc->retcode=0; ++ if(fin==stdin) { ++ sc->interactive_repl=1; ++ } ++ ++#if SHOW_ERROR_LINE ++ sc->load_stack[0].rep.stdio.curr_line = 0; ++ if(fin!=stdin && filename) ++ sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0); ++#endif ++ ++ sc->inport=sc->loadport; ++ sc->args = mk_integer(sc,sc->file_i); ++ Eval_Cycle(sc, OP_T0LVL); ++ typeflag(sc->loadport)=T_ATOM; ++ if(sc->retcode==0) { ++ sc->retcode=sc->nesting!=0; ++ } ++} ++ ++void scheme_load_string(scheme *sc, const char *cmd) { ++ dump_stack_reset(sc); ++ sc->envir = sc->global_env; ++ sc->file_i=0; ++ sc->load_stack[0].kind=port_input|port_string; ++ sc->load_stack[0].rep.string.start=(char*)cmd; /* This func respects const */ ++ sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd); ++ sc->load_stack[0].rep.string.curr=(char*)cmd; ++ sc->loadport=mk_port(sc,sc->load_stack); ++ sc->retcode=0; ++ sc->interactive_repl=0; ++ sc->inport=sc->loadport; ++ sc->args = mk_integer(sc,sc->file_i); ++ Eval_Cycle(sc, OP_T0LVL); ++ typeflag(sc->loadport)=T_ATOM; ++ if(sc->retcode==0) { ++ sc->retcode=sc->nesting!=0; ++ } ++} ++ ++void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { ++ pointer x; ++ ++ x=find_slot_in_env(sc,envir,symbol,0); ++ if (x != sc->NIL) { ++ set_slot_in_env(sc, x, value); ++ } else { ++ new_slot_spec_in_env(sc, envir, symbol, value); ++ } ++} ++ ++#if !STANDALONE ++void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr) ++{ ++ scheme_define(sc, ++ sc->global_env, ++ mk_symbol(sc,sr->name), ++ mk_foreign_func(sc, sr->f)); ++} ++ ++void scheme_register_foreign_func_list(scheme * sc, ++ scheme_registerable * list, ++ int count) ++{ ++ int i; ++ for(i = 0; i < count; i++) ++ { ++ scheme_register_foreign_func(sc, list + i); ++ } ++} ++ ++pointer scheme_apply0(scheme *sc, const char *procname) ++{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); } ++ ++void save_from_C_call(scheme *sc) ++{ ++ pointer saved_data = ++ cons(sc, ++ car(sc->sink), ++ cons(sc, ++ sc->envir, ++ sc->dump)); ++ /* Push */ ++ sc->c_nest = cons(sc, saved_data, sc->c_nest); ++ /* Truncate the dump stack so TS will return here when done, not ++ directly resume pre-C-call operations. */ ++ dump_stack_reset(sc); ++} ++void restore_from_C_call(scheme *sc) ++{ ++ car(sc->sink) = caar(sc->c_nest); ++ sc->envir = cadar(sc->c_nest); ++ sc->dump = cdr(cdar(sc->c_nest)); ++ /* Pop */ ++ sc->c_nest = cdr(sc->c_nest); ++} ++ ++/* "func" and "args" are assumed to be already eval'ed. */ ++pointer scheme_call(scheme *sc, pointer func, pointer args) ++{ ++ int old_repl = sc->interactive_repl; ++ sc->interactive_repl = 0; ++ save_from_C_call(sc); ++ sc->envir = sc->global_env; ++ sc->args = args; ++ sc->code = func; ++ sc->retcode = 0; ++ Eval_Cycle(sc, OP_APPLY); ++ sc->interactive_repl = old_repl; ++ restore_from_C_call(sc); ++ return sc->value; ++} ++ ++pointer scheme_eval(scheme *sc, pointer obj) ++{ ++ int old_repl = sc->interactive_repl; ++ sc->interactive_repl = 0; ++ save_from_C_call(sc); ++ sc->args = sc->NIL; ++ sc->code = obj; ++ sc->retcode = 0; ++ Eval_Cycle(sc, OP_EVAL); ++ sc->interactive_repl = old_repl; ++ restore_from_C_call(sc); ++ return sc->value; ++} ++ ++ ++#endif ++ ++/* ========== Main ========== */ ++ ++#if STANDALONE ++ ++#if defined(__APPLE__) && !defined (OSX) ++int main() ++{ ++ extern MacTS_main(int argc, char **argv); ++ char** argv; ++ int argc = ccommand(&argv); ++ MacTS_main(argc,argv); ++ return 0; ++} ++int MacTS_main(int argc, char **argv) { ++#else ++int main(int argc, char **argv) { ++#endif ++ scheme sc; ++ FILE *fin; ++ char *file_name=InitFile; ++ int retcode; ++ int isfile=1; ++ ++ if(argc==1) { ++ printf(banner); ++ } ++ if(argc==2 && strcmp(argv[1],"-?")==0) { ++ printf("Usage: tinyscheme -?\n"); ++ printf("or: tinyscheme [ ...]\n"); ++ printf("followed by\n"); ++ printf(" -1 [ ...]\n"); ++ printf(" -c [ ...]\n"); ++ printf("assuming that the executable is named tinyscheme.\n"); ++ printf("Use - as filename for stdin.\n"); ++ return 1; ++ } ++ if(!scheme_init(&sc)) { ++ fprintf(stderr,"Could not initialize!\n"); ++ return 2; ++ } ++ scheme_set_input_port_file(&sc, stdin); ++ scheme_set_output_port_file(&sc, stdout); ++#if USE_DL ++ scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext)); ++#endif ++ argv++; ++ if(access(file_name,0)!=0) { ++ char *p=getenv("TINYSCHEMEINIT"); ++ if(p!=0) { ++ file_name=p; ++ } ++ } ++ do { ++ if(strcmp(file_name,"-")==0) { ++ fin=stdin; ++ } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) { ++ pointer args=sc.NIL; ++ isfile=file_name[1]=='1'; ++ file_name=*argv++; ++ if(strcmp(file_name,"-")==0) { ++ fin=stdin; ++ } else if(isfile) { ++ fin=fopen(file_name,"r"); ++ } ++ for(;*argv;argv++) { ++ pointer value=mk_string(&sc,*argv); ++ args=cons(&sc,value,args); ++ } ++ args=reverse_in_place(&sc,sc.NIL,args); ++ scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args); ++ ++ } else { ++ fin=fopen(file_name,"r"); ++ } ++ if(isfile && fin==0) { ++ fprintf(stderr,"Could not open file %s\n",file_name); ++ } else { ++ if(isfile) { ++ scheme_load_named_file(&sc,fin,file_name); ++ } else { ++ scheme_load_string(&sc,file_name); ++ } ++ if(!isfile || fin!=stdin) { ++ if(sc.retcode!=0) { ++ fprintf(stderr,"Errors encountered reading %s\n",file_name); ++ } ++ if(isfile) { ++ fclose(fin); ++ } ++ } ++ } ++ file_name=*argv++; ++ } while(file_name!=0); ++ if(argc==1) { ++ scheme_load_named_file(&sc,stdin,0); ++ } ++ retcode=sc.retcode; ++ scheme_deinit(&sc); ++ ++ return retcode; ++} ++ ++#endif ++ ++/* ++Local variables: ++c-file-style: "k&r" ++End: ++*/ ++ ++/* XXX: Hurd addition. */ ++void ++scheme_load_mem (scheme *sc, const char *cmd_start, const char *cmd_end) ++{ ++ dump_stack_reset(sc); ++ sc->envir = sc->global_env; ++ sc->file_i=0; ++ sc->load_stack[0].kind=port_input|port_string; ++ /* This func respects const */ ++ sc->load_stack[0].rep.string.start=(char*) cmd_start; ++ sc->load_stack[0].rep.string.past_the_end=(char*) cmd_end; ++ sc->load_stack[0].rep.string.curr=(char*) cmd_start; ++ sc->loadport=mk_port(sc,sc->load_stack); ++ sc->retcode=0; ++ sc->interactive_repl=0; ++ sc->inport=sc->loadport; ++ sc->args = mk_integer(sc,sc->file_i); ++ Eval_Cycle(sc, OP_T0LVL); ++ typeflag(sc->loadport)=T_ATOM; ++ if(sc->retcode==0) { ++ sc->retcode=sc->nesting!=0; ++ } ++} +diff --git a/bootshell/scheme.h b/bootshell/scheme.h +new file mode 100644 +index 0000000..fbc542b +--- /dev/null ++++ b/bootshell/scheme.h +@@ -0,0 +1,255 @@ ++/* SCHEME.H */ ++ ++#ifndef _SCHEME_H ++#define _SCHEME_H ++ ++#include ++ ++#ifdef __cplusplus ++extern "C" { ++#endif ++ ++/* ++ * Default values for #define'd symbols ++ */ ++#ifndef STANDALONE /* If used as standalone interpreter */ ++# define STANDALONE 1 ++#endif ++ ++#ifndef _MSC_VER ++# define USE_STRCASECMP 1 ++# ifndef USE_STRLWR ++# define USE_STRLWR 1 ++# endif ++# define SCHEME_EXPORT ++#else ++# define USE_STRCASECMP 0 ++# define USE_STRLWR 0 ++# ifdef _SCHEME_SOURCE ++# define SCHEME_EXPORT __declspec(dllexport) ++# else ++# define SCHEME_EXPORT __declspec(dllimport) ++# endif ++#endif ++ ++#if USE_NO_FEATURES ++# define USE_MATH 0 ++# define USE_CHAR_CLASSIFIERS 0 ++# define USE_ASCII_NAMES 0 ++# define USE_STRING_PORTS 0 ++# define USE_ERROR_HOOK 0 ++# define USE_TRACING 0 ++# define USE_COLON_HOOK 0 ++# define USE_DL 0 ++# define USE_PLIST 0 ++#endif ++ ++/* ++ * Leave it defined if you want continuations, and also for the Sharp Zaurus. ++ * Undefine it if you only care about faster speed and not strict Scheme compatibility. ++ */ ++#define USE_SCHEME_STACK ++ ++#if USE_DL ++# define USE_INTERFACE 1 ++#endif ++ ++ ++#ifndef USE_MATH /* If math support is needed */ ++# define USE_MATH 1 ++#endif ++ ++#ifndef USE_CHAR_CLASSIFIERS /* If char classifiers are needed */ ++# define USE_CHAR_CLASSIFIERS 1 ++#endif ++ ++#ifndef USE_ASCII_NAMES /* If extended escaped characters are needed */ ++# define USE_ASCII_NAMES 1 ++#endif ++ ++#ifndef USE_STRING_PORTS /* Enable string ports */ ++# define USE_STRING_PORTS 1 ++#endif ++ ++#ifndef USE_TRACING ++# define USE_TRACING 1 ++#endif ++ ++#ifndef USE_PLIST ++# define USE_PLIST 0 ++#endif ++ ++/* To force system errors through user-defined error handling (see *error-hook*) */ ++#ifndef USE_ERROR_HOOK ++# define USE_ERROR_HOOK 1 ++#endif ++ ++#ifndef USE_COLON_HOOK /* Enable qualified qualifier */ ++# define USE_COLON_HOOK 1 ++#endif ++ ++#ifndef USE_STRCASECMP /* stricmp for Unix */ ++# define USE_STRCASECMP 0 ++#endif ++ ++#ifndef USE_STRLWR ++# define USE_STRLWR 1 ++#endif ++ ++#ifndef STDIO_ADDS_CR /* Define if DOS/Windows */ ++# define STDIO_ADDS_CR 0 ++#endif ++ ++#ifndef INLINE ++# define INLINE ++#endif ++ ++#ifndef USE_INTERFACE ++# define USE_INTERFACE 0 ++#endif ++ ++#ifndef SHOW_ERROR_LINE /* Show error line in file */ ++# define SHOW_ERROR_LINE 1 ++#endif ++ ++typedef struct scheme scheme; ++typedef struct cell *pointer; ++ ++typedef void * (*func_alloc)(size_t); ++typedef void (*func_dealloc)(void *); ++ ++/* num, for generic arithmetic */ ++typedef struct num { ++ char is_fixnum; ++ union { ++ long ivalue; ++ double rvalue; ++ } value; ++} num; ++ ++SCHEME_EXPORT scheme *scheme_init_new(); ++SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free); ++SCHEME_EXPORT int scheme_init(scheme *sc); ++SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc); ++SCHEME_EXPORT void scheme_deinit(scheme *sc); ++void scheme_set_input_port_file(scheme *sc, FILE *fin); ++void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end); ++SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin); ++void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end); ++SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin); ++SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename); ++SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd); ++SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname); ++SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args); ++SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj); ++void scheme_set_external_data(scheme *sc, void *p); ++SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value); ++ ++typedef pointer (*foreign_func)(scheme *, pointer); ++ ++pointer _cons(scheme *sc, pointer a, pointer b, int immutable); ++pointer mk_integer(scheme *sc, long num); ++pointer mk_real(scheme *sc, double num); ++pointer mk_symbol(scheme *sc, const char *name); ++pointer gensym(scheme *sc); ++pointer mk_string(scheme *sc, const char *str); ++pointer mk_counted_string(scheme *sc, const char *str, int len); ++pointer mk_empty_string(scheme *sc, int len, char fill); ++pointer mk_character(scheme *sc, int c); ++pointer mk_foreign_func(scheme *sc, foreign_func f); ++void putstr(scheme *sc, const char *s); ++int list_length(scheme *sc, pointer a); ++int eqv(pointer a, pointer b); ++ ++ ++#if USE_INTERFACE ++struct scheme_interface { ++ void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value); ++ pointer (*cons)(scheme *sc, pointer a, pointer b); ++ pointer (*immutable_cons)(scheme *sc, pointer a, pointer b); ++ pointer (*reserve_cells)(scheme *sc, int n); ++ pointer (*mk_integer)(scheme *sc, long num); ++ pointer (*mk_real)(scheme *sc, double num); ++ pointer (*mk_symbol)(scheme *sc, const char *name); ++ pointer (*gensym)(scheme *sc); ++ pointer (*mk_string)(scheme *sc, const char *str); ++ pointer (*mk_counted_string)(scheme *sc, const char *str, int len); ++ pointer (*mk_character)(scheme *sc, int c); ++ pointer (*mk_vector)(scheme *sc, int len); ++ pointer (*mk_foreign_func)(scheme *sc, foreign_func f); ++ void (*putstr)(scheme *sc, const char *s); ++ void (*putcharacter)(scheme *sc, int c); ++ ++ int (*is_string)(pointer p); ++ char *(*string_value)(pointer p); ++ int (*is_number)(pointer p); ++ num (*nvalue)(pointer p); ++ long (*ivalue)(pointer p); ++ double (*rvalue)(pointer p); ++ int (*is_integer)(pointer p); ++ int (*is_real)(pointer p); ++ int (*is_character)(pointer p); ++ long (*charvalue)(pointer p); ++ int (*is_list)(scheme *sc, pointer p); ++ int (*is_vector)(pointer p); ++ int (*list_length)(scheme *sc, pointer vec); ++ long (*vector_length)(pointer vec); ++ void (*fill_vector)(pointer vec, pointer elem); ++ pointer (*vector_elem)(pointer vec, int ielem); ++ pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel); ++ int (*is_port)(pointer p); ++ ++ int (*is_pair)(pointer p); ++ pointer (*pair_car)(pointer p); ++ pointer (*pair_cdr)(pointer p); ++ pointer (*set_car)(pointer p, pointer q); ++ pointer (*set_cdr)(pointer p, pointer q); ++ ++ int (*is_symbol)(pointer p); ++ char *(*symname)(pointer p); ++ ++ int (*is_syntax)(pointer p); ++ int (*is_proc)(pointer p); ++ int (*is_foreign)(pointer p); ++ char *(*syntaxname)(pointer p); ++ int (*is_closure)(pointer p); ++ int (*is_macro)(pointer p); ++ pointer (*closure_code)(pointer p); ++ pointer (*closure_env)(pointer p); ++ ++ int (*is_continuation)(pointer p); ++ int (*is_promise)(pointer p); ++ int (*is_environment)(pointer p); ++ int (*is_immutable)(pointer p); ++ void (*setimmutable)(pointer p); ++ void (*load_file)(scheme *sc, FILE *fin); ++ void (*load_string)(scheme *sc, const char *input); ++}; ++#endif ++ ++#if !STANDALONE ++typedef struct scheme_registerable ++{ ++ foreign_func f; ++ const char * name; ++} ++scheme_registerable; ++ ++void scheme_register_foreign_func_list(scheme * sc, ++ scheme_registerable * list, ++ int n); ++ ++#endif /* !STANDALONE */ ++ ++#ifdef __cplusplus ++} ++#endif ++ ++#endif ++ ++ ++/* ++Local variables: ++c-file-style: "k&r" ++End: ++*/ +diff --git a/bootshell/startup.c b/bootshell/startup.c +new file mode 100644 +index 0000000..abb600c +--- /dev/null ++++ b/bootshell/startup.c +@@ -0,0 +1,487 @@ ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++#include ++ ++#include "startup_reply_U.h" ++// eek #include "startup_S.h" ++// eek #include "fsys_S.h" ++extern boolean_t startup_server (mach_msg_header_t *, mach_msg_header_t *); ++extern boolean_t fsys_server (mach_msg_header_t *, mach_msg_header_t *); ++ ++#include "bootshell.h" ++#include "ffi.h" ++ ++/* Handling of `startup_essential_task'. */ ++ ++static mach_port_t early_startup_port; ++ ++/* This structure keeps track of each registered essential task. */ ++struct port_string_tuple ++ { ++ struct port_string_tuple *next; ++ task_t port; ++ char *name; ++ }; ++ ++static struct port_string_tuple *essential_tasks; ++static struct port_string_tuple *registered_tasks; ++ ++/* Record an essential task in the list. */ ++static error_t ++add_tuple (struct port_string_tuple **list, mach_port_t port, const char *name) ++{ ++ struct port_string_tuple *et; ++ ++ et = malloc (sizeof *et); ++ if (et == NULL) ++ goto out; ++ ++ et->port = port; ++ et->name = strdup (name); ++ if (et->name == NULL) ++ goto out; ++ ++ et->next = *list; ++ *list = et; ++ return 0; ++ ++ out: ++ free (et); ++ return ENOMEM; ++} ++ ++/* fsys_goaway for early-boot /servers/startup. */ ++error_t ++S_fsys_goaway (mach_port_t fsys, ++ int flags) ++{ ++ if (fsys != early_startup_port) ++ return EOPNOTSUPP; ++ // XXX keep going = 0 ++ return 0; ++} ++ ++/* fsys_getroot for early-boot /servers/startup. */ ++error_t ++S_fsys_getroot (mach_port_t fsys, ++ mach_port_t dotdotnode, ++ uid_t *uids, size_t nuids, ++ uid_t *gids, size_t ngids, ++ int flags, ++ retry_type *do_retry, ++ char *retry_name, ++ mach_port_t *ret, ++ mach_msg_type_name_t *rettype) ++{ ++ if (fsys != early_startup_port) ++ return EOPNOTSUPP; ++ ++ *do_retry = FS_RETRY_NORMAL; ++ *retry_name = '\0'; ++ *ret = early_startup_port; ++ *rettype = MACH_MSG_TYPE_MAKE_SEND; ++ return 0; ++} ++ ++error_t ++S_startup_essential_task (startup_t server, ++ mach_port_t reply_port, ++ mach_msg_type_name_t reply_portPoly, ++ mach_port_t task, ++ mach_port_t excpt, ++ string_t name, ++ mach_port_t credential) ++{ ++ error_t err; ++ if (server != early_startup_port) ++ return EOPNOTSUPP; ++ if (credential != _hurd_host_priv) ++ return EPERM; ++ ++ err = mach_port_deallocate (mach_task_self (), credential); ++ assert_perror (err); ++ ++ if (MACH_PORT_VALID (excpt)) ++ { ++ error (0, 0, ++ "Oh dear, someone actually send us their exception port.\n" ++ "I'm going to destroy it. Please investigate."); ++ err = mach_port_destroy (mach_task_self (), excpt); ++ assert_perror (err); ++ } ++ ++ err = add_tuple (&essential_tasks, task, name); ++ if (err) ++ return err; ++ ++ return 0; ++} ++ ++kern_return_t ++S_startup_request_notification (mach_port_t server, ++ mach_port_t notify, ++ char *name) ++{ ++ if (server != early_startup_port) ++ return EOPNOTSUPP; ++ ++ return add_tuple (®istered_tasks, notify, name); ++} ++ ++static boolean_t ++early_startup_demuxer (mach_msg_header_t *request, ++ mach_msg_header_t *reply) ++{ ++ /* XXX hardcoded msgh_ids */ ++ if (request->msgh_id == 29000 /* startup_essential_task */ ++ || request->msgh_id == 29001) /* startup_request_notification */ ++ return startup_server (request, reply); ++ else if (request->msgh_id == 22001 /* fsys_goaway */ ++ || request->msgh_id == 22002) /* fsys_getroot */ ++ return fsys_server (request, reply); ++ ++ /* Return MIG_BAD_ID. */ ++ mig_reply_setup (request, reply); ++ return FALSE; ++} ++ ++static void * ++service_early_startup_requests (void *arg) ++{ ++ // XXX while (keep_going) ... ++ while (1) ++ mach_msg_server (early_startup_demuxer, 0, ++ early_startup_port); ++ ++ /* Not reached. */ ++ return NULL; ++} ++ ++static error_t ++start_handling_early_startup (mach_port_t startup_port) ++{ ++ error_t err; ++ pthread_t t; ++ ++ if (MACH_PORT_VALID (early_startup_port)) ++ return EINVAL; ++ early_startup_port = startup_port; ++ ++ /* Make a thread to service `startup_essential_task' requests. */ ++ err = pthread_create (&t, NULL, service_early_startup_requests, ++ NULL); ++ if (err) ++ return err; ++ pthread_detach (t); ++ ++ return err; ++} ++ ++pointer ++do__start_handling_early_startup (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("start-handling-early-startup"); ++ SC_ARG (sc, mach_port_t, server_port, number, args); ++ SC_ARGS_DONE (sc); ++ err = start_handling_early_startup (server_port); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__get_essential_tasks (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("get-essential-tasks"); ++ SC_ARGS_DONE (sc); ++ pointer result = sc->NIL; ++ struct port_string_tuple *et; ++ for (et = essential_tasks; et; et = et->next) ++#define IMC(A, B) _cons (sc, (A), (B), 1) ++ result = IMC (IMC (mk_integer (sc, et->port), ++ mk_string (sc, et->name)), ++ result); ++#undef IMC ++ SC_RETURN_POINTER (sc, result); ++} ++ ++pointer ++do__get_registered_tasks (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("get-registered-tasks"); ++ SC_ARGS_DONE (sc); ++ pointer result = sc->NIL; ++ struct port_string_tuple *rt; ++ for (rt = registered_tasks; rt; rt = rt->next) ++#define IMC(A, B) _cons (sc, (A), (B), 1) ++ result = IMC (IMC (mk_integer (sc, rt->port), ++ mk_string (sc, rt->name)), ++ result); ++#undef IMC ++ SC_RETURN_POINTER (sc, result); ++} ++ ++/* Client stubs for startup. */ ++pointer ++do__startup_essential_task (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("startup-essential-task"); ++ SC_ARG (sc, mach_port_t, startup, number, args); ++ SC_ARG (sc, mach_port_t, task, number, args); ++ SC_ARG (sc, mach_port_t, exception, number, args); ++ SC_ARG (sc, char *, name, string, args); ++ SC_ARG (sc, mach_port_t, credential, number, args); ++ SC_ARGS_DONE (sc); ++ err = startup_essential_task (startup, task, exception, name, credential); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__startup_request_notification (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("startup-request-notification"); ++ SC_ARG (sc, mach_port_t, startup, number, args); ++ SC_ARG (sc, mach_port_t, notify_port, number, args); ++ SC_ARG (sc, char *, name, string, args); ++ SC_ARGS_DONE (sc); ++ err = startup_request_notification (startup, ++ notify_port, MACH_MSG_TYPE_COPY_SEND, ++ name); ++ SC_RETURN (sc); ++} ++ ++pointer ++do__startup_reboot (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("startup-reboot"); ++ SC_ARG (sc, mach_port_t, startup, number, args); ++ SC_ARG (sc, mach_port_t, credential, number, args); ++ SC_ARG (sc, int, flags, number, args); ++ SC_ARGS_DONE (sc); ++ err = startup_reboot (startup, credential, flags); ++ SC_RETURN (sc); ++} ++ ++/* Handling of `startup_procinit'. */ ++ ++/* XXX would be nice not to use a global variable, maybe with ++ payloads. */ ++static struct ++{ ++ /* Filled by caller. */ ++ mach_port_t bootstrap_port; ++ ++ /* Filled by the server function. */ ++ mach_port_t reply; ++ mach_msg_type_name_t replyPoly; ++ process_t procserver; ++} startup_procinit_args; ++ ++kern_return_t ++S_startup_procinit (startup_t bootstrap, ++ mach_port_t reply, ++ mach_msg_type_name_t replyPoly, ++ process_t procserver, ++ mach_port_t *startuptask, ++ auth_t *auth, ++ mach_port_t *hostpriv, ++ mach_msg_type_name_t *hostprivPoly, ++ mach_port_t *devmaster, ++ mach_msg_type_name_t *devmasterPoly) ++{ ++ if (bootstrap != startup_procinit_args.bootstrap_port) ++ return EOPNOTSUPP; ++ ++ startup_procinit_args.reply = reply; ++ startup_procinit_args.replyPoly = replyPoly; ++ startup_procinit_args.procserver = procserver; ++ return MIG_NO_REPLY; ++} ++ ++boolean_t ++startup_procinit_demuxer (mach_msg_header_t *request, ++ mach_msg_header_t *reply) ++{ ++ if (request->msgh_id != 29003) /* XXX hardcoded msgh_id */ ++ { ++ /* Return MIG_BAD_ID. */ ++ mig_reply_setup (request, reply); ++ return FALSE; ++ } ++ return startup_server (request, reply); ++} ++ ++error_t ++service_startup_procinit_request (mach_port_t bootstrap, ++ mach_msg_timeout_t timeout, ++ mach_port_t *reply, ++ mach_msg_type_name_t *replyPoly, ++ process_t *procserver) ++{ ++ error_t err; ++ mach_msg_id_t msgh_id; ++ ++ if (! MACH_PORT_VALID (bootstrap)) ++ return EINVAL; ++ ++ startup_procinit_args.bootstrap_port = bootstrap; ++ ++ err = mach_msg_server_timeout_once (startup_procinit_demuxer, 0, bootstrap, ++ MACH_RCV_TIMEOUT|MACH_SEND_TIMEOUT, ++ timeout, &msgh_id); ++ if (err != MACH_MSG_SUCCESS) ++ return err; ++ ++ *reply = startup_procinit_args.reply; ++ *replyPoly = startup_procinit_args.replyPoly; ++ *procserver = startup_procinit_args.procserver; ++ return 0; ++} ++ ++pointer ++do__handle_startup_procinit (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("handle-startup-procinit"); ++ SC_ARG (sc, mach_port_t, bootstrap, number, args); ++ SC_ARG (sc, mach_msg_timeout_t, timeout, number, args); ++ SC_ARGS_DONE (sc); ++ mach_port_t reply; ++ mach_msg_type_name_t replyPoly; ++ mach_port_t proc; ++ err = service_startup_procinit_request (bootstrap, timeout, ++ &reply, &replyPoly, &proc); ++#define IMC(A, B) _cons (sc, sc->vptr->mk_integer (sc, A), (B), 1) ++ SC_RETURN_POINTER (sc, IMC (reply, IMC (replyPoly, IMC (proc, sc->NIL)))); ++#undef IMC ++} ++ ++pointer ++do__startup_procinit_reply (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("startup-procinit-reply"); ++ SC_ARG (sc, mach_port_t, reply, number, args); ++ SC_ARG (sc, mach_msg_type_name_t, replyPoly, number, args); ++ SC_ARG (sc, int, retCode, number, args); ++ SC_ARG (sc, mach_port_t, startup_task, number, args); ++ SC_ARG (sc, mach_port_t, authserver, number, args); ++ SC_ARG (sc, mach_port_t, host_priv, number, args); ++ SC_ARG (sc, mach_port_t, device_master, number, args); ++ SC_ARGS_DONE (sc); ++ err = startup_procinit_reply (reply, replyPoly, retCode, ++ startup_task, authserver, ++ host_priv, MACH_MSG_TYPE_COPY_SEND, ++ device_master, MACH_MSG_TYPE_COPY_SEND); ++ SC_RETURN (sc); ++} ++ ++/* Handling of `startup_authinit'. */ ++ ++/* XXX would be nice not to use a global variable, maybe with ++ payloads. */ ++static struct ++{ ++ /* Filled by caller. */ ++ mach_port_t bootstrap_port; ++ ++ /* Filled by the server function. */ ++ mach_port_t reply; ++ mach_msg_type_name_t replyPoly; ++ mach_port_t authserver; ++} startup_authinit_args; ++ ++/* Called by the auth server when it starts up. */ ++ ++kern_return_t ++S_startup_authinit (startup_t bootstrap, ++ mach_port_t reply, ++ mach_msg_type_name_t replyPoly, ++ mach_port_t auth, ++ mach_port_t *proc, ++ mach_msg_type_name_t *procPoly) ++{ ++ if (bootstrap != startup_authinit_args.bootstrap_port) ++ return EOPNOTSUPP; ++ ++ startup_authinit_args.reply = reply; ++ startup_authinit_args.replyPoly = replyPoly; ++ startup_authinit_args.authserver = auth; ++ return MIG_NO_REPLY; ++} ++ ++boolean_t ++startup_authinit_demuxer (mach_msg_header_t *request, ++ mach_msg_header_t *reply) ++{ ++ if (request->msgh_id != 29004) /* XXX hardcoded msgh_id */ ++ { ++ /* Return MIG_BAD_ID. */ ++ mig_reply_setup (request, reply); ++ return FALSE; ++ } ++ return startup_server (request, reply); ++} ++ ++error_t ++service_startup_authinit_request (mach_port_t bootstrap, ++ mach_msg_timeout_t timeout, ++ mach_port_t *reply, ++ mach_msg_type_name_t *replyPoly, ++ mach_port_t *authserver) ++{ ++ error_t err; ++ mach_msg_id_t msgh_id; ++ ++ if (! MACH_PORT_VALID (bootstrap)) ++ return EINVAL; ++ ++ startup_authinit_args.bootstrap_port = bootstrap; ++ ++ err = mach_msg_server_timeout_once (startup_authinit_demuxer, 0, bootstrap, ++ MACH_RCV_TIMEOUT|MACH_SEND_TIMEOUT, ++ timeout, &msgh_id); ++ if (err != MACH_MSG_SUCCESS) ++ return err; ++ ++ *reply = startup_authinit_args.reply; ++ *replyPoly = startup_authinit_args.replyPoly; ++ *authserver = startup_authinit_args.authserver; ++ return 0; ++} ++ ++pointer ++do__handle_startup_authinit (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("handle-startup-authinit"); ++ SC_ARG (sc, mach_port_t, bootstrap, number, args); ++ SC_ARG (sc, mach_msg_timeout_t, timeout, number, args); ++ SC_ARGS_DONE (sc); ++ mach_port_t reply; ++ mach_msg_type_name_t replyPoly; ++ mach_port_t auth; ++ err = service_startup_authinit_request (bootstrap, timeout, ++ &reply, &replyPoly, &auth); ++#define IMC(A, B) _cons (sc, sc->vptr->mk_integer (sc, A), (B), 1) ++ SC_RETURN_POINTER (sc, IMC (reply, IMC (replyPoly, IMC (auth, sc->NIL)))); ++#undef IMC ++} ++ ++pointer ++do__startup_authinit_reply (scheme *sc, pointer args) ++{ ++ SC_FFI_PROLOG ("startup-authinit-reply"); ++ SC_ARG (sc, mach_port_t, reply, number, args); ++ SC_ARG (sc, mach_msg_type_name_t, replyPoly, number, args); ++ SC_ARG (sc, int, retCode, number, args); ++ SC_ARG (sc, mach_port_t, authproc, number, args); ++ SC_ARGS_DONE (sc); ++ err = startup_authinit_reply (reply, replyPoly, retCode, authproc, ++ MACH_MSG_TYPE_COPY_SEND); ++ SC_RETURN (sc); ++} +diff --git a/bootshell/startup.h b/bootshell/startup.h +new file mode 100644 +index 0000000..69f760f +--- /dev/null ++++ b/bootshell/startup.h +@@ -0,0 +1,12 @@ ++#include ++ ++pointer do__handle_startup_procinit (scheme *sc, pointer args); ++pointer do__handle_startup_authinit (scheme *sc, pointer args); ++pointer do__startup_procinit_reply (scheme *sc, pointer args); ++pointer do__startup_authinit_reply (scheme *sc, pointer args); ++pointer do__start_handling_early_startup (scheme *sc, pointer args); ++pointer do__get_essential_tasks (scheme *sc, pointer args); ++pointer do__get_registered_tasks (scheme *sc, pointer args); ++pointer do__startup_essential_task (scheme *sc, pointer args); ++pointer do__startup_request_notification (scheme *sc, pointer args); ++pointer do__startup_reboot (scheme *sc, pointer args); +diff --git a/bootshell/utils.c b/bootshell/utils.c +new file mode 100644 +index 0000000..31c3f4a +--- /dev/null ++++ b/bootshell/utils.c +@@ -0,0 +1,121 @@ ++#include ++#include ++#include ++#include ++#include ++#include ++ ++mach_msg_return_t ++mach_msg_server_timeout_once (boolean_t (*demux) (mach_msg_header_t *request, ++ mach_msg_header_t *reply), ++ mach_msg_size_t max_size, ++ mach_port_t rcv_name, ++ mach_msg_option_t option, ++ mach_msg_timeout_t timeout, ++ mach_msg_id_t *msgh_id) ++{ ++ mig_reply_header_t *request, *reply; ++ mach_msg_return_t mr; ++ ++ if (! MACH_PORT_VALID (rcv_name)) ++ return EINVAL; ++ ++ if (max_size == 0) ++ { ++#ifdef MACH_RCV_LARGE ++ option |= MACH_RCV_LARGE; ++ max_size = 2 * __vm_page_size; /* Generic. Good? XXX */ ++#else ++ max_size = 4 * __vm_page_size; /* XXX */ ++#endif ++ } ++ ++ request = alloca (max_size); ++ reply = alloca (max_size); ++ ++ mr = mach_msg (&request->Head, MACH_RCV_MSG|option, ++ 0, max_size, rcv_name, ++ timeout, MACH_PORT_NULL); ++ if (mr != MACH_MSG_SUCCESS) ++ return mr; ++ ++ *msgh_id = request->Head.msgh_id; ++ ++ /* We have a request message. Pass it to DEMUX for processing. */ ++ (void) (*demux) (&request->Head, &reply->Head); ++ assert (reply->Head.msgh_size <= max_size); ++ ++ switch (reply->RetCode) ++ { ++ case KERN_SUCCESS: ++ /* Hunky dory. */ ++ break; ++ ++ case MIG_NO_REPLY: ++ /* The server function wanted no reply sent. ++ Loop for another request. */ ++ return 0; ++ ++ default: ++ /* Some error; destroy the request message to release any ++ port rights or VM it holds. Don't destroy the reply port ++ right, so we can send an error message. */ ++ request->Head.msgh_remote_port = MACH_PORT_NULL; ++ mach_msg_destroy (&request->Head); ++ break; ++ } ++ ++ if (reply->Head.msgh_remote_port == MACH_PORT_NULL) ++ { ++ /* No reply port, so destroy the reply. */ ++ if (reply->Head.msgh_bits & MACH_MSGH_BITS_COMPLEX) ++ mach_msg_destroy (&reply->Head); ++ return reply->RetCode; ++ } ++ ++ /* Send the reply. */ ++ mr = mach_msg (&reply->Head, ++ MACH_SEND_MSG|option, ++ reply->Head.msgh_size, max_size, rcv_name, ++ timeout, MACH_PORT_NULL); ++ ++ /* See if a message error occurred. */ ++ if (mr == MACH_SEND_INVALID_DEST) ++ /* The reply can't be delivered, so destroy it. This error ++ indicates only that the requester went away, so we ++ continue and get the next request. */ ++ mach_msg_destroy (&request->Head); ++ ++ return mr != 0 ? mr : request->RetCode; ++} ++ ++/* Fill in default response. */ ++void ++mig_reply_setup ( ++ const mach_msg_header_t *in, ++ mach_msg_header_t *out) ++{ ++ static const mach_msg_type_t RetCodeType = { ++ /* msgt_name = */ MACH_MSG_TYPE_INTEGER_32, ++ /* msgt_size = */ 32, ++ /* msgt_number = */ 1, ++ /* msgt_inline = */ TRUE, ++ /* msgt_longform = */ FALSE, ++ /* msgt_deallocate = */ FALSE, ++ /* msgt_unused = */ 0 ++ }; ++ ++#define InP (in) ++#define OutP ((mig_reply_header_t *) out) ++ OutP->Head.msgh_bits = ++ MACH_MSGH_BITS(MACH_MSGH_BITS_REMOTE(InP->msgh_bits), 0); ++ OutP->Head.msgh_size = sizeof *OutP; ++ OutP->Head.msgh_remote_port = InP->msgh_remote_port; ++ OutP->Head.msgh_local_port = MACH_PORT_NULL; ++ OutP->Head.msgh_seqno = 0; ++ OutP->Head.msgh_id = InP->msgh_id + 100; ++ OutP->RetCodeType = RetCodeType; ++ OutP->RetCode = MIG_BAD_ID; ++#undef InP ++#undef OutP ++} +-- +2.1.4 + diff --git a/debian/patches/0010-potfu_bootshell_fixbuild.patch b/debian/patches/0010-potfu_bootshell_fixbuild.patch new file mode 100644 index 00000000..7f475cad --- /dev/null +++ b/debian/patches/0010-potfu_bootshell_fixbuild.patch @@ -0,0 +1,75 @@ +From 8905e266cc72b915cae5be6630907ba08789cd06 Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Wed, 14 Jan 2015 02:13:46 +0100 +Subject: [PATCH hurd 10/11] potfu_bootshell_fixbuild + +--- + bootshell/Makefile | 4 +++- + bootshell/ffi.h | 11 ++++++----- + bootshell/main.c | 6 +++--- + 3 files changed, 12 insertions(+), 9 deletions(-) + +diff --git a/bootshell/Makefile b/bootshell/Makefile +index 97e30f7..2b22696 100644 +--- a/bootshell/Makefile ++++ b/bootshell/Makefile +@@ -52,7 +52,9 @@ LDFLAGS += -static + MIGSFLAGS := -imacros mig-mutate.h + + %.o: %.scm +- $(LD) -r --format=binary $< -o $@ ++ cat <$< >.$@ ++ $(LD) -r --format=binary .$@ -o $@ ++ rm .$@ + + NOWARN := conversion sign-conversion switch unused-function + CFLAGS := $(filter-out $(foreach flag,$NOWARN,-W$(flag)),$(CFLAGS)) +diff --git a/bootshell/ffi.h b/bootshell/ffi.h +index b1b3f97..60ab50d 100644 +--- a/bootshell/ffi.h ++++ b/bootshell/ffi.h +@@ -94,8 +94,9 @@ + void scheme_load_mem (scheme *, const char *, const char *); + + #define declare_embedded_script(X) \ +- extern char X##_start[] asm("_binary_"#X"_start"); \ +- extern char X##_end[] asm("_binary_"#X"_end") ++ extern char X##_size[] asm("_binary__"#X"_o_size"); \ ++ extern char X##_start[] asm("_binary__"#X"_o_start"); \ ++ extern char X##_end[] asm("_binary__"#X"_o_end") + + #define load_embedded_script(S, X) \ + ({ \ +@@ -104,9 +105,9 @@ void scheme_load_mem (scheme *, const char *, const char *); + fprintf (stderr, "Errors encountered evaluating %s\n", #X); \ + }) + +-declare_embedded_script (init_scm); +-declare_embedded_script (boot_scm); +-declare_embedded_script (runsystem_scm); ++declare_embedded_script (init); ++declare_embedded_script (boot); ++declare_embedded_script (runsystem); + + void ffi_update (scheme *sc); + void ffi_init (scheme *sc); +diff --git a/bootshell/main.c b/bootshell/main.c +index f5f3ab5..823a143 100644 +--- a/bootshell/main.c ++++ b/bootshell/main.c +@@ -232,9 +232,9 @@ main (int argc, char **argv) + + ffi_init (&scm); + +- load_embedded_script (&scm, init_scm); +- load_embedded_script (&scm, boot_scm); +- load_embedded_script (&scm, runsystem_scm); ++ load_embedded_script (&scm, init); ++ load_embedded_script (&scm, boot); ++ load_embedded_script (&scm, runsystem); + + define_variable (&scm, bootscript_task); + define_variable (&scm, rootfs_server_task); +-- +2.1.4 + diff --git a/debian/patches/0011-bootshell-improve-error-message.patch b/debian/patches/0011-bootshell-improve-error-message.patch new file mode 100644 index 00000000..6d4ae6e1 --- /dev/null +++ b/debian/patches/0011-bootshell-improve-error-message.patch @@ -0,0 +1,27 @@ +From 13246988637409ac6487ac4ac2909e14d7fbb812 Mon Sep 17 00:00:00 2001 +From: Justus Winter <4winter@informatik.uni-hamburg.de> +Date: Tue, 13 Jan 2015 17:16:46 +0100 +Subject: [PATCH hurd 11/11] bootshell: improve error message + +* bootshell/scheme.c (opexe_0): Mention the expression in the error +message. +--- + bootshell/scheme.c | 2 +- + 1 file changed, 1 insertion(+), 1 deletion(-) + +diff --git a/bootshell/scheme.c b/bootshell/scheme.c +index 5ca5641..6f583f5 100644 +--- a/bootshell/scheme.c ++++ b/bootshell/scheme.c +@@ -2679,7 +2679,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) { + sc->dump = cont_dump(sc->code); + s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL); + } else { +- Error_0(sc,"illegal function"); ++ Error_1(sc,"illegal function:", sc->code); + } + + case OP_DOMACRO: /* do macro */ +-- +2.1.4 + diff --git a/debian/patches/series b/debian/patches/series index bde0ea07..7bf3ac1a 100644 --- a/debian/patches/series +++ b/debian/patches/series @@ -47,3 +47,14 @@ libports-payloads.patch proc-task-notify-0005-proc-fix-build.patch merge-me-0001-libports-avoid-acquiring-global-lock-in-message-disp.patch merge-me-0002-startup-faster-reboots.patch +0001-libports-silence-pointless-error-message.patch +0002-startup-give-the-tasks-we-create-a-name.patch +0003-auth-simplify-expression.patch +0004-auth-remove-implicit-assumption-about-the-bootstrap-.patch +0005-proc-call-startup_essential_task-earlier.patch +0006-libshouldbeinlibc-provide-mach_print-XXX.patch +0007-libdiskfs-fixes-XXX.patch +0008-trans-add-startup-standalone-XXX.patch +0009-XXX-bootshell.patch +0010-potfu_bootshell_fixbuild.patch +0011-bootshell-improve-error-message.patch -- cgit v1.2.3