diff options
31 files changed, 7 insertions, 16297 deletions
diff --git a/debian/patches/bootshell0001-daemons-console-run-add-console-argument-to-select-t.patch b/debian/patches/bootshell0001-daemons-console-run-add-console-argument-to-select-t.patch deleted file mode 100644 index 11dc7de6..00000000 --- a/debian/patches/bootshell0001-daemons-console-run-add-console-argument-to-select-t.patch +++ /dev/null @@ -1,120 +0,0 @@ -From 0aa6f9897b9b56600c0d80a11415dadc1c980ea5 Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Fri, 30 Jan 2015 10:01:31 +0100 -Subject: [PATCH hurd 01/11] daemons/console-run: add `--console' argument to - select the device - -Parse the command line arguments, and honor `--console' to select the -console device. - -* daemons/console-run.c (console_device, cmd_argv, doc, args_doc, argp): -New variables. -(parse_opt): New function. -(main): Use `argp_parse', adapt accordingly. -(open_console): Use `console_device' instead of hardcoded value. ---- - daemons/console-run.c | 58 ++++++++++++++++++++++++++++++++++++++++++++------- - 1 file changed, 51 insertions(+), 7 deletions(-) - -diff --git a/daemons/console-run.c b/daemons/console-run.c -index e1bfe64..a76ec8a 100644 ---- a/daemons/console-run.c -+++ b/daemons/console-run.c -@@ -17,6 +17,7 @@ - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111, USA. */ - -+#include <argp.h> - #include <stdio.h> - #include <stdlib.h> - #include <unistd.h> -@@ -26,7 +27,51 @@ - #include <hurd.h> - #include <hurd/fshelp.h> - #include <device/device.h> -+ -+char *console_device = _PATH_CONSOLE; -+char **cmd_argv; -+ -+static const struct argp_option options[] = -+{ -+ {"console", 'c', "DEVICE", 0, "use this device ["_PATH_CONSOLE"]"}, -+ {0} -+}; -+ -+static error_t -+parse_opt (int opt, char *arg, struct argp_state *state) -+{ -+ switch (opt) -+ { -+ case 'c': -+ console_device = arg; -+ break; -+ -+ case ARGP_KEY_NO_ARGS: -+ argp_usage (state); -+ return EINVAL; -+ -+ case ARGP_KEY_ARG: -+ cmd_argv = &state->argv[state->next - 1]; -+ state->next = state->argc; -+ 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[] = -+ "Open a terminal and run the given program"; -+static const char args_doc[] = "COMMAND [ARG...]"; -+ -+static const struct argp argp = -+{ options, parse_opt, args_doc, doc }; -+ - static mach_port_t - get_console () - { -@@ -60,20 +105,19 @@ main (int argc, char **argv) - if (!stderr) - _exit (127); - -- if (argc < 2) -- error (1, 0, "Usage: %s PROGRAM [ARG...]", program_invocation_short_name); -+ argp_parse (&argp, argc, argv, ARGP_IN_ORDER, 0, 0); - - /* Check whether runsystem exists before opening a console for it. */ -- runsystem = file_name_lookup (argv[1], O_RDONLY, 0); -+ runsystem = file_name_lookup (cmd_argv[0], O_RDONLY, 0); - if (runsystem == MACH_PORT_NULL) -- error (127, errno, "cannot open file `%s' for execution", argv[1]); -+ error (127, errno, "cannot open file `%s' for execution", cmd_argv[0]); - mach_port_deallocate (mach_task_self (), runsystem); - - if (open_console (&consname)) - setenv ("FALLBACK_CONSOLE", consname, 1); - -- execv (argv[1], &argv[1]); -- error (5, errno, "cannot execute %s", argv[1]); -+ execv (cmd_argv[0], &cmd_argv[0]); -+ error (5, errno, "cannot execute %s", cmd_argv[0]); - /* NOTREACHED */ - return 127; - } -@@ -97,7 +141,7 @@ open_console (char **namep) - int fd; - int fallback; - -- termname = _PATH_CONSOLE; -+ termname = console_device; - term = file_name_lookup (termname, O_RDWR, 0); - if (term != MACH_PORT_NULL) - err = io_stat (term, &st); --- -2.1.4 - diff --git a/debian/patches/bootshell0002-trans-add-startup-standalone.patch b/debian/patches/bootshell0002-trans-add-startup-standalone.patch deleted file mode 100644 index 268cc757..00000000 --- a/debian/patches/bootshell0002-trans-add-startup-standalone.patch +++ /dev/null @@ -1,504 +0,0 @@ -From b96c3ff610bc95d91aeba32691c28b4946362df3 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 02/11] trans: add `startup-standalone' - -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 | 446 +++++++++++++++++++++++++++++++++++++++++++++ - 2 files changed, 451 insertions(+), 4 deletions(-) - create mode 100644 trans/startup-standalone.c - -diff --git a/trans/Makefile b/trans/Makefile -index ec0586e..7f0a83c 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 random -+ mtab random 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 startup_notifyServer.o -+ device_replyServer.o elfcore.o startup_notifyServer.o startupServer.o - HURDLIBS = ports netfs trivfs iohelp fshelp pipe ihash shouldbeinlibc - LDLIBS += -lpthread - password-LDLIBS = -lcrypt -@@ -63,8 +63,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..187a126 ---- /dev/null -+++ b/trans/startup-standalone.c -@@ -0,0 +1,446 @@ -+/* 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 <argp.h> -+#include <argz.h> -+#include <error.h> -+#include <fcntl.h> -+#include <hurd/ports.h> -+#include <hurd/trivfs.h> -+#include <stdlib.h> -+#include <stdio.h> -+#include <string.h> -+#include <sys/mman.h> -+#include <sys/reboot.h> -+#include <unistd.h> -+#include <version.h> -+ -+#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[] = -+{ -+ {"crash-debug", 'H', NULL, 0, "On system crash, go to kernel debugger", 0}, -+ {0} -+}; -+ -+static error_t -+parse_opt (int opt, char *arg, struct argp_state *state) -+{ -+ switch (opt) -+ { -+ case 'H': crash_flags = RB_DEBUGGER; break; -+ 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) -+{ -+ error_t err = 0; -+ -+ if (crash_flags == RB_DEBUGGER) -+ err = argz_add (argz, argz_len, "--crash-debug"); -+ -+ return err; -+} -+ -+static const char doc[] = -+ "Supervise Hurd core servers and manage system shutdown"; -+ -+static struct argp argp = -+ { -+ .options = options, -+ .parser = parse_opt, -+ .args_doc = NULL, -+ .doc = doc, -+ }; -+ -+/* Setting this variable makes libtrivfs use our argp to -+ parse options passed in an fsys_set_options RPC. */ -+struct argp *trivfs_runtime_argp = &argp; -+ -+static int -+demuxer (mach_msg_header_t *inp, -+ mach_msg_header_t *outp) -+{ -+ mig_routine_t routine; -+ if ((routine = startup_server_routine (inp)) || -+ (routine = NULL, trivfs_demuxer (inp, outp))) -+ { -+ if (routine) -+ (*routine) (inp, outp); -+ return TRUE; -+ } -+ else -+ return FALSE; -+} -+ -+int -+main (int argc, char **argv) -+{ -+ error_t err; -+ mach_port_t bootstrap; -+ struct trivfs_control *fsys; -+ struct port_class *notification_class; -+ -+ /* We use the same argp for options available at startup -+ as for options we'll accept in an fsys_set_options RPC. */ -+ argp_parse (&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 (! err && MACH_PORT_VALID (prev)) -+ 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) -+{ -+ error_t err; -+ struct ntfy_task *nt; -+ -+ err = request_dead_name (notify); -+ if (err) -+ return err; -+ -+ /* 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. */ -+ err = mach_port_deallocate (mach_task_self (), dead_name); -+ assert_perror (err); -+ 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/bootshell0003-libdiskfs-fixes-XXX.patch b/debian/patches/bootshell0003-libdiskfs-fixes-XXX.patch deleted file mode 100644 index 5afb2bb5..00000000 --- a/debian/patches/bootshell0003-libdiskfs-fixes-XXX.patch +++ /dev/null @@ -1,66 +0,0 @@ -From 3a7a90a40f9920fa613dd648aff34b09af124781 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 03/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 731d8c6..511dd61 100644 ---- a/libdiskfs/boot-start.c -+++ b/libdiskfs/boot-start.c -@@ -466,7 +466,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 357960b..3c42b3d 100644 ---- a/libdiskfs/init-init.c -+++ b/libdiskfs/init-init.c -@@ -69,14 +69,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 14da003..404b1a5 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/bootshell0004-bootshell-import-TinyScheme-1.41.patch b/debian/patches/bootshell0004-bootshell-import-TinyScheme-1.41.patch deleted file mode 100644 index 0891c5e7..00000000 --- a/debian/patches/bootshell0004-bootshell-import-TinyScheme-1.41.patch +++ /dev/null @@ -1,7336 +0,0 @@ -From 2bf2dab79ccd3f39a1f9d72b58e639c26ff91a04 Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Sat, 24 Jan 2015 01:52:58 +0100 -Subject: [PATCH hurd 04/11] bootshell: import TinyScheme 1.41 - -This is a verbatim import of TinyScheme 1.41. - -* bootshell/COPYING.tinyscheme: New file. -* bootshell/Manual.txt: Likewise. -* bootshell/MiniSCHEMETribute.txt: Likewise. -* bootshell/hack.txt: Likewise. -* bootshell/init.scm: Likewise. -* bootshell/opdefines.h: Likewise. -* bootshell/scheme-private.h: Likewise. -* bootshell/scheme.c: Likewise. -* bootshell/scheme.h: Likewise. ---- - bootshell/COPYING.tinyscheme | 31 + - bootshell/Manual.txt | 452 ++++ - bootshell/MiniSCHEMETribute.txt | 88 + - bootshell/hack.txt | 244 ++ - bootshell/init.scm | 716 ++++++ - bootshell/opdefines.h | 195 ++ - bootshell/scheme-private.h | 210 ++ - bootshell/scheme.c | 5051 +++++++++++++++++++++++++++++++++++++++ - bootshell/scheme.h | 255 ++ - 9 files changed, 7242 insertions(+) - create mode 100644 bootshell/COPYING.tinyscheme - create mode 100644 bootshell/Manual.txt - create mode 100644 bootshell/MiniSCHEMETribute.txt - create mode 100644 bootshell/hack.txt - create mode 100644 bootshell/init.scm - create mode 100644 bootshell/opdefines.h - create mode 100644 bootshell/scheme-private.h - create mode 100644 bootshell/scheme.c - create mode 100644 bootshell/scheme.h - -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/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? <symbol>) (defined? <symbol> <environment>) -+ 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 <bool>) -+ The argument (defaulting to #t) controls whether GC produces -+ visible outcome. -+ -+ (quit) (quit <num>) -+ Stops the interpreter and sets the 'retcode' internal field (defaults -+ to 0). When standalone, 'retcode' is returned as exit code to the OS. -+ -+ (tracing <num>) -+ 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<=?, 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<=?, 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 <filename without 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 <form>) -+ Returns the expanded form of the macro call denoted by the argument -+ -+ (define-with-return (<procname> <args>...) <body>) -+ Like plain 'define', but makes the continuation available as 'return' -+ inside the procedure. Handy for imperative programs. -+ -+ (new-segment <num>) -+ Allocates more memory segments. -+ -+ defined? -+ See "Environments" -+ -+ (get-closure-code <closure>) -+ Gets the code as scheme data. -+ -+ (make-closure <code> <environment>) -+ Makes a new closure in the given environment. -+ -+ Obsolete procedures -+ (print-width <object>) -+ -+ 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_<base-name>. 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 [<file1> <file2> ...] -+ followed by -+ -1 <file> [<arg1> <arg2> ...] -+ -c <Scheme commands> [<arg1> <arg2> ...] -+ 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 <expr returned exceptionally> -+ <expr1> <expr2> ... <exprN>) -+ -+ "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 <qualifier>::<symbol> and -+ transforms it in the following manner (T is the transformation function): -+ -+ T(<qualifier>::<symbol>) = (*colon-hook* 'T(<symbol>) <qualifier>) -+ -+ where <qualifier> 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: -+ <SDI00379@niftyserve.or.jp> -+ -+ -+ 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/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 <n> [<fill>]) makes a new block of the specified size -+ optionally filling it with a specified byte -+ (block? <obj>) -+ (block-length <block>) -+ (block-ref <block> <index>) retrieves byte at location -+ (block-set! <block> <index> <byte>) 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 = "#<CONTINUATION>"; -+> } else if (is_memblock(l)) { -+> p = "#<MEMORY BLOCK>"; -+| } 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>=? 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)) -+(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>=? 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 (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/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/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..99f9106 ---- /dev/null -+++ b/bootshell/scheme.c -@@ -0,0 +1,5051 @@ -+/* 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 <unistd.h> -+#endif -+#ifdef WIN32 -+#define snprintf _snprintf -+#endif -+#if USE_DL -+# include "dynload.h" -+#endif -+#if USE_MATH -+# include <math.h> -+#endif -+ -+#include <limits.h> -+#include <float.h> -+#include <ctype.h> -+ -+#if USE_STRCASECMP -+#include <strings.h> -+# 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 <string.h> -+#include <stdlib.h> -+ -+#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.ivalue<b.value.ivalue; -+ } else { -+ ret=num_rvalue(a)<num_rvalue(b); -+ } -+ return ret; -+} -+ -+static int num_le(num a, num b) { -+ return !num_gt(a,b); -+} -+ -+#if USE_MATH -+/* Round to nearest. Round to even if midway */ -+static double round_per_R5RS(double x) { -+ double fl=floor(x); -+ double ce=ceil(x); -+ double dfl=x-fl; -+ double dce=ce-x; -+ if(dfl>dce) { -+ return ce; -+ } else if(dfl<dce) { -+ return fl; -+ } else { -+ if(fmod(fl,2.0)==0.0) { /* I imagine this holds */ -+ return fl; -+ } else { -+ return ce; -+ } -+ } -+} -+#endif -+ -+static int is_zero_double(double x) { -+ return x<DBL_MIN && x>-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(adj<sizeof(struct cell)) { -+ adj=sizeof(struct cell); -+ } -+ -+ for (k = 0; k < n; k++) { -+ if (sc->last_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;i<n;i++) -+ { (void)check_cell_alloced(p+i,expect_alloced); } -+} -+ -+#endif -+ -+/* Medium level cell allocation */ -+ -+/* get new cons cell */ -+pointer _cons(scheme *sc, pointer a, pointer b, int immutable) { -+ pointer x = get_cell(sc,a, b); -+ -+ typeflag(x) = T_PAIR; -+ if(immutable) { -+ setimmutable(x); -+ } -+ car(x) = a; -+ cdr(x) = b; -+ return (x); -+} -+ -+/* ========== oblist implementation ========== */ -+ -+#ifndef USE_OBJECT_LIST -+ -+static int hash_fn(const char *key, int table_size); -+ -+static pointer oblist_initial_value(scheme *sc) -+{ -+ return mk_vector(sc, 461); /* probably should be bigger */ -+} -+ -+/* returns the new symbol */ -+static pointer oblist_add_by_name(scheme *sc, const char *name) -+{ -+ pointer x; -+ int location; -+ -+ x = immutable_cons(sc, mk_string(sc, name), sc->NIL); -+ 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; i<num; i++) { -+ typeflag(vec+1+i) = T_PAIR; -+ setimmutable(vec+1+i); -+ car(vec+1+i)=obj; -+ cdr(vec+1+i)=obj; -+ } -+} -+ -+INTERFACE static pointer vector_elem(pointer vec, int ielem) { -+ int n=ielem/2; -+ if(ielem%2==0) { -+ return car(vec+1+n); -+ } else { -+ return cdr(vec+1+n); -+ } -+} -+ -+INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) { -+ int n=ielem/2; -+ if(ielem%2==0) { -+ return car(vec+1+n)=a; -+ } else { -+ return cdr(vec+1+n)=a; -+ } -+} -+ -+/* get new symbol */ -+INTERFACE pointer mk_symbol(scheme *sc, const char *name) { -+ pointer x; -+ -+ /* first check oblist */ -+ x = oblist_find_by_name(sc, name); -+ if (x != sc->NIL) { -+ 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_cnt<LONG_MAX; sc->gensym_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; i<num; i++) { -+ /* Vector cells will be treated like ordinary cells */ -+ mark(p+1+i); -+ } -+ } -+ if (is_atom(p)) -+ goto E6; -+ /* E4: down car */ -+ q = car(p); -+ if (q && !is_mark(q)) { -+ setatom(p); /* a note that we have moved car */ -+ car(p) = t; -+ t = p; -+ p = q; -+ goto E2; -+ } -+E5: q = cdr(p); /* down cdr */ -+ if (q && !is_mark(q)) { -+ cdr(p) = t; -+ t = p; -+ p = q; -+ goto E2; -+ } -+E6: /* up. Undo the link switching from steps E4 and E5. */ -+ if (!t) -+ return; -+ q = t; -+ if (is_atom(q)) { -+ clratom(q); -+ t = car(q); -+ car(q) = p; -+ p = q; -+ goto E5; -+ } else { -+ t = cdr(q); -+ cdr(q) = p; -+ p = q; -+ goto E6; -+ } -+} -+ -+/* garbage collection. parameter a, b is marked. */ -+static void gc(scheme *sc, pointer a, pointer b) { -+ pointer p; -+ int i; -+ -+ if(sc->gc_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; i<len; i++) { -+ if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') { -+ putcharacter(sc,'\\'); -+ switch(*s) { -+ case '"': -+ putcharacter(sc,'"'); -+ break; -+ case '\n': -+ putcharacter(sc,'n'); -+ break; -+ case '\t': -+ putcharacter(sc,'t'); -+ break; -+ case '\r': -+ putcharacter(sc,'r'); -+ break; -+ case '\\': -+ putcharacter(sc,'\\'); -+ break; -+ default: { -+ int d=*s/16; -+ putcharacter(sc,'x'); -+ if(d<10) { -+ putcharacter(sc,d+'0'); -+ } else { -+ putcharacter(sc,d-10+'A'); -+ } -+ d=*s%16; -+ if(d<10) { -+ putcharacter(sc,d+'0'); -+ } else { -+ putcharacter(sc,d-10+'A'); -+ } -+ } -+ } -+ } else { -+ putcharacter(sc,*s); -+ } -+ s++; -+ } -+ putcharacter(sc,'"'); -+} -+ -+ -+/* print atoms */ -+static void printatom(scheme *sc, pointer l, int f) { -+ char *p; -+ int len; -+ atom2str(sc,l,f,&p,&len); -+ putchars(sc,p,len); -+} -+ -+ -+/* Uses internal buffer unless string pointer is already available */ -+static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) { -+ char *p; -+ -+ if (l == sc->NIL) { -+ p = "()"; -+ } else if (l == sc->T) { -+ p = "#t"; -+ } else if (l == sc->F) { -+ p = "#f"; -+ } else if (l == sc->EOF_OBJ) { -+ p = "#<EOF>"; -+ } else if (is_port(l)) { -+ p = sc->strbuff; -+ snprintf(p, STRBUFFSIZE, "#<PORT>"); -+ } 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 = "#<MACRO>"; -+ } else if (is_closure(l)) { -+ p = "#<CLOSURE>"; -+ } else if (is_promise(l)) { -+ p = "#<PROMISE>"; -+ } else if (is_foreign(l)) { -+ p = sc->strbuff; -+ snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l)); -+ } else if (is_continuation(l)) { -+ p = "#<CONTINUATION>"; -+ } else { -+ p = "#<ERROR>"; -+ } -+ *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 = "<unknown>"; -+ -+ /* 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; i<nframes; i++) { -+ struct dump_stack_frame *frame; -+ frame = (struct dump_stack_frame *)sc->dump_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)) || index1<index0) { -+ Error_1(sc,"substring: end out of bounds:",caddr(sc->args)); -+ } -+ } 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,"#<ENVIRONMENT>"); -+ 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(n<pcd->min_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(i<n); -+ if(i<n) { -+ ok=0; -+ snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s", -+ pcd->name, -+ 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; i<n; i++) { -+ if(dispatch_table[i].name!=0) { -+ assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name); -+ } -+ } -+ -+ /* initialization of global pointers to special symbols */ -+ sc->LAMBDA = 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 [<file1> <file2> ...]\n"); -+ printf("followed by\n"); -+ printf(" -1 <file> [<arg1> <arg2> ...]\n"); -+ printf(" -c <Scheme commands> [<arg1> <arg2> ...]\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: -+*/ -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 <stdio.h> -+ -+#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: -+*/ --- -2.1.4 - diff --git a/debian/patches/bootshell0005-bootshell-add-facility-to-load-embedded-scripts.patch b/debian/patches/bootshell0005-bootshell-add-facility-to-load-embedded-scripts.patch deleted file mode 100644 index 32bf8354..00000000 --- a/debian/patches/bootshell0005-bootshell-add-facility-to-load-embedded-scripts.patch +++ /dev/null @@ -1,83 +0,0 @@ -From 208ce325d26d4393bd69e7d491891a25c4f5461a Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Sat, 24 Jan 2015 01:54:52 +0100 -Subject: [PATCH hurd 05/11] bootshell: add facility to load embedded scripts - -* bootshell/scheme.c (scheme_load_mem): New function. ---- - bootshell/scheme-private.h | 3 +++ - bootshell/scheme.c | 40 ++++++++++++++++++++++++++++++++++++++++ - 2 files changed, 43 insertions(+) - -diff --git a/bootshell/scheme-private.h b/bootshell/scheme-private.h -index 3395328..bb4ebd6 100644 ---- a/bootshell/scheme-private.h -+++ b/bootshell/scheme-private.h -@@ -36,6 +36,9 @@ typedef struct port { - char *start; - char *past_the_end; - char *curr; -+#if SHOW_ERROR_LINE -+ const char *name; -+#endif - } string; - } rep; - } port; -diff --git a/bootshell/scheme.c b/bootshell/scheme.c -index 99f9106..bdeb004 100644 ---- a/bootshell/scheme.c -+++ b/bootshell/scheme.c -@@ -2312,6 +2312,18 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) { - snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s); - - str = (const char*)sbuf; -+ } else if (sc->load_stack[sc->file_i].kind & port_string) { -+ const char *start = sc->load_stack[sc->file_i].rep.string.start; -+ const char *curr = sc->load_stack[sc->file_i].rep.string.curr; -+ const char *name = sc->load_stack[sc->file_i].rep.string.name; -+ -+ /* should never happen */ -+ if (!name) name = "<unknown>"; -+ -+ /* we started from 0 */ -+ snprintf(sbuf, STRBUFFSIZE, "(%s offset %i) %s", name, curr-start, s); -+ -+ str = (const char*)sbuf; - } - #endif - -@@ -5049,3 +5061,31 @@ Local variables: - c-file-style: "k&r" - End: - */ -+ -+/* Like scheme_load_string, but does not rely on a terminating zero. */ -+void -+scheme_load_mem (scheme *sc, const char *cmd_start, const char *cmd_end, -+ const char *name) -+{ -+ 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; -+#if SHOW_ERROR_LINE -+ sc->load_stack[0].rep.string.name = name; -+#endif -+ 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; -+ } -+} --- -2.1.4 - diff --git a/debian/patches/bootshell0006-bootshell-improve-error-message.patch b/debian/patches/bootshell0006-bootshell-improve-error-message.patch deleted file mode 100644 index 98a0d8eb..00000000 --- a/debian/patches/bootshell0006-bootshell-improve-error-message.patch +++ /dev/null @@ -1,27 +0,0 @@ -From d8793766206ced492427a9d12abe379fbaad264e 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 06/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 bdeb004..0fe2721 100644 ---- a/bootshell/scheme.c -+++ b/bootshell/scheme.c -@@ -2691,7 +2691,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/bootshell0007-XXX-bootshell.patch b/debian/patches/bootshell0007-XXX-bootshell.patch deleted file mode 100644 index b3e78a2a..00000000 --- a/debian/patches/bootshell0007-XXX-bootshell.patch +++ /dev/null @@ -1,4500 +0,0 @@ -From aba884a4ee96aa2e7a0383490bfd539210b040c5 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 07/11] XXX bootshell - -XXX hack in toplevel Makefile. ---- - Makefile | 1 + - bootshell/Makefile | 73 +++ - bootshell/boot.scm | 214 ++++++++ - bootshell/bootshell.h | 49 ++ - bootshell/bootstrap.scm | 306 ++++++++++++ - bootshell/elf-exec.c | 211 ++++++++ - bootshell/exceptions.c | 92 ++++ - bootshell/exec-startup.c | 182 +++++++ - bootshell/ffi.c | 1215 +++++++++++++++++++++++++++++++++++++++++++++ - bootshell/ffi.h | 170 +++++++ - bootshell/frob-task.c | 131 +++++ - bootshell/fs.c | 111 +++++ - bootshell/fsys.c | 164 ++++++ - bootshell/fsys.h | 28 ++ - bootshell/hurd.scm | 122 +++++ - bootshell/mach.scm | 93 ++++ - bootshell/main.c | 267 ++++++++++ - bootshell/mig-decls.h | 22 + - bootshell/mig-mutate.h | 27 + - bootshell/runsystem.scm | 78 +++ - bootshell/scheme-config.h | 31 ++ - bootshell/startup.c | 508 +++++++++++++++++++ - bootshell/startup.h | 36 ++ - bootshell/utils.c | 118 +++++ - config.make.in | 4 + - configure.ac | 15 + - 26 files changed, 4268 insertions(+) - create mode 100644 bootshell/Makefile - create mode 100644 bootshell/boot.scm - create mode 100644 bootshell/bootshell.h - create mode 100644 bootshell/bootstrap.scm - create mode 100644 bootshell/elf-exec.c - 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/frob-task.c - create mode 100644 bootshell/fs.c - create mode 100644 bootshell/fsys.c - create mode 100644 bootshell/fsys.h - create mode 100644 bootshell/hurd.scm - create mode 100644 bootshell/mach.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/runsystem.scm - create mode 100644 bootshell/scheme-config.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 6544cd2..00d64ff 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/Makefile b/bootshell/Makefile -new file mode 100644 -index 0000000..e2b09e2 ---- /dev/null -+++ b/bootshell/Makefile -@@ -0,0 +1,73 @@ -+# 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 \ -+ mach.scm \ -+ hurd.scm \ -+ boot.scm \ -+ bootstrap.scm \ -+ runsystem.scm \ -+ -+SRCS := \ -+ scheme.c \ -+ main.c \ -+ exceptions.c \ -+ fs.c \ -+ fsys.c \ -+ exec-startup.c \ -+ startup.c \ -+ utils.c \ -+ ffi.c \ -+ hurd.c \ -+ elf-exec.c \ -+ frob-task.c \ -+ -+SERVER_PROTOCOLS := exc exec_startup fs fsys startup -+USER_PROTOCOLS := startup startup_reply -+ -+MIGSTUBS:= $(foreach p,$(SERVER_PROTOCOLS),$(p)Server.o) \ -+ $(foreach p,$(USER_PROTOCOLS),$(p)User.o) -+OBJS := $(SRCS:.c=.o) $(SCRIPTS:.scm=.o) $(MIGSTUBS) -+ -+HURDLIBS:= shouldbeinlibc -+# XXX why doesn't $(libreadline_LIBS) work ??? -+OTHERLIBS:= $(libreadline_LIBS) -lreadline -lhistory -lncurses -ltinfo -lpthread -+CFLAGS += -imacros scheme-config.h -+LDFLAGS += -static -+MIGSFLAGS := -imacros mig-mutate.h -+ -+%.o: %.scm -+ cat <$< >.$@ -+ $(LD) -r --format=binary .$@ -o $@ -+ rm .$@ -+ -+NOWARN := conversion sign-conversion switch unused-function -+CFLAGS := $(filter-out $(foreach flag,$NOWARN,-W$(flag)),$(CFLAGS)) -+ -+# XXX -+CFLAGS += -Wno-sign-conversion -+ -+include ../Makeconf -diff --git a/bootshell/boot.scm b/bootshell/boot.scm -new file mode 100644 -index 0000000..75cc75f ---- /dev/null -+++ b/bootshell/boot.scm -@@ -0,0 +1,214 @@ -+;; Bootshell, a Scheme shell, a flexible multiserver bootstrap solution. -+;; -+;; Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+;; 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. As a crappy workaround, we set! `last-exception' to the -+;; last the exception. -+(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 wrapper. Expects F to return a list with the -+;; first element being the `error_t' value returned by the foreign -+;; function. The error is thrown, or the cdr of the result is -+;; returned. -+(define (ffi-apply name f args) -+ (let ((result (apply f args))) -+ (cond -+ ((not (= (car result) 0)) -+ (let ((args' (open-output-string))) -+ (write (cons (string->symbol name) args) args') -+ (throw (string-append -+ (get-output-string args') ": " (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) -+ (call/cc -+ (lambda (exit) -+ (let loop ((prefix "")) -+ (let ((line (prompt (p prefix)))) -+ (if (and (not (eof-object? line)) (eqv? (string-length line) 0)) -+ (exit (loop prefix))) -+ (if (not (eof-object? line)) -+ (let* ((next (string-append prefix line)) -+ (c (catch (begin (echo "Parse error: " last-exception) -+ (loop prefix)) -+ (read (open-input-string next))))) -+ (if (not (eof-object? c)) -+ (begin -+ (catch (echo "Error: " last-exception) -+ (echo " ===> " (eval c))) -+ (exit (loop "")))) -+ (exit (loop next))))))))) -+ -+(define (prompt-append-prefix prompt prefix) -+ (string-append prompt (if (> (string-length prefix) 0) -+ (string-append prefix "...") -+ "> "))) -+ -+;; Default repl run by the bootshell. -+(define (interactive-repl) -+ (shell (lambda (p) (prompt-append-prefix "(bootshell) " p)))) -+ -+;; Default repl run by `panic'. -+(define (emergency-shell) -+ (shell (lambda (p) (prompt-append-prefix "(emergency-shell) " p)))) -+ -+;; Display a message and run the emergency shell. -+(define (panic . msg) -+ (display "\n\npanic: ") -+ (map display msg) -+ (newline) -+ (emergency-shell)) -+ -+;; XXX -+(define (path->string x) -+ (if (string? x) x (symbol->string x))) -+ -+;; Hurd server bootstrap. -+ -+;; 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. -+")) -+ -+;; 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")) -+ -+;; 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)))) -+ -+;; We store our messages so that we can replay them if we start the -+;; Hurd console which erases the screen. -+(define messages '()) -+(define (log . args) -+ (set! messages (append messages args)) -+ (for-each display args)) -+(define (replay-log) -+ (for-each display messages)) -+ -+(define timeout 1000) ; 1 second -+ -+(define (pause) -+ (if (= 1 boot-pause) (prompt "Press enter to continue..."))) -+ -+;; We're ready. -+(echo version ".") -diff --git a/bootshell/bootshell.h b/bootshell/bootshell.h -new file mode 100644 -index 0000000..fd91ce9 ---- /dev/null -+++ b/bootshell/bootshell.h -@@ -0,0 +1,49 @@ -+/* Bootshell, a Scheme shell, a flexible multiserver bootstrap solution. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#ifndef _HURD_BOOTSHELL_H -+#define _HURD_BOOTSHELL_H -+ -+#include <mach.h> -+ -+extern char **global_argv; -+extern const char *argp_program_version; -+ -+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); -+ -+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); -+ -+#define TRACE error (0, 0, "%s:%d", __FUNCTION__, __LINE__); -+ -+#endif /* _HURD_BOOTSHELL_H */ -diff --git a/bootshell/bootstrap.scm b/bootshell/bootstrap.scm -new file mode 100644 -index 0000000..a521e01 ---- /dev/null -+++ b/bootshell/bootstrap.scm -@@ -0,0 +1,306 @@ -+;; The Hurd server bootstrap. -+;; -+;; Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+;; -+;; The Hurd server bootstrap. -+;; -+ -+(define (run-stage stage) -+ (stage)) -+ -+(define (bootstrap stages) -+ (catch (panic "Hurd bootstrap failed: " (car last-exception) "\n") -+ (log "Hurd server bootstrap: ") -+ (for-each run-stage stages) -+ (log "done.\n")) -+ -+ (shell -+ (lambda (prefix) -+ (prompt-append-prefix -+ (string-append "runsystem@" (hostname) " " (getcwd) " ") prefix)))) -+ -+;; -+;; The stages of the Hurd server bootstrap. -+;; -+ -+(define rootfs-control MACH_PORT_NULL) -+(define console-device "/dev/console") -+ -+(define (first-stage rootfs-device) -+ (set! exec-server-task (task-create mach-task-self 0)) -+ (let -+ ((rootfs-args -+ `("rootfs" -+ ,(make-arg "host-priv-port" rootfs-server-task host-priv) -+ ,(make-arg "device-master-port" rootfs-server-task device-master) -+ ,(make-arg "exec-server-task" rootfs-server-task exec-server-task) -+ "-T" "typed" ,rootfs-device))) -+ (log "rootfs ") -+ (set! rootfs-control (bind-root (resume-translator rootfs-server-task -+ rootfs-args))) -+ (log "/servers/exec ") -+ (task-set-name exec-server-task "/hurd/exec") -+ (task-suspend exec-server-task) -+ (elf-exec exec-server-task -+ `("/lib/ld.so.1" "/hurd/exec" -+ ,(make-arg "device-master-port" exec-server-task device-master))) -+ (bind "/servers/exec" (resume-translator exec-server-task '())))) -+ -+(define (early-startup) -+ (let ((startup-control (mach-port-allocate mach-task-self -+ MACH_PORT_RIGHT_RECEIVE))) -+ (start-handling-early-startup startup-control) -+ (set-active-translator "/servers/startup" 0 0 -+ (make-send-right startup-control)))) -+ -+(define (second-stage) -+ (letport -+ ((proc-task (task-create mach-task-self 0)) -+ (auth-task (task-create mach-task-self 0))) -+ -+ ;; Starting proc and auth is tricky, we need to do it simultaneously. -+ (let ((pc (bootstrap-proc (start-translator proc-task '("/hurd/proc")))) -+ (ac (bootstrap-auth (start-translator auth-task '("/hurd/auth")))) -+ ;; Projections for the cookies returned by bootstrap-*. -+ (:reply car) (:replyPoly cadr) (:server caddr)) -+ (log "proc ") -+ (startup-procinit-reply (:reply pc) (:replyPoly pc) ESUCCESS -+ mach-task-self (:server ac) -+ host-priv device-master) -+ (bind-proc (:server pc)) -+ -+ ;; Declare that these tasks are our children, and fix them up. -+ (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)) -+ -+ ;; Supply the proc server with a standard template. -+ (proc->auth->set-std-execdata! (:server pc) (:server ac)) -+ -+ ;; Neither the kernel nor our bootscript task have command line -+ ;; arguments. Fix that. -+ (frob-task (proc->pid->task (:server pc) 3) -+ '(gnumach huhu lala XXX)) -+ (if (mach-port-valid? bootscript-task) -+ (frob-task bootscript-task '(/hurd/runsystem.scm))) -+ (frob-task mach-task-self '(/hurd/bootshell)) -+ -+ (mach-port-deallocate mach-task-self (:server pc)) -+ (mach-port-deallocate mach-task-self (:server ac))))) -+ -+(define (start-hurd-console) -+ (log "hurd-console ") -+ (throw 'notyet) ;; XXX -+ (run '(/bin/console -+ --driver-path=/usr/lib/hurd/console ;; XXX -+ --driver=current_vcs -+ --driver=vga -+ --driver=pc_kbd --keymap us -+ --driver=pc_mouse --protocol=ps/2 -+ /dev/vcs)) -+ -+ ;; XXX -+ ;(symlink 'tty1 '/dev/console) -+ (set! console-device "/dev/tty1")) -+ -+(define (start-mach-console) -+ (start-active-translator '/dev/console -+ '(/hurd/term /dev/console device console))) -+ -+(define (start-terminal) -+ (catch (begin (log "failed: ") -+ (log last-exception) -+ (start-mach-console)) -+ (start-hurd-console)) -+ -+ (letport ((term (file-name-lookup console-device O_RDWR 0))) -+ (bind-term term)) -+ -+ (if (equal? console-device "/dev/tty1") -+ ;; If we got the Hurd console running, it erased the screen. -+ (replay-log)) -+ -+ ;; If we made it this far, we can use libreadline! -+ (enable-readline)) -+ -+(define (pflocal) -+ (start-active-translator '/servers/socket/1 '(/hurd/pflocal))) -+ -+(define (mach-defpager) -+ (log "mach-defpager ") -+ (run '(/hurd/mach-defpager)) -+ -+ ;; Wait for it to start. -+ (wait-for have-default-memory-manager? 1000000)) -+ -+(define (rootfs-update) -+ (fsys-set-options rootfs-control '("--update") 0)) -+ -+(define (startup-standalone) -+ ;; The standalone startup server watches essential servers, and -+ ;; handles the system shutdown. -+ (start-active-translator '/servers/startup '(/hurd/startup-standalone)) -+ -+ ;; Now that we have startup, register all servers to it. -+ (letport -+ ((startup (file-name-lookup "/servers/startup" 0 0))) -+ (let ((:port car) (:name cdr)) ;; Projections. -+ ;; 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))))) -+ -+(define (boot! init) -+ (run-init `(/sbin/console-run --console ,console-device -- ,init -a))) -+ -+;; -+;; Utility functions. -+;; -+ -+;; 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->mark-exec! child-proc) -+ (proc->mark-important! child-proc) -+ (proc->task->child! proc task)))))) -+ -+;; 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 #o666)) ;; XXX mode 0 should be fine -+ (control (bootstrap-translator prepare-task realnode))) -+ (set-active-translator path 0 0 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))) -+ -+(define (start-active-translator path args) -+ (log (path->string path) " ") -+ (bind path (start-translator (task-create mach-task-self 0) args))) -+ -+;; Start the userspace init daemon. -+(define (run-init argv) -+ (letport ((proc (getproc)) -+ (task (task-create mach-task-self 0)) -+ (child-proc (proc->task->proc proc task))) -+ (proc->task->set-init-task! proc task) -+ (task-set-name task (car argv)) -+ -+ ;; XXX this is roughly what console-run does -+ ;;(tcsetpgrp 0 (proc->task->pid proc task)) -+ ;;(proc->setsid! child-proc) -+ ;;(proc->make-login-coll! child-proc) -+ -+ (proc->mark-exec! child-proc) -+ (proc->mark-important! child-proc) -+ (proc->task->child! child-proc mach-task-self) -+ (_exec (file-name-lookup (car argv) O_EXEC 0) -+ task argv MACH_PORT_NULL) -+ (copy-send-right task))) -+ -+;; -+;; Legacy support. -+;; -+ -+;; 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)) -+ -+(define (traditional-first-stage) -+ (log "rootfs ") -+ (set! rootfs-control (bind-root (resume-translator rootfs-server-task '()))) -+ (log "/servers/exec ") -+ (bind "/servers/exec" (resume-translator exec-server-task '()))) -+ -+;; XXX fix bootstrap -+(define (traditional-boot) -+ (bootstrap (list traditional-first-stage -+ early-startup -+ second-stage -+ start-terminal -+ startup-standalone -+ (lambda () (boot! "/sbin/init"))))) -diff --git a/bootshell/elf-exec.c b/bootshell/elf-exec.c -new file mode 100644 -index 0000000..a61addb ---- /dev/null -+++ b/bootshell/elf-exec.c -@@ -0,0 +1,211 @@ -+/* Load an ELF image into a task without using the exec server. -+ -+ 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <argz.h> -+#include <assert.h> -+#include <elf.h> -+#include <errno.h> -+#include <fcntl.h> -+#include <mach.h> -+#include <mach/machine/vm_param.h> /* For VM_XXX_ADDRESS */ -+#include <stdlib.h> -+#include <string.h> -+#include <sys/ioctl.h> -+#include <sys/mman.h> -+#include <unistd.h> -+ -+#include "ffi.h" -+ -+error_t -+load_image (task_t t, -+ char *file, -+ vm_address_t *addr) -+{ -+ error_t err; -+ int fd; -+ ssize_t count; -+ Elf32_Ehdr hdr; -+ -+ fd = open (file, O_RDONLY, 0); -+ if (fd == -1) -+ return errno; -+ -+ count = read (fd, &hdr, sizeof hdr); -+ if (count != sizeof hdr) -+ return errno; -+ -+ if (*(Elf32_Word *) hdr.e_ident != *(Elf32_Word *) "\177ELF") -+ return EINVAL; // XXX -+ -+ Elf32_Phdr phdrs[hdr.e_phnum], *ph; -+ lseek (fd, hdr.e_phoff, SEEK_SET); -+ read (fd, phdrs, sizeof phdrs); -+ for (ph = phdrs; ph < &phdrs[sizeof phdrs/sizeof phdrs[0]]; ++ph) -+ if (ph->p_type == PT_LOAD) -+ { -+ vm_address_t buf; -+ vm_size_t offs = ph->p_offset & (ph->p_align - 1); -+ vm_size_t bufsz = round_page (ph->p_filesz + offs); -+ -+ buf = (vm_address_t) mmap (0, bufsz, -+ PROT_READ|PROT_WRITE, MAP_ANON, 0, 0); -+ -+ lseek (fd, ph->p_offset, SEEK_SET); -+ read (fd, (void *)(buf + offs), ph->p_filesz); -+ -+ ph->p_memsz = ((ph->p_vaddr + ph->p_memsz + ph->p_align - 1) -+ & ~(ph->p_align - 1)); -+ ph->p_vaddr &= ~(ph->p_align - 1); -+ ph->p_memsz -= ph->p_vaddr; -+ -+ err = vm_allocate (t, (vm_address_t*)&ph->p_vaddr, ph->p_memsz, 0); -+ if (err) -+ return err; -+ -+ err = vm_write (t, ph->p_vaddr, buf, bufsz); -+ if (err) -+ return err; -+ -+ munmap ((caddr_t) buf, bufsz); -+ err = vm_protect (t, ph->p_vaddr, ph->p_memsz, 0, -+ ((ph->p_flags & PF_R) ? VM_PROT_READ : 0) | -+ ((ph->p_flags & PF_W) ? VM_PROT_WRITE : 0) | -+ ((ph->p_flags & PF_X) ? VM_PROT_EXECUTE : 0)); -+ if (err) -+ return err; -+ } -+ -+ *addr = hdr.e_entry; -+ return 0; -+} -+ -+/* XXX refactor this mess */ -+error_t -+boot_script_exec_cmd (mach_port_t task, char *path, int argc, -+ char **argv, char *strings, int stringlen) -+{ -+ error_t err; -+ char *args, *p; -+ int arg_len, i; -+ size_t reg_size; -+ void *arg_pos; -+ vm_offset_t stack_start, stack_end; -+ vm_address_t startpc, str_start; -+ thread_t thread; -+ -+ err = load_image (task, path, &startpc); -+ if (err) -+ return err; -+ -+ arg_len = stringlen + (argc + 2) * sizeof (char *) + sizeof (integer_t); -+ arg_len += 5 * sizeof (int); -+ stack_end = VM_MAX_ADDRESS; -+ stack_start = VM_MAX_ADDRESS - 16 * 1024 * 1024; -+ err = vm_allocate (task, &stack_start, stack_end - stack_start, FALSE); -+ if (err) -+ return err; -+ -+ arg_pos = (void *) ((stack_end - arg_len) & ~(sizeof (natural_t) - 1)); -+ args = mmap (0, stack_end - trunc_page ((vm_offset_t) arg_pos), -+ PROT_READ|PROT_WRITE, MAP_ANON, 0, 0); -+ str_start = ((vm_address_t) arg_pos -+ + (argc + 2) * sizeof (char *) + sizeof (integer_t)); -+ p = args + ((vm_address_t) arg_pos & (vm_page_size - 1)); -+ *(int *) p = argc; -+ p = (void *) p + sizeof (int); -+ for (i = 0; i < argc; i++) -+ { -+ *(char **) p = argv[i] - strings + (char *) str_start; -+ p = (void *) p + sizeof (char *); -+ } -+ *(char **) p = 0; -+ p = (void *) p + sizeof (char *); -+ *(char **) p = 0; -+ p = (void *) p + sizeof (char *); -+ memcpy (p, strings, stringlen); -+ memset (args, 0, (vm_offset_t)arg_pos & (vm_page_size - 1)); -+ err = vm_write (task, trunc_page ((vm_offset_t) arg_pos), (vm_address_t) args, -+ stack_end - trunc_page ((vm_offset_t) arg_pos)); -+ if (err) -+ return err; -+ munmap ((caddr_t) args, -+ stack_end - trunc_page ((vm_offset_t) arg_pos)); -+ -+ err = thread_create (task, &thread); -+ if (err) -+ return err; -+ -+#ifdef i386_THREAD_STATE_COUNT -+ { -+ struct i386_thread_state regs; -+ reg_size = i386_THREAD_STATE_COUNT; -+ thread_get_state (thread, i386_THREAD_STATE, -+ (thread_state_t) ®s, ®_size); -+ regs.eip = (int) startpc; -+ regs.uesp = (int) arg_pos; -+ err = thread_set_state (thread, i386_THREAD_STATE, -+ (thread_state_t) ®s, reg_size); -+ if (err) -+ return err; -+ } -+#else -+# error needs to be ported -+#endif -+ -+ err = thread_resume (thread); -+ if (err) -+ return err; -+ -+ err = mach_port_deallocate (mach_task_self (), thread); -+ assert_perror (err); -+ return 0; -+} -+ -+error_t -+elf_exec (mach_port_t task, char *argz, size_t argz_len) -+{ -+ error_t err; -+ size_t argc; -+ char **argv; -+ -+ argc = argz_count (argz, argz_len); -+ argv = malloc ((argc + 1) * sizeof *argv); -+ if (argv == NULL) -+ return ENOMEM; -+ argz_extract (argz, argz_len, argv); -+ -+ err = boot_script_exec_cmd (task, argz, argc, argv, argz, argz_len); -+ free (argv); -+ return err; -+} -+ -+pointer -+do_elf_exec (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("elf-exec"); -+ SC_ARG (sc, task_t, task, number, args); -+ SC_ARG (sc, pointer, arguments, list, args); -+ SC_ARGS_DONE (sc); -+ char *argz = NULL; -+ size_t argz_len = 0; -+ ffi_list2argz (sc, &argz, &argz_len, arguments); -+ err = elf_exec (task, argz, argz_len); -+ free (argz); -+ SC_RETURN (sc); -+} -diff --git a/bootshell/exceptions.c b/bootshell/exceptions.c -new file mode 100644 -index 0000000..3102369 ---- /dev/null -+++ b/bootshell/exceptions.c -@@ -0,0 +1,92 @@ -+/* Mach exception handling. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <mach.h> -+#include <pthread.h> -+#include <stdio.h> -+ -+#include "bootshell.h" -+ -+// eek #include "exc_S.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; -+ -+ fprintf (stderr, "catch_exception_raise (%d, %d, %d, %d, %d): ", -+ thread, task, exception, code, subcode); -+ -+ if (task == mach_task_self ()) -+ fprintf (stderr, "terminating bootshell. bye.\n"); -+ else -+ fprintf (stderr, "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..026687f ---- /dev/null -+++ b/bootshell/exec-startup.c -@@ -0,0 +1,182 @@ -+/* Handles the exec_startup protocol. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <assert.h> -+#include <hurd.h> -+#include <hurd/paths.h> -+#include <mach.h> -+#include <mach/message.h> -+#include <mach/mig_support.h> -+#include <stdio.h> -+#include <sys/mman.h> -+ -+// 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; -+ -+ 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 = NULL; -+ *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 (), -+ (vm_address_t *)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; -+ -+ 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); -+ 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..3b3088a ---- /dev/null -+++ b/bootshell/ffi.c -@@ -0,0 +1,1215 @@ -+/* Mach, Hurd, and libc primitives for the Scheme environment. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <argz.h> -+#include <assert.h> -+#include <ctype.h> -+#include <device/device.h> -+#include <errno.h> -+#include <error.h> -+#include <fcntl.h> -+#include <hurd.h> -+#include <hurd/fsys.h> -+#include <mach.h> -+#include <mach/gnumach.h> -+#include <sys/reboot.h> -+#include <sys/mman.h> -+#include <string.h> -+#include <unistd.h> -+ -+#if HAVE_LIBREADLINE -+#include <readline/readline.h> -+#include <readline/history.h> -+#endif -+ -+#include "bootshell.h" -+#include "ffi.h" -+ -+#include "fsys.h" -+#include "startup.h" -+ -+static mach_port_t -+copy_send_right (mach_port_t right) -+{ -+ error_t err; -+ if (! MACH_PORT_VALID (right)) -+ return right; -+ -+ err = mach_port_insert_right (mach_task_self (), -+ right, -+ right, -+ MACH_MSG_TYPE_COPY_SEND); -+ if (err) -+ { -+ error (0, err, "mach_port_insert_right"); -+ return MACH_PORT_NULL; -+ } -+ -+ return right; -+} -+ -+ -+pointer -+do_logand (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("logand"); -+ unsigned int acc = ~0; -+ while (args != sc->NIL) -+ { -+ SC_ARG (sc, unsigned int, v, number, args); -+ acc &= v; -+ } -+ SC_RETURN_INT (sc, acc); -+} -+ -+pointer -+do_logior (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("logior"); -+ unsigned int acc = 0; -+ while (args != sc->NIL) -+ { -+ SC_ARG (sc, unsigned int, v, number, args); -+ acc |= v; -+ } -+ SC_RETURN_INT (sc, acc); -+} -+ -+pointer -+do_logxor (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("logxor"); -+ unsigned int acc = 0; -+ while (args != sc->NIL) -+ { -+ SC_ARG (sc, unsigned int, v, number, args); -+ acc ^= v; -+ } -+ SC_RETURN_INT (sc, acc); -+} -+ -+pointer -+do_lognot (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("lognot"); -+ SC_ARG (sc, unsigned int, v, number, args); -+ SC_ARGS_DONE (sc); -+ SC_RETURN_INT (sc, ~v); -+} -+ -+ -+ -+ -+int use_libreadline; -+ -+/* Read a string, and return a pointer to it. Returns NULL on EOF. */ -+char * -+rl_gets (const char *prompt) -+{ -+ static char *line = NULL; -+ free (line); -+ -+#if HAVE_LIBREADLINE -+ if (use_libreadline) -+ { -+ line = readline (prompt); -+ if (line && *line) -+ add_history (line); -+ } -+ else -+#endif -+ { -+ size_t max_size = 0xff; -+ printf ("%s", prompt); -+ fflush (stdout); -+ line = malloc (max_size); -+ if (line != NULL) -+ fgets (line, max_size, stdin); -+ } -+ -+ /* Strip trailing whitespace. */ -+ if (line && strlen (line) > 0) -+ for (char *p = &line[strlen (line) - 1]; isspace (*p); p--) -+ *p = 0; -+ -+ return line; -+} -+ -+pointer -+do_enable_readline (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("enable-readline"); -+ SC_ARGS_DONE (sc); -+ use_libreadline = 1; -+ SC_RETURN (sc); -+} -+ -+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); -+ if (! line) -+ SC_RETURN_POINTER (sc, sc->EOF_OBJ); -+ -+ SC_RETURN_STRING (sc, line); -+} -+ -+#define is_false(p) ((p) == sc->F) -+ -+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_suspend (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("task-suspend"); -+ SC_ARG (sc, task_t, task, number, args); -+ SC_ARGS_DONE (sc); -+ err = task_suspend (task); -+ SC_RETURN (sc); -+} -+ -+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_task_set_name (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("task-terminate"); -+ SC_ARG (sc, task_t, task, number, args); -+ SC_ARG (sc, char *, name, path, args); -+ SC_ARGS_DONE (sc); -+ err = task_set_name (task, name); -+ SC_RETURN (sc); -+} -+ -+pointer -+do_vm_set_default_memory_manager (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("task-terminate"); -+ SC_ARG (sc, mach_port_t, host_priv, number, args); -+ SC_ARG (sc, mach_port_t, defpager, number, args); -+ SC_ARGS_DONE (sc); -+ err = vm_set_default_memory_manager (host_priv, &defpager); -+ SC_RETURN_INT (sc, defpager); -+} -+ -+ -+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, path, 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, path, 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); -+ char *cwd = get_current_dir_name (); -+ if (cwd == NULL) -+ SC_RETURN_ERR (sc, errno); -+ SC_RETURN_STRING (sc, cwd); -+} -+ -+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, path, 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_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); -+ /* XXX intarray */ -+ _hurd_init (0, global_argv, 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. */ -+ err = mach_port_mod_refs (mach_task_self (), -+ procserver, MACH_PORT_RIGHT_SEND, +1); -+ assert_perror (err); -+ _hurd_port_set (&_hurd_ports[INIT_PORT_PROC], procserver); -+ -+ /* When we called _hurd_init, the proc server wasn't around. */ -+ _hurd_new_proc_init (global_argv, NULL, 0); /* XXX intarray */ -+ 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 server port. */ -+ _hurd_port_set (&_hurd_ports[INIT_PORT_AUTH], authserver); -+ portarray_template[INIT_PORT_AUTH] = authserver; -+ err = mach_port_mod_refs (mach_task_self (), -+ authserver, MACH_PORT_RIGHT_SEND, +2); -+ assert_perror (err); -+ SC_RETURN (sc); -+} -+ -+pointer -+do_bind_term (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("bind-term"); -+ SC_ARG (sc, mach_port_t, term, number, args); -+ SC_ARGS_DONE (sc); -+ int new_fd0, new_fd1, new_fd2; -+ FILE *new_stdin, *new_stdout, *new_stderr; -+ -+ new_fd0 = openport (copy_send_right (term), O_RDONLY); -+ if (new_fd0 < 0) -+ SC_RETURN_ERR (sc, errno); -+ -+ new_fd1 = openport (copy_send_right (term), O_WRONLY); -+ if (new_fd1 < 0) -+ SC_RETURN_ERR (sc, errno); -+ -+ new_fd2 = openport (copy_send_right (term), O_WRONLY); -+ if (new_fd2 < 0) -+ SC_RETURN_ERR (sc, errno); -+ -+ dup2 (new_fd0, 0); -+ close (new_fd0); -+ dup2 (new_fd1, 1); -+ close (new_fd1); -+ dup2 (new_fd2, 2); -+ close (new_fd2); -+ -+ // XXX proper error handling, restore all state on error -+ -+ new_stdin = fdopen (0, "r"); -+ if (new_stdin == NULL) -+ SC_RETURN_ERR (sc, errno); -+ -+ new_stdout = fdopen (1, "w"); -+ if (new_stdout == NULL) -+ SC_RETURN_ERR (sc, errno); -+ -+ new_stderr = fdopen (2, "w"); -+ if (new_stderr == NULL) -+ SC_RETURN_ERR (sc, errno); -+ -+ fclose (stdin); -+ fclose (stdout); -+ fclose (stderr); -+ stdin = new_stdin; -+ stdout = new_stdout; -+ stderr = new_stderr; -+ -+ scheme_set_input_port_file (sc, stdin); -+ scheme_set_output_port_file (sc, stdout); -+ -+ 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_task2pid (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("proc-task2pid"); -+ SC_ARG (sc, mach_port_t, proc, number, args); -+ SC_ARG (sc, task_t, task, number, args); -+ SC_ARGS_DONE (sc); -+ pid_t pid; -+ err = proc_task2pid (proc, task, &pid); -+ SC_RETURN_INT (sc, pid); -+} -+ -+pointer -+do_proc_pid2task (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("proc-pid2task"); -+ SC_ARG (sc, mach_port_t, proc, number, args); -+ SC_ARG (sc, pid_t, pid, number, args); -+ SC_ARGS_DONE (sc); -+ task_t task; -+ err = proc_pid2task (proc, pid, &task); -+ SC_RETURN_INT (sc, task); -+} -+ -+pointer -+do_proc_wait (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("proc-wait"); -+ SC_ARG (sc, process_t, proc, number, args); -+ SC_ARG (sc, pid_t, pid, number, args); -+ SC_ARG (sc, int, options, number, args); -+ SC_ARGS_DONE (sc); -+ int status, sigcode; -+ rusage_t rusage; // XXX -+ pid_t pid_status; -+ err = proc_wait (proc, pid, options, -+ &status, &sigcode, &rusage, &pid_status); -+#define IMC(A, B) _cons (sc, sc->vptr->mk_integer (sc, A), (B), 1) -+ SC_RETURN_POINTER (sc, IMC (status, -+ IMC (sigcode, -+ IMC (pid_status, sc->NIL)))); -+#undef IMC -+} -+ -+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); -+} -+ -+/* Set up the initial value of the standard exec data. */ -+/* XXX: Provide primitives and implement in Scheme. */ -+pointer -+do_proc_auth_set_std_execdata (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("proc->auth->set-std-execdata!"); -+ SC_ARG (sc, process_t, proc, number, args); -+ SC_ARG (sc, auth_t, auth, number, args); -+ SC_ARGS_DONE (sc); -+ -+ auth_t nullauth; -+ mach_port_t pt; -+ mach_port_t ref; -+ mach_port_t *std_port_array; -+ int *std_int_array; -+ int i; -+ -+ std_port_array = alloca (sizeof (mach_port_t) * INIT_PORT_MAX); -+ memset (std_port_array, 0, sizeof(mach_port_t) * INIT_PORT_MAX); -+ std_int_array = alloca (sizeof (int) * INIT_INT_MAX); -+ memset (std_int_array, 0, sizeof(int) * INIT_INT_MAX); -+ -+ err = auth_makeauth (auth, -+ NULL, MACH_MSG_TYPE_COPY_SEND, 0, -+ NULL, 0, -+ NULL, 0, -+ NULL, 0, -+ NULL, 0, -+ &nullauth); -+ if (err) -+ goto out; -+ -+ /* MAKE_SEND is safe in these transactions because we destroy REF -+ ourselves each time. */ -+ pt = getcwdir (); -+ ref = mach_reply_port (); -+ err = io_reauthenticate (pt, ref, MACH_MSG_TYPE_MAKE_SEND); -+ if (err) -+ goto out; -+ -+ err = auth_user_authenticate (nullauth, ref, MACH_MSG_TYPE_MAKE_SEND, -+ &std_port_array[INIT_PORT_CWDIR]); -+ if (err) -+ goto out; -+ -+ mach_port_destroy (mach_task_self (), ref); -+ mach_port_deallocate (mach_task_self (), pt); -+ -+ pt = getcrdir (); -+ ref = mach_reply_port (); -+ err = io_reauthenticate (pt, ref, MACH_MSG_TYPE_MAKE_SEND); -+ if (err) -+ goto out; -+ -+ err = auth_user_authenticate (nullauth, ref, MACH_MSG_TYPE_MAKE_SEND, -+ &std_port_array[INIT_PORT_CRDIR]); -+ if (err) -+ goto out; -+ -+ mach_port_destroy (mach_task_self (), ref); -+ mach_port_deallocate (mach_task_self (), pt); -+ -+ std_port_array[INIT_PORT_AUTH] = nullauth; -+ std_int_array[INIT_UMASK] = CMASK; -+ -+ err = proc_setexecdata (proc, std_port_array, -+ MACH_MSG_TYPE_COPY_SEND, INIT_PORT_MAX, -+ std_int_array, INIT_INT_MAX); -+ -+ out: -+ for (i = 0; i < INIT_PORT_MAX; i++) -+ if (MACH_PORT_VALID (std_port_array[i])) -+ { -+ error_t err; -+ err = mach_port_deallocate (mach_task_self (), std_port_array[i]); -+ assert_perror (err); -+ } -+ SC_RETURN (sc); -+} -+ -+pointer -+do_proc_make_login_coll (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("proc->make-login-coll!"); -+ SC_ARG (sc, process_t, proc, number, args); -+ SC_ARGS_DONE (sc); -+ err = proc_make_login_coll (proc); -+ SC_RETURN (sc); -+} -+ -+pointer -+do_proc_setsid (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("proc->setsid!"); -+ SC_ARG (sc, process_t, proc, number, args); -+ SC_ARGS_DONE (sc); -+ err = proc_setsid (proc); -+ SC_RETURN (sc); -+} -+ -+pointer -+do_tcsetpgrp (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("tcsetpgrp"); -+ SC_ARG (sc, int, fd, number, args); -+ SC_ARG (sc, pid_t, pgrp, number, args); -+ SC_ARGS_DONE (sc); -+ tcsetpgrp (fd, pgrp); -+ 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) -+{ -+ for (; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list)) -+ { -+ char *v; -+ if (sc->vptr->is_string (sc->vptr->pair_car (list))) -+ v = sc->vptr->string_value (sc->vptr->pair_car (list)); -+ else if (sc->vptr->is_symbol (sc->vptr->pair_car (list))) -+ v = sc->vptr->symname (sc->vptr->pair_car (list)); -+ else -+ continue; // XXX this just silently drops values -+ argz_add (argz, argz_len, v); -+ } -+} -+ -+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, pointer, arguments, list, args); -+ char *argz = NULL; -+ size_t argz_len = 0; -+ ffi_list2argz (sc, &argz, &argz_len, arguments); -+ 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); -+} -+ -+// 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); -+ mach_port_deallocate (mach_task_self (), 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); -+ for (i = 0; i < INIT_PORT_MAX; i++) -+ copy_send_right (portarray[i]); -+ -+ portarray[INIT_PORT_CWDIR] = getcwdir (); -+ portarray[INIT_PORT_CRDIR] = getcrdir (); -+ portarray[INIT_PORT_PROC] = child_proc; -+ portarray[INIT_PORT_BOOTSTRAP] = copy_send_right (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, STDERR_FILENO+1, -+ portarray, MACH_MSG_TYPE_COPY_SEND, INIT_PORT_MAX, -+ default_ints, INIT_INT_MAX, -+ NULL, 0, NULL, 0); -+ -+ 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_INT (sc, task); -+} -+ -+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) -+{ -+ char *version; -+ asprintf (&version, "%s/%s", argp_program_version, "TinyScheme 1.41"); -+ define_ (sc, "version", mk_string (sc, version)); -+ free (version); -+ -+ /* bitwise arithmetic */ -+ define_function (sc, "logand", logand); -+ define_function (sc, "logior", logior); -+ define_function (sc, "logxor", logxor); -+ define_function (sc, "lognot", lognot); -+ -+ /* Mach stuff. */ -+ 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_function (sc, "mach-port-allocate", mach_port_allocate); -+ define_function (sc, "mach-port-deallocate", mach_port_deallocate); -+ define_function (sc, "mach-port-destroy", mach_port_destroy); -+ //define_function (sc, "mach-port-get-refs", mach_port_get_refs); -+ //define_function (sc, "mach-port-mod-refs", mach_port_mod_refs); -+ define_function (sc, "mach-port-insert-right", mach_port_insert_right); -+ //define_function (sc, "mach-port-extract-right", mach_port_extract_right); -+ -+ define_function (sc, "task-create", task_create); -+ define_function (sc, "task-suspend", task_suspend); -+ define_function (sc, "task-resume", task_resume); -+ define_function (sc, "task-terminate", task_terminate); -+ define_function (sc, "task-set-name", task_set_name); -+ define_function (sc, "task-get-special-port", task_get_special_port); -+ define_function (sc, "task-set-special-port", task_set_special_port); -+ define_function (sc, "host-reboot", host_reboot); -+ -+ define_function (sc, "vm-set-default-memory-manager", -+ vm_set_default_memory_manager); -+ -+ /* Device protocol. */ -+ define_constant (sc, D_READ); -+ define_constant (sc, D_WRITE); -+ define_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); -+ -+ /* glibc. */ -+ define_function (sc, "sleep", sleep); -+ define_function (sc, "usleep", usleep); -+ define_function (sc, "getcwd", getcwd); -+ define_function (sc, "chdir", chdir); -+ define_function (sc, "strerror", strerror); -+ define_function (sc, "getproc", getproc); -+ -+ /* Boot process */ -+ define_function (sc, "bind-root", bind_root); -+ define_function (sc, "bind-proc", bind_proc); -+ define_function (sc, "bind-auth", bind_auth); -+ define_function (sc, "bind-term", bind_term); -+ define_function (sc, "fsys-init", fsys_init); -+ -+ /* Early bootstrap protocols. */ -+ define_function (sc, "handle-startup-procinit", handle_startup_procinit); -+ define_function (sc, "handle-startup-authinit", handle_startup_authinit); -+ define_function (sc, "startup-procinit-reply", startup_procinit_reply); -+ define_function (sc, "startup-authinit-reply", startup_authinit_reply); -+ -+ define_function (sc, "startup-essential-task", startup_essential_task); -+ define_function (sc, "startup-request-notification", -+ startup_request_notification); -+ define_function (sc, "startup-reboot", startup_reboot); -+ -+ /* Process and translator startup. */ -+ define_function (sc, "handle-exec-startup", handle_exec_startup); -+ define_function (sc, "handle-fsys-startup", handle_fsys_startup); -+ -+ /* Hurd fsys protocol. */ -+ define_function (sc, "fsys-set-options", fsys_set_options); -+ define_function (sc, "fsys-get-options", fsys_get_options); -+ -+ /* Hurd fs API */ -+ define_function (sc, "file-name-lookup", file_name_lookup); -+ define_function (sc, "file-set-translator", file_set_translator); -+ define_function (sc, "file-get-fs-options", file_get_fs_options); -+ -+ /* Hurd process API */ -+ define_function (sc, "proc-wait!", proc_wait); -+ define_function (sc, "proc->task->proc", proc_task2proc); -+ define_function (sc, "proc->task->pid", proc_task2pid); -+ define_function (sc, "proc->pid->task", proc_pid2task); -+ define_function (sc, "proc->mark-important!", proc_mark_important); -+ define_function (sc, "proc->mark-exec!", proc_mark_exec); -+ define_function (sc, "proc->task->child!", proc_child); -+ define_function (sc, "proc->task->set-init-task!", proc_set_init_task); -+ define_function (sc, "proc->make-login-coll!", proc_make_login_coll); -+ define_function (sc, "proc->setsid!", proc_setsid); -+ -+ /* Terminal magic. */ -+ define_function (sc, "tcsetpgrp", tcsetpgrp); -+ -+ /* Hurd hacks. */ -+ define_function (sc, "frob-task", frob_task); -+ define_function (sc, "elf-exec", elf_exec); -+ define_function (sc, "_exec", _exec); -+ define_function (sc, "start-handling-early-startup", -+ start_handling_early_startup); -+ define_function (sc, "get-essential-tasks", get_essential_tasks); -+ define_function (sc, "get-registered-tasks", get_registered_tasks); -+ define_function (sc, "proc->auth->set-std-execdata!", -+ proc_auth_set_std_execdata); -+ -+ /* User interface. */ -+ define_function (sc, "enable-readline", enable_readline); -+ define_function (sc, "prompt", prompt); -+ -+ /* XXX */ -+ ffi_update (sc); -+} -diff --git a/bootshell/ffi.h b/bootshell/ffi.h -new file mode 100644 -index 0000000..f5d0ac6 ---- /dev/null -+++ b/bootshell/ffi.h -@@ -0,0 +1,170 @@ -+/* Convenience functions and macros for the foreign function interface. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#ifndef _HURD_BOOTSHELL_FFI_H -+#define _HURD_BOOTSHELL_FFI_H -+ -+#include <mach.h> -+#include <mach/message.h> -+ -+#include "scheme.h" -+#include "scheme-private.h" -+ -+// XXX drop name -+#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(SC, X) ivalue -+#define CONVERSION_string(SC, X) string_value -+#define CONVERSION_list(SC, X) -+#define CONVERSION_path(SC, X) ((SC)->vptr->is_string (X) \ -+ ? (SC)->vptr->string_value \ -+ : (SC)->vptr->symname) -+ -+#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 IS_A_path(SC, X) ((SC)->vptr->is_string (X) \ -+ || (SC)->vptr->is_symbol (X)) -+ -+// XXX proper error handling -+#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 (SC, pair_car (ARGS)) (pair_car (ARGS)); \ -+ ARGS = pair_cdr (ARGS); \ -+ __ffi_arg_index += 1; \ -+ -+#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))) -+ -+const char *schemify_name (const char *s, int macro); -+ -+#define define_function(S, P, F) \ -+ ({ \ -+ char _sc_buf[256]; \ -+ scheme_define ((S), \ -+ (S)->global_env, \ -+ mk_symbol ((S), schemify_name ("_" #F, 0)), \ -+ mk_foreign_func ((S), (do_##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 *, const char *); -+ -+#define declare_embedded_script(X) \ -+ 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) \ -+ ({ \ -+ scheme_load_mem ((S), X##_start, X##_end, #X); \ -+ if ((S)->retcode != 0) \ -+ fprintf (stderr, "Errors encountered evaluating %s\n", #X); \ -+ }) -+ -+declare_embedded_script (init); -+declare_embedded_script (mach); -+declare_embedded_script (hurd); -+declare_embedded_script (boot); -+declare_embedded_script (bootstrap); -+declare_embedded_script (runsystem); -+ -+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); -+ -+/* elf-exec.c */ -+pointer do_elf_exec (scheme *sc, pointer args); -+ -+/* fsys.c */ -+pointer do_handle_fsys_startup (scheme *sc, pointer args); -+ -+/* frob_task.c */ -+pointer do_frob_task (scheme *sc, pointer args); -+ -+#endif /* _HURD_BOOTSHELL_FFI_H */ -diff --git a/bootshell/frob-task.c b/bootshell/frob-task.c -new file mode 100644 -index 0000000..05d0238 ---- /dev/null -+++ b/bootshell/frob-task.c -@@ -0,0 +1,131 @@ -+/* Supply a task (e.g. the kernel) with the command line arguments. -+ -+ 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <argz.h> -+#include <assert.h> -+#include <errno.h> -+#include <error.h> -+#include <hurd.h> -+#include <mach.h> -+#include <pids.h> -+#include <string.h> -+#include <sys/mman.h> -+#include <sys/types.h> -+#include <unistd.h> -+ -+#include "ffi.h" -+ -+/* Frobnicate the given TASK and the proc server's idea of it, so the -+ command line can be read as for a normal Hurd process. */ -+error_t -+frob_task (task_t kernel_task, const char *argz, size_t argz_len) -+{ -+ error_t err; -+ process_t proc, kernel_proc = MACH_PORT_NULL; -+ -+ int argc, i; -+ const char *entry; -+ size_t windowsz; -+ vm_address_t mine, his; -+ -+ proc = getproc (); -+ if (! MACH_PORT_VALID (proc)) -+ return EINVAL; -+ -+ err = proc_task2proc (proc, kernel_task, &kernel_proc); -+ if (err) -+ goto out; -+ -+ /* Mark the kernel task as an essential task so that we or the proc server -+ never want to task_terminate it. */ -+ err = proc_mark_important (kernel_proc); -+ if (err) -+ goto out; -+ -+ /* Our arguments make up the multiboot command line used to boot the -+ kernel. We'll write into the kernel task a page containing a -+ canonical argv array and argz of those words. */ -+ -+ argc = argz_count (argz, argz_len); -+ -+ windowsz = round_page (((argc + 1) * sizeof (char *)) + argz_len); -+ -+ mine = (vm_address_t) mmap (0, windowsz, PROT_READ|PROT_WRITE, -+ MAP_ANON, 0, 0); -+ if (mine == (vm_address_t) -1) -+ { -+ err = errno; -+ goto out; -+ } -+ -+ err = vm_allocate (kernel_task, &his, windowsz, 1); -+ if (err) -+ { -+ error (0, err, "cannot allocate %Zu bytes in kernel task", windowsz); -+ munmap ((caddr_t) mine, windowsz); -+ goto out; -+ } -+ -+ for (i = 0, entry = argz; entry != NULL; -+ ++i, entry = argz_next (argz, argz_len, entry)) -+ ((char **) mine)[i] = ((char *) &((char **) his)[argc + 1] -+ + (entry - argz)); -+ ((char **) mine)[argc] = NULL; -+ memcpy (&((char **) mine)[argc + 1], argz, argz_len); -+ -+ /* We have the data all set up in our copy, now just write it over. */ -+ err = vm_write (kernel_task, his, mine, windowsz); -+ munmap ((caddr_t) mine, windowsz); -+ if (err) -+ goto out; -+ -+ /* The argument vector is set up in the kernel task at address HIS. -+ Finally, we can inform the proc server where to find it. */ -+ err = proc_set_arg_locations (kernel_proc, -+ his, his + (argc * sizeof (char *))); -+ if (err) -+ error (0, err, "proc_set_arg_locations for kernel task"); -+ -+ out: -+ { -+ error_t e; -+ e = mach_port_deallocate (mach_task_self (), proc); -+ assert_perror (e); -+ -+ if (MACH_PORT_VALID (kernel_proc)) -+ e = mach_port_deallocate (mach_task_self (), kernel_proc); -+ assert_perror (e); -+ } -+ return err; -+} -+ -+pointer -+do_frob_task (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("frob-task"); -+ SC_ARG (sc, task_t, task, number, args); -+ SC_ARG (sc, pointer, arguments, list, args); -+ SC_ARGS_DONE (sc); -+ char *argz = NULL; -+ size_t argz_len = 0; -+ ffi_list2argz (sc, &argz, &argz_len, arguments); -+ err = frob_task (task, argz, argz_len); -+ free (argz); -+ SC_RETURN (sc); -+} -diff --git a/bootshell/fs.c b/bootshell/fs.c -new file mode 100644 -index 0000000..88536d8 ---- /dev/null -+++ b/bootshell/fs.c -@@ -0,0 +1,111 @@ -+/* Handles the fs protocol. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <assert.h> -+#include <hurd.h> -+#include <mach.h> -+#include <mach/message.h> -+#include <pthread.h> -+#include <stdio.h> -+ -+// 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; -+ } -+ -+ // XXX specialized demuxer -+ 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..5383e7f ---- /dev/null -+++ b/bootshell/fsys.c -@@ -0,0 +1,164 @@ -+/* Handles the fsys protocol. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <assert.h> -+#include <errno.h> -+#include <error.h> -+#include <hurd.h> -+#include <mach.h> -+#include <mach/message.h> -+#include <mach/mig_support.h> -+#include <stdio.h> -+ -+/* fsys client support. */ -+#include <hurd.h> -+#include <hurd/fsys.h> -+ -+#include "ffi.h" -+ -+pointer -+do_fsys_set_options (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("fsys-set-options"); -+ SC_ARG (sc, fsys_t, control, number, args); -+ char *options = NULL; -+ size_t options_len = 0; -+ SC_ARG (sc, pointer, arguments, list, args); -+ ffi_list2argz (sc, &options, &options_len, arguments); -+ SC_ARG (sc, int, do_children, number, args); -+ SC_ARGS_DONE (sc); -+ err = fsys_set_options (control, options, options_len, do_children); -+ SC_RETURN (sc); -+} -+ -+pointer -+do_fsys_get_options (scheme *sc, pointer args) -+{ -+ SC_FFI_PROLOG ("fsys_get_options"); -+ SC_ARG (sc, fsys_t, control, number, args); -+ SC_ARGS_DONE (sc); -+ char *options = NULL; -+ size_t options_len = 0; -+ pointer result; -+ err = fsys_get_options (control, &options, &options_len); -+ if (err) -+ SC_RETURN (sc); -+ result = ffi_argz2list (sc, options, options_len, NULL); -+ vm_deallocate (mach_task_self (), (vm_address_t) options, options_len); -+ SC_RETURN_POINTER (sc, result); -+} -+ -+/* Partial fsys server support. */ -+// 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; -+ 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; -+} -+ -+static boolean_t -+fsys_startup_demuxer (mach_msg_header_t *request, -+ mach_msg_header_t *reply) -+{ -+ // XXX -+ extern boolean_t fsys_server (mach_msg_header_t *, mach_msg_header_t *); -+ -+ switch (request->msgh_id) -+ { -+ case 22000: /* fsys_startup */ -+ return fsys_server (request, reply); -+ } -+ -+ /* Return MIG_BAD_ID. */ -+ mig_reply_setup (request, reply); -+ return FALSE; -+} -+ -+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; -+ -+ 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_startup_demuxer, 0, bootstrap, -+ MACH_RCV_TIMEOUT | MACH_SEND_TIMEOUT, -+ timeout); -+ if (err != MACH_MSG_SUCCESS) -+ return err; -+ -+ *control = fsys_startup_args.control_port; -+ return 0; -+} -+ -+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 = MACH_PORT_NULL; -+ err = service_fsys_request (bootstrap, -+ realnode, -+ realnodePoly, -+ timeout, -+ &control); -+ SC_RETURN_INT (sc, control); -+} -diff --git a/bootshell/fsys.h b/bootshell/fsys.h -new file mode 100644 -index 0000000..d6f2ea7 ---- /dev/null -+++ b/bootshell/fsys.h -@@ -0,0 +1,28 @@ -+/* Handles the fsys protocol. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#ifndef _HURD_BOOTSHELL_FSYS_H -+#define _HURD_BOOTSHELL_FSYS_H -+ -+#include "ffi.h" -+ -+pointer do_fsys_set_options (scheme *sc, pointer args); -+pointer do_fsys_get_options (scheme *sc, pointer args); -+ -+#endif /* _HURD_BOOTSHELL_FSYS_H */ -diff --git a/bootshell/hurd.scm b/bootshell/hurd.scm -new file mode 100644 -index 0000000..46cbfe3 ---- /dev/null -+++ b/bootshell/hurd.scm -@@ -0,0 +1,122 @@ -+;; The Hurd interface. -+;; -+;; Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+(define (touch path) -+ (letport ((p (file-name-lookup path O_CREAT #o666))))) ;; XXX mode ? -+ -+(define (chown path owner) #f) ;;XXX -+ -+(define (st path owner mode translator . args) -+ (if (not (null? args)) -+ (for-each display args)) -+ (set-passive-translator path O_CREAT mode translator) -+ (chown path owner)) -+ -+(define (tty n) -+ (let ((path (string-append "/dev/tty" (number->string n)))) -+ (st path 'root #o600 -+ `(/hurd/term -+ ,path hurdio -+ ,(string-append "/dev/vcs/" (number->string n) "/console"))))) -+ -+(define (have-default-memory-manager?) -+ (letport ((p (vm-set-default-memory-manager host-priv -+ MACH_PORT_NULL))) -+ (mach-port-valid? p))) -+ -+ -+(define (path->string x) -+ (if (string? x) x (symbol->string x))) -+ -+(define (start-active-translator path args) -+ (log (path->string path) " ") -+ (bind path (start-translator (task-create mach-task-self 0) args))) -+ -+(define (make-essential-devices) -+ (log "mach-defpager ") -+ (run '(/hurd/mach-defpager)) -+ -+ (start-active-translator '/proc '(/hurd/procfs --compatible)) -+ (start-active-translator '/servers/socket/1 '(/hurd/pflocal)) -+ (start-active-translator '/servers/password '(/hurd/password)) -+ -+ ;; We need the default pager before starting proxy-defpager. -+ (wait-for have-default-memory-manager? 1000000) -+ -+ (start-active-translator '/servers/default-pager '(/hurd/proxy-defpager)) -+ (start-active-translator '/dev '(/hurd/tmpfs 5M)) -+ (start-active-translator '/run '(/hurd/tmpfs 15M)) -+ (start-active-translator '/root '(/hurd/tmpfs 5M)) -+ (start-active-translator '/tmp '(/hurd/tmpfs 15M)) -+ (start-active-translator '/home '(/hurd/tmpfs 20%)) ;; XXX 20% -+ -+ (st '/dev/time 'root #o644 '(/hurd/storeio --no-cache time)) -+ (st '/dev/mem 'root #o660 '(/hurd/storeio --no-cache mem)) -+ (st '/dev/vcs 'root #o600 '(/hurd/console)) -+ (touch '/dev/console) -+ -+ (map tty '(1 2 3 4 5 6)) -+ -+ (st '/dev/fd 'root #o666 '(/hurd/magic --directory fd)) -+ (symlink 'fd/0 '/dev/stdin) -+ (symlink 'fd/1 '/dev/stdout) -+ (symlink 'fd/2 '/dev/stderr)) -+ -+(define (symlink target linkpath) -+ (st linkpath 'root #o644 `(/hurd/symlink ,target))) -+ -+(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) -+ (catch (reboot-mach) -+ (reboot-hurd))) -+(define (halt) -+ (catch (halt-mach) -+ (halt-hurd))) -+ -+(define ESUCCESS 0) ; -+ -+;; translator linkage -+ -+(define (set-passive-translator path flags mode args) -+ (letport ((node (file-name-lookup path (logior O_NOTRANS flags) mode))) -+ (file-set-translator node FS_TRANS_SET 0 0 args -+ MACH_PORT_NULL MACH_MSG_TYPE_COPY_SEND))) -+ -+(define (set-active-translator path flags mode active-control) -+ (letport ((node (file-name-lookup path (logior O_NOTRANS flags) mode))) -+ (file-set-translator node 0 FS_TRANS_SET 0 '() -+ active-control MACH_MSG_TYPE_COPY_SEND))) -+(define (run argv) -+ (letport ((proc (getproc)) -+ (task (task-create mach-task-self 0)) -+ (child-proc (proc->task->proc proc task))) -+ (task-set-name task (car argv)) -+ (_exec (file-name-lookup (car argv) O_EXEC 0) -+ task argv MACH_PORT_NULL) -+ (proc->mark-exec! child-proc) -+ (proc->mark-important! child-proc) -+ (proc->task->child! proc task) -+ (copy-send-right task))) -diff --git a/bootshell/mach.scm b/bootshell/mach.scm -new file mode 100644 -index 0000000..3dd98ac ---- /dev/null -+++ b/bootshell/mach.scm -@@ -0,0 +1,93 @@ -+;; The Mach interface. -+;; -+;; Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+;; 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 ...)))) -+ -+;; Mach 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)) -+ -+;; Mach task interface. -+(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)) -+ -+;; Mach host interface. -+(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)) -+ -+;; Default memory manager interface. -+(define (have-default-memory-manager?) -+ (letport ((p (vm-set-default-memory-manager host-priv -+ MACH_PORT_NULL))) -+ (mach-port-valid? p))) -+ -+;; 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))) -+ -diff --git a/bootshell/main.c b/bootshell/main.c -new file mode 100644 -index 0000000..54685a7 ---- /dev/null -+++ b/bootshell/main.c -@@ -0,0 +1,267 @@ -+/* Bootshell, a Scheme shell, a flexible multiserver bootstrap solution. -+ -+ Copyright (C) 1995-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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <argp.h> -+#include <assert.h> -+#include <ctype.h> -+#include <stdarg.h> -+#include <stdio.h> -+#include <stdlib.h> -+#include <unistd.h> -+#include <error.h> -+#include <hurd.h> -+#include <hurd/fshelp.h> -+#include <device/device.h> -+#include <version.h> -+ -+#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) -+{ -+ puts (msg); -+ fflush (stdout); -+ _exit (127); -+} -+ -+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); -+ global_argv = argv; /* For calling _hurd_new_proc_init later. */ -+ -+ { -+ 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); -+ load_embedded_script (&scm, mach); -+ load_embedded_script (&scm, hurd); -+ load_embedded_script (&scm, boot); -+ load_embedded_script (&scm, bootstrap); -+ load_embedded_script (&scm, runsystem); -+ -+ 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, "external bootscript"); -+ 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..76a67ff ---- /dev/null -+++ b/bootshell/mig-decls.h -@@ -0,0 +1,22 @@ -+/* MIG declarations for bootshell. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <hurd.h> -+ -+#define MIG_EOPNOTSUPP ({ abort (); EOPNOTSUPP; }) -diff --git a/bootshell/mig-mutate.h b/bootshell/mig-mutate.h -new file mode 100644 -index 0000000..145e83a ---- /dev/null -+++ b/bootshell/mig-mutate.h -@@ -0,0 +1,27 @@ -+/* MIG mutations for bootshell. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#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/runsystem.scm b/bootshell/runsystem.scm -new file mode 100644 -index 0000000..86b8c16 ---- /dev/null -+++ b/bootshell/runsystem.scm -@@ -0,0 +1,78 @@ -+;; The Hurd server bootstrap. -+;; -+;; Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+(define (string-index haystack delimiter) -+ (define (index i haystack delimiter) -+ (if (= (length haystack) 0) -+ #f -+ (if (char=? (car haystack) delimiter) -+ i -+ (index (+ i 1) (cdr haystack) delimiter)))) -+ (index 0 (string->list haystack) delimiter)) -+ -+(define (string-splitn haystack delimiter n) -+ (define (split acc haystack delimiter n) -+ (if (= (string-length haystack) 0) -+ (reverse acc) -+ (let ((i (string-index haystack delimiter))) -+ (if (not (or (eq? i #f) (= 0 n))) -+ (split (cons (substring haystack 0 i) acc) -+ (substring haystack (+ i 1) (string-length haystack)) -+ delimiter (- n 1)) -+ (split (cons haystack acc) "" delimiter 0) -+ )))) -+ (split '() haystack delimiter n)) -+ -+(define (string-split haystack delimiter) -+ (string-splitn haystack delimiter -1)) -+ -+(define (parse-cmdline c) -+ (define (parse args kwargs l) -+ (if (= (length l) 0) -+ (cons (reverse args) kwargs) -+ (let ((kv (string-splitn (car l) #\= 1))) -+ (if (= (length kv) 1) -+ (parse (cons (car kv) args) kwargs (cdr l)) -+ (parse args (cons (cons (car kv) (cadr kv)) kwargs) (cdr l)))))) -+ (parse '() '() (string-split c #\ ))) -+ -+(define (boot) -+ (let* ((arguments (parse-cmdline multiboot-command-line)) -+ (:flag (lambda (key) (member key (car arguments)))) -+ (:kwarg (lambda (key default) -+ (let ((value (assoc key (cdr arguments)))) -+ (if (equal? value #f) -+ (default) -+ (cdr value))))) -+ (init (:kwarg "init" (lambda () "/sbin/init")))) -+ -+ (bootstrap (list -+ (lambda () (first-stage (:kwarg "root" (lambda () "xxx")))) -+ early-startup -+ second-stage -+ start-terminal -+ startup-standalone -+ pflocal -+ mach-defpager -+ rootfs-update -+ ;(lambda () (boot! init)) -+ (lambda () -+ (run '(/sbin/console-run --console=/dev/console -- /bin/bash)) -+ (sleep 60)) -+ )))) -diff --git a/bootshell/scheme-config.h b/bootshell/scheme-config.h -new file mode 100644 -index 0000000..127df9f ---- /dev/null -+++ b/bootshell/scheme-config.h -@@ -0,0 +1,31 @@ -+/* TinyScheme configuration. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#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 -+#define SHOW_ERROR_LINE 1 -diff --git a/bootshell/startup.c b/bootshell/startup.c -new file mode 100644 -index 0000000..4b9f71d ---- /dev/null -+++ b/bootshell/startup.c -@@ -0,0 +1,508 @@ -+/* Handles the startup protocol. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <assert.h> -+#include <errno.h> -+#include <error.h> -+#include <hurd.h> -+#include <hurd/startup.h> -+#include <mach.h> -+#include <mach/message.h> -+#include <mach/mig_support.h> -+#include <mach/notify.h> -+#include <pthread.h> -+#include <stdio.h> -+#include <string.h> -+ -+#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 */ -+ switch (request->msgh_id) -+ { -+ case 29000: /* startup_essential_task */ -+ case 29001: /* startup_request_notification */ -+ return startup_server (request, reply); -+ case 22001: /* fsys_goaway */ -+ case 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; -+ -+ 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); -+ 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; -+ -+ 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); -+ 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..0fa9b4c ---- /dev/null -+++ b/bootshell/startup.h -@@ -0,0 +1,36 @@ -+/* Handles the startup protocol. -+ -+ Copyright (C) 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#ifndef _HURD_BOOTSHELL_STARTUP_H -+#define _HURD_BOOTSHELL_STARTUP_H -+ -+#include <ffi.h> -+ -+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); -+ -+#endif /* _HURD_BOOTSHELL_STARTUP_H */ -diff --git a/bootshell/utils.c b/bootshell/utils.c -new file mode 100644 -index 0000000..9fcf17c ---- /dev/null -+++ b/bootshell/utils.c -@@ -0,0 +1,118 @@ -+#include <assert.h> -+#include <hurd.h> -+#include <mach.h> -+#include <mach/message.h> -+#include <stdarg.h> -+#include <stdio.h> -+ -+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) -+{ -+ 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; -+ -+ /* 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 (&reply->Head); -+ -+ return mr != 0 ? mr : reply->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 -+} -diff --git a/config.make.in b/config.make.in -index 0f1390a..012bcd5 100644 ---- a/config.make.in -+++ b/config.make.in -@@ -95,6 +95,10 @@ HAVE_BLKID = @HAVE_BLKID@ - libblkid_CFLAGS = @libblkid_CFLAGS@ - libblkid_LIBS = @libblkid_LIBS@ - -+# How to compile and link against libreadline. -+HAVE_READLINE = @HAVE_READLINE@ -+libreadline_LIBS = @libreadline_LIBS@ -+ - # Whether Sun RPC support is available. - HAVE_SUN_RPC = @HAVE_SUN_RPC@ - -diff --git a/configure.ac b/configure.ac -index 124eb07..819b264 100644 ---- a/configure.ac -+++ b/configure.ac -@@ -341,6 +341,21 @@ PKG_CHECK_MODULES([libblkid], [blkid], - AC_SUBST([libblkid_LIBS]) - AC_SUBST([libblkid_CFLAGS]) - -+AC_ARG_WITH([readline], -+ [AS_HELP_STRING([--without-readline], [disable support for readline])], -+ [], -+ [with_readline=yes]) -+ -+LIBREADLINE= -+AS_IF([test "x$with_readline" != xno], -+ [AC_CHECK_LIB([readline], [main], -+ [AC_SUBST([libreadline_LIBS], ["-lreadline -lhistory -lncurses"]) -+ AC_DEFINE([HAVE_LIBREADLINE], [1], [Define if you have libreadline]) -+ ], -+ [AC_MSG_FAILURE( -+ [readline test failed (--without-readline to disable)])], -+ [-lncurses])]) -+ - AC_CONFIG_FILES([config.make ${makefiles}]) - AC_OUTPUT - --- -2.1.4 - diff --git a/debian/patches/bootshell0008-XXX-proc-fix-build.patch b/debian/patches/bootshell0008-XXX-proc-fix-build.patch deleted file mode 100644 index b9e1e41c..00000000 --- a/debian/patches/bootshell0008-XXX-proc-fix-build.patch +++ /dev/null @@ -1,26 +0,0 @@ -From 159cdfb86b4c6c870e44935a82b94bc38e670561 Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Fri, 9 Jan 2015 13:41:13 +0100 -Subject: [PATCH hurd 08/11] XXX proc fix build - ---- - proc/Makefile | 3 +++ - 1 file changed, 3 insertions(+) - -diff --git a/proc/Makefile b/proc/Makefile -index 2275a66..7cc4af5 100644 ---- a/proc/Makefile -+++ b/proc/Makefile -@@ -32,6 +32,9 @@ MIGSTUBS = processServer.o notifyServer.o \ - OBJS = $(SRCS:.c=.o) $(MIGSTUBS) - HURDLIBS = ihash ports shouldbeinlibc - -+# XXX: fix build -+MIGSTUBS += gnumachUser.o task_notifyUser.o -+ - OTHERLIBS = -lpthread - - include ../Makeconf --- -2.1.4 - diff --git a/debian/patches/bootshell0009-fu_bootshell.patch b/debian/patches/bootshell0009-fu_bootshell.patch deleted file mode 100644 index 976eb3a5..00000000 --- a/debian/patches/bootshell0009-fu_bootshell.patch +++ /dev/null @@ -1,95 +0,0 @@ -From 4535e00555a3317aa28395a7f7fd02b3d204e6ec Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Mon, 7 Sep 2015 12:32:00 +0200 -Subject: [PATCH hurd 09/11] fu_bootshell - ---- - bootshell/boot.scm | 28 ++++++++++++++++++++++++++++ - bootshell/runsystem.scm | 26 +------------------------- - 2 files changed, 29 insertions(+), 25 deletions(-) - -diff --git a/bootshell/boot.scm b/bootshell/boot.scm -index 75cc75f..8b51459 100644 ---- a/bootshell/boot.scm -+++ b/bootshell/boot.scm -@@ -38,6 +38,34 @@ - (define (string-prefix-any? lp s) - (any (lambda (p) (string-prefix? p s)) lp)) - -+;; Locate the first occurrence of needle in haystack. -+(define (string-index haystack needle) -+ (define (index i haystack needle) -+ (if (= (length haystack) 0) -+ #f -+ (if (char=? (car haystack) needle) -+ i -+ (index (+ i 1) (cdr haystack) needle)))) -+ (index 0 (string->list haystack) needle)) -+ -+;; Split haystack at delimiter at most n times. -+(define (string-splitn haystack delimiter n) -+ (define (split acc haystack delimiter n) -+ (if (= (string-length haystack) 0) -+ (reverse acc) -+ (let ((i (string-index haystack delimiter))) -+ (if (not (or (eq? i #f) (= 0 n))) -+ (split (cons (substring haystack 0 i) acc) -+ (substring haystack (+ i 1) (string-length haystack)) -+ delimiter (- n 1)) -+ (split (cons haystack acc) "" delimiter 0) -+ )))) -+ (split '() haystack delimiter n)) -+ -+;; Split haystack at delimiter. -+(define (string-split haystack delimiter) -+ (string-splitn haystack delimiter -1)) -+ - ;; The `catch' from init.scm doesn't give the thrown value to the - ;; handler. As a crappy workaround, we set! `last-exception' to the - ;; last the exception. -diff --git a/bootshell/runsystem.scm b/bootshell/runsystem.scm -index 86b8c16..a2f0ee2 100644 ---- a/bootshell/runsystem.scm -+++ b/bootshell/runsystem.scm -@@ -17,31 +17,6 @@ - ;; You should have received a copy of the GNU General Public License - ;; along with the GNU Hurd. If not, see <http://www.gnu.org/licenses/>. */ - --(define (string-index haystack delimiter) -- (define (index i haystack delimiter) -- (if (= (length haystack) 0) -- #f -- (if (char=? (car haystack) delimiter) -- i -- (index (+ i 1) (cdr haystack) delimiter)))) -- (index 0 (string->list haystack) delimiter)) -- --(define (string-splitn haystack delimiter n) -- (define (split acc haystack delimiter n) -- (if (= (string-length haystack) 0) -- (reverse acc) -- (let ((i (string-index haystack delimiter))) -- (if (not (or (eq? i #f) (= 0 n))) -- (split (cons (substring haystack 0 i) acc) -- (substring haystack (+ i 1) (string-length haystack)) -- delimiter (- n 1)) -- (split (cons haystack acc) "" delimiter 0) -- )))) -- (split '() haystack delimiter n)) -- --(define (string-split haystack delimiter) -- (string-splitn haystack delimiter -1)) -- - (define (parse-cmdline c) - (define (parse args kwargs l) - (if (= (length l) 0) -@@ -74,5 +49,6 @@ - ;(lambda () (boot! init)) - (lambda () - (run '(/sbin/console-run --console=/dev/console -- /bin/bash)) -+ (echo "bash started") - (sleep 60)) - )))) --- -2.1.4 - diff --git a/debian/patches/bootshell0010-fixup_bootshell.patch b/debian/patches/bootshell0010-fixup_bootshell.patch deleted file mode 100644 index 133605c3..00000000 --- a/debian/patches/bootshell0010-fixup_bootshell.patch +++ /dev/null @@ -1,43 +0,0 @@ -From 06b93c0c5b0ed5ffbfdf35e58741a18e444b2d63 Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Tue, 29 Sep 2015 17:17:21 +0200 -Subject: [PATCH hurd 10/11] fixup_bootshell - ---- - bootshell/fs.c | 2 ++ - bootshell/main.c | 1 + - 2 files changed, 3 insertions(+) - -diff --git a/bootshell/fs.c b/bootshell/fs.c -index 88536d8..89b6b9d 100644 ---- a/bootshell/fs.c -+++ b/bootshell/fs.c -@@ -18,11 +18,13 @@ - along with the GNU Hurd. If not, see <http://www.gnu.org/licenses/>. */ - - #include <assert.h> -+#include <error.h> - #include <hurd.h> - #include <mach.h> - #include <mach/message.h> - #include <pthread.h> - #include <stdio.h> -+#include <string.h> - - // eek #include "fs_S.h" - -diff --git a/bootshell/main.c b/bootshell/main.c -index 54685a7..f444abc 100644 ---- a/bootshell/main.c -+++ b/bootshell/main.c -@@ -18,6 +18,7 @@ - along with the GNU Hurd. If not, see <http://www.gnu.org/licenses/>. */ - - #include <argp.h> -+#include <argz.h> - #include <assert.h> - #include <ctype.h> - #include <stdarg.h> --- -2.1.4 - diff --git a/debian/patches/bootshell0011-fixup_bootshell.patch b/debian/patches/bootshell0011-fixup_bootshell.patch deleted file mode 100644 index a55c79d5..00000000 --- a/debian/patches/bootshell0011-fixup_bootshell.patch +++ /dev/null @@ -1,148 +0,0 @@ -From d649e0d40bb8aa6c2b1de7a556f9453943dd2c9d Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Tue, 29 Sep 2015 18:03:45 +0200 -Subject: [PATCH hurd 11/11] fixup_bootshell - ---- - bootshell/boot.scm | 5 ++++ - bootshell/bootstrap.scm | 80 +++++++++++++++++++++++++------------------------ - bootshell/runsystem.scm | 2 +- - 3 files changed, 47 insertions(+), 40 deletions(-) - -diff --git a/bootshell/boot.scm b/bootshell/boot.scm -index 8b51459..bef374d 100644 ---- a/bootshell/boot.scm -+++ b/bootshell/boot.scm -@@ -233,6 +233,11 @@ Environment: - (define (replay-log) - (for-each display messages)) - -+(define verbose #f) -+(define (trace . args) -+ (if verbose -+ (log . args))) -+ - (define timeout 1000) ; 1 second - - (define (pause) -diff --git a/bootshell/bootstrap.scm b/bootshell/bootstrap.scm -index a521e01..766321e 100644 ---- a/bootshell/bootstrap.scm -+++ b/bootshell/bootstrap.scm -@@ -73,45 +73,45 @@ - (letport - ((proc-task (task-create mach-task-self 0)) - (auth-task (task-create mach-task-self 0))) -- -- ;; Starting proc and auth is tricky, we need to do it simultaneously. -- (let ((pc (bootstrap-proc (start-translator proc-task '("/hurd/proc")))) -- (ac (bootstrap-auth (start-translator auth-task '("/hurd/auth")))) -- ;; Projections for the cookies returned by bootstrap-*. -- (:reply car) (:replyPoly cadr) (:server caddr)) -- (log "proc ") -- (startup-procinit-reply (:reply pc) (:replyPoly pc) ESUCCESS -- mach-task-self (:server ac) -- host-priv device-master) -- (bind-proc (:server pc)) -- -- ;; Declare that these tasks are our children, and fix them up. -- (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)) -- -- ;; Supply the proc server with a standard template. -- (proc->auth->set-std-execdata! (:server pc) (:server ac)) -- -- ;; Neither the kernel nor our bootscript task have command line -- ;; arguments. Fix that. -- (frob-task (proc->pid->task (:server pc) 3) -- '(gnumach huhu lala XXX)) -- (if (mach-port-valid? bootscript-task) -- (frob-task bootscript-task '(/hurd/runsystem.scm))) -- (frob-task mach-task-self '(/hurd/bootshell)) -- -- (mach-port-deallocate mach-task-self (:server pc)) -- (mach-port-deallocate mach-task-self (:server ac))))) -+ (log "about to start proc and auth") -+ ;; Starting proc and auth is tricky, we need to do it simultaneously. -+ (let ((pc (bootstrap-proc (start-translator proc-task '("/hurd/proc")))) -+ (ac (bootstrap-auth (start-translator auth-task '("/hurd/auth")))) -+ ;; Projections for the cookies returned by bootstrap-*. -+ (:reply car) (:replyPoly cadr) (:server caddr)) -+ (log "proc ") -+ (startup-procinit-reply (:reply pc) (:replyPoly pc) ESUCCESS -+ mach-task-self (:server ac) -+ host-priv device-master) -+ (bind-proc (:server pc)) -+ -+ ;; Declare that these tasks are our children, and fix them up. -+ (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)) -+ -+ ;; Supply the proc server with a standard template. -+ (proc->auth->set-std-execdata! (:server pc) (:server ac)) -+ -+ ;; Neither the kernel nor our bootscript task have command line -+ ;; arguments. Fix that. -+ (frob-task (proc->pid->task (:server pc) 3) -+ '(gnumach huhu lala XXX)) -+ (if (mach-port-valid? bootscript-task) -+ (frob-task bootscript-task '(/hurd/runsystem.scm))) -+ (frob-task mach-task-self '(/hurd/bootshell)) -+ -+ (mach-port-deallocate mach-task-self (:server pc)) -+ (mach-port-deallocate mach-task-self (:server ac))))) - - (define (start-hurd-console) - (log "hurd-console ") -@@ -215,6 +215,7 @@ - (mach-port-allocate mach-task-self MACH_PORT_RIGHT_RECEIVE)) - (task - (prepare-task (make-send-right bootstrap)))) -+ (log "proc handshake") - (handle-startup-procinit bootstrap timeout))) - - ;; Bootstraps the auth server using the startup protocol. -@@ -223,6 +224,7 @@ - (mach-port-allocate mach-task-self MACH_PORT_RIGHT_RECEIVE)) - (task - (prepare-task (make-send-right bootstrap)))) -+ (log "auth handshake") - (handle-startup-authinit bootstrap timeout))) - - ;; Bootstraps a translator using the fsys protocol and installs it as -diff --git a/bootshell/runsystem.scm b/bootshell/runsystem.scm -index a2f0ee2..bcf2c80 100644 ---- a/bootshell/runsystem.scm -+++ b/bootshell/runsystem.scm -@@ -36,7 +36,7 @@ - (default) - (cdr value))))) - (init (:kwarg "init" (lambda () "/sbin/init")))) -- -+ (set! verbose #t) - (bootstrap (list - (lambda () (first-stage (:kwarg "root" (lambda () "xxx")))) - early-startup --- -2.1.4 - diff --git a/debian/patches/external.patch b/debian/patches/external.patch index c746aac4..a283b69a 100644 --- a/debian/patches/external.patch +++ b/debian/patches/external.patch @@ -6,21 +6,22 @@ Index: hurd-debian/Makefile =================================================================== --- hurd-debian.orig/Makefile +++ hurd-debian/Makefile -@@ -28,7 +28,8 @@ include ./Makeconf +@@ -28,8 +28,8 @@ include ./Makeconf # Hurd libraries lib-subdirs = libshouldbeinlibc libihash libiohelp libports libthreads \ libpager libfshelp libdiskfs libtrivfs libps \ -- libnetfs libpipe libstore libhurdbugaddr libftpconn libcons -+ libnetfs libpipe libstore libhurdbugaddr libftpconn libcons \ -+ libmachdev libbpf libddekit libhurd-slab eth-filter eth-multiplexer + libnetfs libpipe libstore libhurdbugaddr libftpconn libcons \ +- libhurd-slab ++ libhurd-slab libmachdev libbpf libddekit libhurd-slab # Hurd programs prog-subdirs = auth proc exec term \ -@@ -37,6 +38,7 @@ prog-subdirs = auth proc exec init term +@@ -37,6 +38,8 @@ prog-subdirs = auth proc exec init term procfs \ startup \ init \ -+ devnode ++ eth-filter \ ++ eth-multiplexer \ ifeq ($(HAVE_SUN_RPC),yes) prog-subdirs += nfs nfsd diff --git a/debian/patches/introspection0001-hurd-add-an-Hurd-server-introspection-protocol.patch b/debian/patches/introspection0001-hurd-add-an-Hurd-server-introspection-protocol.patch deleted file mode 100644 index e9e5a483..00000000 --- a/debian/patches/introspection0001-hurd-add-an-Hurd-server-introspection-protocol.patch +++ /dev/null @@ -1,147 +0,0 @@ -From ce7d1456a483bd38c78267fb073713c1cae01c7c Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Wed, 21 May 2014 16:40:12 +0200 -Subject: [PATCH hurd 1/9] hurd: add an Hurd server introspection protocol - -Most Hurd servers use libports to manage receive rights and the -associated objects. These procedures can be used to query the state -associated with receive rights managed by libports. - -The procedures are not specific to libports. Any Hurd server can -implement this protocol. To do so, a server installs a send right in -the array of well-known ports, under the key -HURD_PORT_REGISTER_INTROSPECTION. - -* hurd/hurd_port.defs: New file. -* hurd/hurd_types.h (HURD_PORT_REGISTER_INTROSPECTION): New macro. -(HURD_PORT_REGISTER_MAX): Likewise. -* hurd/subsystems: Add hurd_port subsystem. ---- - hurd/hurd_port.defs | 78 +++++++++++++++++++++++++++++++++++++++++++++++++++++ - hurd/hurd_types.h | 7 +++++ - hurd/subsystems | 1 + - 3 files changed, 86 insertions(+) - create mode 100644 hurd/hurd_port.defs - -diff --git a/hurd/hurd_port.defs b/hurd/hurd_port.defs -new file mode 100644 -index 0000000..d1f46b3 ---- /dev/null -+++ b/hurd/hurd_port.defs -@@ -0,0 +1,78 @@ -+/* Hurd server introspection. -+ -+ Copyright (C) 2014 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+subsystem hurd_port 39000; -+ -+/* Hurd server introspection. -+ -+ Most Hurd servers use libports to manage receive rights and the -+ associated objects. These procedures can be used to query the -+ state associated with receive rights managed by libports. -+ -+ The procedures are not specific to libports. Any Hurd server can -+ implement this protocol. To do so, a server installs a send right -+ in the array of well-known ports, under the key -+ HURD_PORT_REGISTER_INTROSPECTION. -+ -+ A client in possession of the servers task port can retrieve a copy -+ of this send right using mach_ports_lookup. */ -+ -+#include <hurd/hurd_types.defs> -+ -+#ifdef HURD_PORT_IMPORTS -+HURD_PORT_IMPORTS -+#endif -+ -+INTR_INTERFACE -+ -+/* Return the number of hard and weak references of the object -+ directly associated with the receive right NAME. -+ -+ Return EINVAL if NAME does not denote a receive right managed by -+ the port-to-object mapper, or if the concept of reference counting -+ simply does not apply. */ -+routine hurd_port_get_refcounts ( -+ introspection: mach_port_t; -+ name: mach_port_name_t; -+ waittime timeout: natural_t; -+ RPT -+ out hard: natural_t; -+ out weak: natural_t); -+ -+/* Return a compact, human-readable description of the object related -+ with the receive right NAME. -+ -+ This description is meant for debugging purposes and should include -+ relevant internal state. If possible, it should include -+ information that is meaningful in other contexts (like a file name, -+ or the inode number). -+ -+ Return EINVAL if NAME does not denote a receive right managed by -+ the port-to-object mapper. */ -+routine hurd_port_debug_info ( -+ introspection: mach_port_t; -+ name: mach_port_name_t; -+ waittime timeout: natural_t; -+ RPT -+ out debug_info: string_t); -+ -+routine hurd_port_trace_class_rpcs ( -+ introspection: mach_port_t; -+ name: mach_port_name_t; -+ trace_port: mach_port_send_t); -diff --git a/hurd/hurd_types.h b/hurd/hurd_types.h -index 83942a7..94e5da6 100644 ---- a/hurd/hurd_types.h -+++ b/hurd/hurd_types.h -@@ -24,6 +24,7 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ - #include <time.h> /* For struct timespec. */ - #include <mach/std_types.h> /* For mach_port_t et al. */ - #include <mach/message.h> /* For mach_msg_id_t et al. */ -+#include <mach/mach_param.h> /* For TASK_PORT_REGISTER_MAX. */ - #include <sys/types.h> /* For pid_t and uid_t. */ - - /* A string identifying this release of the GNU Hurd. Our -@@ -373,4 +374,10 @@ enum - INIT_INT_MAX, - }; - -+/* Define the well-known ports available via mach_ports_lookup. */ -+#define HURD_PORT_REGISTER_INTROSPECTION 0 -+ -+/* This is a fixed limit. */ -+#define HURD_PORT_REGISTER_MAX TASK_PORT_REGISTER_MAX -+ - #endif -diff --git a/hurd/subsystems b/hurd/subsystems -index c05895c..59893b2 100644 ---- a/hurd/subsystems -+++ b/hurd/subsystems -@@ -36,6 +36,7 @@ tape 35000 Special control operations for magtapes - login 36000 Database of logged-in users - pfinet 37000 Internet configuration calls - password 38000 Password checker -+hurd_port 39000 Port debugging and introspection - <ioctl space> 100000- First subsystem of ioctl class 'f' (lowest class) - tioctl 156000 Ioctl class 't' (terminals) - tioctl 156200 (continued) --- -2.1.4 - diff --git a/debian/patches/introspection0002-libintrospection-a-library-for-Hurd-server-introspec.patch b/debian/patches/introspection0002-libintrospection-a-library-for-Hurd-server-introspec.patch deleted file mode 100644 index 9ceee518..00000000 --- a/debian/patches/introspection0002-libintrospection-a-library-for-Hurd-server-introspec.patch +++ /dev/null @@ -1,397 +0,0 @@ -From 1bf95b7a4e31f9f26d828c1008687eb082727e15 Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Fri, 23 May 2014 17:01:48 +0200 -Subject: [PATCH hurd 2/9] libintrospection: a library for Hurd server - introspection - -* Makefile (lib-subdirs): Add libintrospection. -* libintrospection/Makefile: New file. -* libintrospection/introspection.c: Likewise. -* libintrospection/introspection.h: Likewise. -* libintrospection/trace.c: Likewise. ---- - Makefile | 2 + - libintrospection/Makefile | 27 +++++++ - libintrospection/introspection.c | 86 ++++++++++++++++++++ - libintrospection/introspection.h | 50 ++++++++++++ - libintrospection/trace.c | 171 +++++++++++++++++++++++++++++++++++++++ - 5 files changed, 336 insertions(+) - create mode 100644 libintrospection/Makefile - create mode 100644 libintrospection/introspection.c - create mode 100644 libintrospection/introspection.h - create mode 100644 libintrospection/trace.c - -diff --git a/Makefile b/Makefile -index 3178740..76eec21 100644 ---- a/Makefile -+++ b/Makefile -@@ -50,6 +50,8 @@ endif - # Other directories - other-subdirs = hurd doc config release include - -+lib-subdirs += libintrospection -+ - # All the subdirectories together - subdirs = $(lib-subdirs) $(prog-subdirs) $(other-subdirs) - -diff --git a/libintrospection/Makefile b/libintrospection/Makefile -new file mode 100644 -index 0000000..75adef2 ---- /dev/null -+++ b/libintrospection/Makefile -@@ -0,0 +1,27 @@ -+# Copyright (C) 2014 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. If not, see <http://www.gnu.org/licenses/>. -+ -+dir := libintrospection -+makemode := library -+ -+libname := libintrospection -+SRCS = introspection.c trace.c hurd_portUser.c -+installhdrs = introspection.h -+ -+OBJS = $(SRCS:.c=.o) -+ -+include ../Makeconf -diff --git a/libintrospection/introspection.c b/libintrospection/introspection.c -new file mode 100644 -index 0000000..65c0727 ---- /dev/null -+++ b/libintrospection/introspection.c -@@ -0,0 +1,86 @@ -+/* Hurd server introspection. -+ -+ Copyright (C) 2014 Free Software Foundation, Inc. -+ -+ Written by Justus Winter <4winter@informatik.uni-hamburg.de> -+ -+ 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 <http://www.gnu.org/licenses/>. */ -+ -+#include <mach.h> -+ -+#include "introspection.h" -+#include "hurd_port_U.h" -+ -+error_t -+introspection_set_port (mach_port_t task, -+ mach_port_t introspection_port) -+{ -+ error_t err; -+ mach_port_t *ports; -+ size_t ports_len; -+ -+ err = mach_ports_lookup (task, &ports, &ports_len); -+ if (err) -+ return err; -+ -+ if (MACH_PORT_VALID (ports[HURD_PORT_REGISTER_INTROSPECTION])) -+ mach_port_deallocate (mach_task_self (), -+ ports[HURD_PORT_REGISTER_INTROSPECTION]); -+ -+ ports[HURD_PORT_REGISTER_INTROSPECTION] = introspection_port; -+ -+ err = mach_ports_register (task, ports, ports_len); -+ if (err) -+ { -+ size_t i; -+ for (i = 0; i < ports_len; i++) -+ if (MACH_PORT_VALID (ports[i])) -+ mach_port_deallocate (mach_task_self (), ports[i]); -+ -+ return err; -+ } -+ -+ return 0; -+} -+ -+error_t -+introspection_get_port (mach_port_t task, mach_port_t *introspection_port) -+{ -+ error_t err; -+ mach_port_t *ports; -+ size_t ports_len; -+ -+ err = mach_ports_lookup (task, &ports, &ports_len); -+ if (! err) -+ { -+ size_t i; -+ if (MACH_PORT_VALID (*introspection_port)) -+ mach_port_deallocate (mach_task_self (), *introspection_port); -+ -+ for (i = 0; i < ports_len; i++) -+ if (i == HURD_PORT_REGISTER_INTROSPECTION) -+ *introspection_port = ports[i]; -+ else -+ { -+ if (MACH_PORT_VALID (ports[i])) -+ mach_port_deallocate (mach_task_self (), ports[i]); -+ } -+ } -+ else -+ *introspection_port = MACH_PORT_DEAD; -+ -+ return err; -+} -diff --git a/libintrospection/introspection.h b/libintrospection/introspection.h -new file mode 100644 -index 0000000..ae9fcfa ---- /dev/null -+++ b/libintrospection/introspection.h -@@ -0,0 +1,50 @@ -+/* Hurd server introspection. -+ -+ Copyright (C) 2014 Free Software Foundation, Inc. -+ -+ Written by Justus Winter <4winter@informatik.uni-hamburg.de> -+ -+ 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 <http://www.gnu.org/licenses/>. */ -+ -+#ifndef _HURD_INTROSPECTION_H_ -+#define _HURD_INTROSPECTION_H_ -+ -+#include <errno.h> -+#include <mach.h> -+ -+error_t -+introspection_set_port (mach_port_t task, -+ mach_port_t introspection_port); -+ -+error_t -+introspection_get_port (mach_port_t task, -+ mach_port_t *introspection_port); -+ -+error_t -+introspection_trace_message (mach_port_t trace_port, -+ const mach_msg_header_t *msgp, -+ mach_port_t id); -+ -+error_t -+introspection_trace_request (mach_port_t trace_port, -+ const mach_msg_header_t *msgp, -+ mach_port_t *id); -+ -+error_t -+introspection_extract_message (mach_msg_header_t *msgp, -+ mach_port_t *id); -+ -+#endif /* _HURD_INTROSPECTION_H_ */ -diff --git a/libintrospection/trace.c b/libintrospection/trace.c -new file mode 100644 -index 0000000..6654515 ---- /dev/null -+++ b/libintrospection/trace.c -@@ -0,0 +1,171 @@ -+/* Hurd server introspection. -+ -+ Copyright (C) 2014 Free Software Foundation, Inc. -+ -+ Written by Justus Winter <4winter@informatik.uni-hamburg.de> -+ -+ 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 <http://www.gnu.org/licenses/>. */ -+ -+#include <error.h> -+#include <hurd/ports.h> -+#include <mach/mig_errors.h> -+#include <pthread.h> -+#include <stdlib.h> -+#include <string.h> -+ -+#include "introspection.h" -+ -+static const mach_msg_type_t ports_type = { -+ /* msgt_name = */ MACH_MSG_TYPE_PORT_NAME, -+ /* msgt_size = */ sizeof (mach_port_t) << 3, -+ /* msgt_number = */ 4, -+ /* msgt_inline = */ TRUE, -+ /* msgt_longform = */ FALSE, -+ /* msgt_deallocate = */ FALSE, -+ /* msgt_unused = */ 0 -+}; -+ -+struct trace_footer -+{ -+ mach_msg_type_t ports_type; -+ mach_port_t id; -+ mach_port_t bits; -+ mach_port_t remote_port; -+ mach_port_t local_port; -+}; -+ -+error_t -+introspection_trace_message (mach_port_t trace_port, -+ const mach_msg_header_t *msgp, -+ mach_port_t id) -+{ -+ error_t err; -+ mach_msg_header_t *copyp; -+ void *msg_buf_ptr; -+ struct trace_footer *footer; -+ size_t size = msgp->msgh_size + sizeof *footer; -+ -+ copyp = malloc (size); -+ if (copyp == NULL) -+ return ENOMEM; -+ -+ memcpy (copyp, msgp, msgp->msgh_size); -+ footer = (void *) copyp + msgp->msgh_size; -+ -+ /* Process the message data, clear msgt_deallocate and turn rights -+ into mere port names. */ -+ msg_buf_ptr = (void *) copyp + sizeof *copyp; -+ while (msg_buf_ptr < (void *) copyp + msgp->msgh_size) -+ { -+ mach_msg_type_long_t *type_long = msg_buf_ptr; -+ mach_msg_type_t *type = &type_long->msgtl_header; -+ mach_msg_type_number_t nelt; /* Number of data items. */ -+ mach_msg_type_size_t eltsize; /* Bytes per item. */ -+ -+ type->msgt_deallocate = 0; -+ -+ if (! type->msgt_longform) -+ { -+ nelt = type->msgt_number; -+ eltsize = type->msgt_size / 8; -+ if (MACH_MSG_TYPE_PORT_ANY (type->msgt_name)) -+ type->msgt_name = MACH_MSG_TYPE_PORT_NAME; -+ msg_buf_ptr += sizeof *type; -+ } -+ else -+ { -+ nelt = type_long->msgtl_number; -+ eltsize = type_long->msgtl_size / 8; -+ if (MACH_MSG_TYPE_PORT_ANY (type_long->msgtl_name)) -+ type_long->msgtl_name = MACH_MSG_TYPE_PORT_NAME; -+ msg_buf_ptr += sizeof *type_long; -+ } -+ -+ if (! type->msgt_inline) -+ /* This datum is out-of-line, meaning the message actually -+ contains a pointer to a vm_allocate'd region of data. */ -+ msg_buf_ptr += sizeof (void *); -+ else -+ msg_buf_ptr += ((nelt * eltsize + sizeof(natural_t) - 1) -+ & ~(sizeof(natural_t) - 1)); -+ } -+ -+ copyp->msgh_bits = -+ MACH_MSGH_BITS (MACH_MSG_TYPE_COPY_SEND, 0) -+ | (msgp->msgh_bits & MACH_MSGH_BITS_COMPLEX); -+ copyp->msgh_remote_port = trace_port; -+ copyp->msgh_local_port = MACH_PORT_NULL; -+ -+ *footer = (struct trace_footer) -+ { -+ ports_type, -+ id, -+ (mach_port_t) msgp->msgh_bits, -+ msgp->msgh_remote_port, -+ MACH_MSGH_BITS_LOCAL (msgp->msgh_bits) -+ == MACH_MSG_TYPE_PROTECTED_PAYLOAD -+ ? ports_payload_get_name (msgp->msgh_protected_payload) -+ : msgp->msgh_local_port, -+ }; -+ -+ err = mach_msg (copyp, MACH_SEND_MSG|MACH_SEND_TIMEOUT, size, -+ 0, MACH_PORT_NULL, 10 /* ms */, MACH_PORT_NULL); -+ -+ free (copyp); -+ return err; -+} -+ -+static mach_port_t -+make_id (void) -+{ -+ static mach_port_t id; -+ mach_port_t result; -+ -+ do -+ result = __atomic_add_fetch (&id, 1, __ATOMIC_RELAXED); -+ while (! MACH_PORT_VALID (result)); -+ -+ return result; -+} -+ -+error_t -+introspection_trace_request (mach_port_t trace_port, -+ const mach_msg_header_t *msgp, -+ mach_port_t *id) -+{ -+ *id = make_id (); -+ return introspection_trace_message (trace_port, msgp, *id); -+} -+ -+error_t -+introspection_extract_message (mach_msg_header_t *msgp, -+ mach_port_t *id) -+{ -+ size_t size = msgp->msgh_size - sizeof (struct trace_footer); -+ struct trace_footer *footer = (void *) msgp + size; -+ -+ if (memcmp (&footer->ports_type, &ports_type, sizeof ports_type) != 0) -+ return MIG_BAD_ARGUMENTS; -+ -+ msgp->msgh_bits = -+ ((mach_msg_bits_t) footer->bits & ~MACH_MSGH_BITS_PORTS_MASK) -+ || MACH_MSGH_BITS (MACH_MSG_TYPE_PORT_NAME, MACH_MSG_TYPE_PORT_NAME); -+ msgp->msgh_remote_port = footer->remote_port; -+ msgp->msgh_local_port = footer->local_port; -+ msgp->msgh_size = size; -+ *id = footer->id; -+ return 0; -+} --- -2.1.4 - diff --git a/debian/patches/introspection0003-libports-implement-the-Hurd-server-introspection-pro.patch b/debian/patches/introspection0003-libports-implement-the-Hurd-server-introspection-pro.patch deleted file mode 100644 index ebc9e56f..00000000 --- a/debian/patches/introspection0003-libports-implement-the-Hurd-server-introspection-pro.patch +++ /dev/null @@ -1,504 +0,0 @@ -From 3cd552c422a2bed42e5c23c997e0e5039c8f8fbc Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Wed, 21 May 2014 16:47:14 +0200 -Subject: [PATCH hurd 3/9] libports: implement the Hurd server introspection - protocol - -Add a compact and self-contained introspection server to libports. -Add functions to to label port buckets and classes. Make it possible -to provide a function that given an object of a class, returns a -human-readable representation for it. - -* libports/introspection.c: New file. -* libports/create-bucket.c (ports_label_bucket): New function. -* libports/create-class.c (ports_set_debug_info): Likewise. -* libports/manage-multithread.c (internal_demuxer): Trace messages if -desired. -* libports/manage-one-thread.c (internal_demuxer): Likewise. -* libports/ports.h (struct port_bucket): Add label. -(struct port_class): Add debug_info and label. -(ports_label_bucket): New declaration. -(ports_set_debug_info): Likewise. -* libports/Makefile (SRCS): Add introspection.c. -(OBJS): Add hurd_portServer.o. ---- - ext2fs/Makefile | 3 +- - fatfs/Makefile | 3 +- - isofs/Makefile | 3 +- - libports/Makefile | 6 +- - libports/create-bucket.c | 7 ++ - libports/create-class.c | 16 ++++ - libports/introspection.c | 194 ++++++++++++++++++++++++++++++++++++++++++ - libports/manage-multithread.c | 12 +++ - libports/manage-one-thread.c | 13 +++ - libports/ports.h | 15 ++++ - tmpfs/Makefile | 3 +- - 11 files changed, 268 insertions(+), 7 deletions(-) - create mode 100644 libports/introspection.c - -diff --git a/ext2fs/Makefile b/ext2fs/Makefile -index 8d2e68c..9d72fda 100644 ---- a/ext2fs/Makefile -+++ b/ext2fs/Makefile -@@ -23,7 +23,8 @@ target = ext2fs - SRCS = balloc.c dir.c ext2fs.c getblk.c hyper.c ialloc.c \ - inode.c pager.c pokel.c truncate.c storeinfo.c msg.c xinl.c - OBJS = $(SRCS:.c=.o) --HURDLIBS = diskfs pager iohelp fshelp store ports ihash shouldbeinlibc -+HURDLIBS = diskfs pager iohelp fshelp store ports ihash introspection \ -+ shouldbeinlibc - OTHERLIBS = -lpthread $(and $(HAVE_LIBBZ2),-lbz2) $(and $(HAVE_LIBZ),-lz) - - include ../Makeconf -diff --git a/fatfs/Makefile b/fatfs/Makefile -index 6224b64..e4f01ec 100644 ---- a/fatfs/Makefile -+++ b/fatfs/Makefile -@@ -22,7 +22,8 @@ target = fatfs - SRCS = inode.c main.c dir.c pager.c fat.c virt-inode.c node-create.c - - OBJS = $(SRCS:.c=.o) --HURDLIBS = diskfs iohelp fshelp store pager ports ihash shouldbeinlibc -+HURDLIBS = diskfs iohelp fshelp store pager ports ihash introspection \ -+ shouldbeinlibc - OTHERLIBS = -lpthread $(and $(HAVE_LIBBZ2),-lbz2) $(and $(HAVE_LIBZ),-lz) - - include ../Makeconf -diff --git a/isofs/Makefile b/isofs/Makefile -index 6475c52..9e399bf 100644 ---- a/isofs/Makefile -+++ b/isofs/Makefile -@@ -21,7 +21,8 @@ target = iso9660fs - SRCS = inode.c main.c lookup.c pager.c rr.c - - OBJS = $(SRCS:.c=.o) --HURDLIBS = diskfs iohelp fshelp store pager ports ihash shouldbeinlibc -+HURDLIBS = diskfs iohelp fshelp store pager ports ihash introspection \ -+ shouldbeinlibc - OTHERLIBS = -lpthread $(and $(HAVE_LIBBZ2),-lbz2) $(and $(HAVE_LIBZ),-lz) - - include ../Makeconf -diff --git a/libports/Makefile b/libports/Makefile -index af881f8..ec98bad 100644 ---- a/libports/Makefile -+++ b/libports/Makefile -@@ -36,13 +36,13 @@ SRCS = create-bucket.c create-class.c \ - interrupt-operation.c interrupt-on-notify.c interrupt-notified-rpcs.c \ - dead-name.c create-port.c import-port.c default-uninhibitable-rpcs.c \ - claim-right.c transfer-right.c create-port-noinstall.c create-internal.c \ -- interrupted.c extern-inline.c port-deref-deferred.c -+ interrupted.c extern-inline.c port-deref-deferred.c introspection.c - - installhdrs = ports.h port-deref-deferred.h - --HURDLIBS= ihash -+HURDLIBS= ihash introspection - LDLIBS += -lpthread --OBJS = $(SRCS:.c=.o) notifyServer.o interruptServer.o -+OBJS = $(SRCS:.c=.o) notifyServer.o interruptServer.o hurd_portServer.o - - MIGCOMSFLAGS = -prefix ports_ - MIGSFLAGS = -imacros $(srcdir)/mig-mutate.h -diff --git a/libports/create-bucket.c b/libports/create-bucket.c -index 82c00a4..34559f5 100644 ---- a/libports/create-bucket.c -+++ b/libports/create-bucket.c -@@ -49,5 +49,12 @@ ports_create_bucket () - hurd_ihash_init (&ret->htable, offsetof (struct port_info, hentry)); - ret->rpcs = ret->flags = ret->count = 0; - _ports_threadpool_init (&ret->threadpool); -+ ret->label = "unlabeled bucket"; - return ret; - } -+ -+/* Label BUCKET with LABEL. */ -+void ports_label_bucket (struct port_bucket *bucket, const char *label) -+{ -+ bucket->label = label; -+} -diff --git a/libports/create-class.c b/libports/create-class.c -index 782f52b..8abf643 100644 ---- a/libports/create-class.c -+++ b/libports/create-class.c -@@ -41,6 +41,22 @@ ports_create_class (void (*clean_routine)(void *), - cl->rpcs = 0; - cl->count = 0; - cl->uninhibitable_rpcs = ports_default_uninhibitable_rpcs; -+ cl->debug_info = NULL; -+ cl->label = "unlabeled class"; -+ cl->trace_port = MACH_PORT_NULL; - - return cl; - } -+ -+/* Label CLASS with LABEL. Use DEBUG_INFO to format human-readable -+ information about a given object belonging to CLASS into an buffer, -+ or the default formatting function if DEBUG_INFO is NULL. */ -+void -+ports_label_class (struct port_class *class, -+ const char *label, -+ error_t (*debug_info) (const void *, char *, size_t)) -+{ -+ class->label = label; -+ if (debug_info) -+ class->debug_info = debug_info; -+} -diff --git a/libports/introspection.c b/libports/introspection.c -new file mode 100644 -index 0000000..07f8624 ---- /dev/null -+++ b/libports/introspection.c -@@ -0,0 +1,194 @@ -+/* Hurd server introspection. -+ -+ Copyright (C) 2014 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. If not, see <http://www.gnu.org/licenses/>. */ -+ -+#include <error.h> -+#include <hurd/introspection.h> -+#include <pthread.h> -+#include <stdio.h> -+#include <string.h> -+ -+#include "ports.h" -+#include "hurd_port_U.h" -+ -+/* We service introspection requests on this port. */ -+static mach_port_t introspection_port; -+ -+/* We use a separate thread to service the introspection requests. It -+ is a straight forward Mach server for the hurd_port protocol. */ -+static void * -+service_introspection_requests (void *arg) -+{ -+ error_t err; -+ -+ err = mach_port_allocate (mach_task_self (), MACH_PORT_RIGHT_RECEIVE, -+ &introspection_port); -+ if (err) -+ { -+ error (0, err, "mach_port_allocate"); -+ return NULL; -+ } -+ -+ err = mach_port_insert_right (mach_task_self (), -+ introspection_port, introspection_port, -+ MACH_MSG_TYPE_MAKE_SEND); -+ if (err) -+ { -+ error (0, err, "mach_port_insert_right"); -+ return NULL; -+ } -+ -+ err = introspection_set_port (mach_task_self (), introspection_port); -+ if (err) -+ { -+ error (0, err, "introspection_set_port"); -+ return NULL; -+ } -+ -+ /* XXX mig should emit this declaration. */ -+ boolean_t ports_hurd_port_server (mach_msg_header_t *InHeadP, -+ mach_msg_header_t *OutHeadP); -+ -+ while (1) -+ mach_msg_server (ports_hurd_port_server, 0, introspection_port); -+ -+ /* Not reached. */ -+ return NULL; -+} -+ -+/* Start the introspection server if it is not already running. */ -+void -+_ports_start_introspection_server (void) -+{ -+ static pthread_mutex_t lock = PTHREAD_MUTEX_INITIALIZER; -+ static int initialized = 0; -+ error_t err; -+ pthread_t thread; -+ -+ pthread_mutex_lock (&lock); -+ if (! initialized) -+ { -+ err = pthread_create (&thread, NULL, -+ service_introspection_requests, NULL); -+ if (err) -+ error (0, err, "Error starting introspection server"); -+ else -+ { -+ pthread_detach (thread); -+ initialized = 1; -+ } -+ } -+ pthread_mutex_unlock (&lock); -+} -+ -+/* Return the number of hard and weak references of the object -+ directly associated with the receive right NAME. -+ -+ Return EINVAL if NAME does not denote a receive right managed by -+ the port-to-object mapper, or if the concept of reference counting -+ simply does not apply. */ -+error_t -+ports_S_hurd_port_get_refcounts (mach_port_t port, -+ mach_port_t name, -+ natural_t *hard, -+ natural_t *weak) -+{ -+ struct references result; -+ struct port_info *pi; -+ -+ if (port != introspection_port) -+ return EOPNOTSUPP; -+ -+ pi = ports_lookup_port (0, name, 0); -+ if (pi == NULL) -+ return EINVAL; -+ -+ refcounts_references (&pi->refcounts, &result); -+ -+ *hard = result.hard - 1; -+ *weak = result.weak; -+ ports_port_deref (pi); -+ return 0; -+} -+ -+static error_t -+default_debug_info (const void *port, char *buffer, size_t size) -+{ -+ const struct port_info *pi = port; -+ snprintf (buffer, size, -+ "bucket: %s, class: %s", -+ pi->bucket->label, pi->class->label); -+ return 0; -+} -+ -+/* Return a compact, human-readable description of the object related -+ with the receive right NAME. -+ -+ This description is meant for debugging purposes and should include -+ relevant internal state. If possible, it should include -+ information that is meaningful in other contexts (like a file name, -+ or the inode number). -+ -+ Return EINVAL if NAME does not denote a receive right managed by -+ the port-to-object mapper. */ -+error_t -+ports_S_hurd_port_debug_info (mach_port_t port, -+ mach_port_t name, -+ char *info) -+{ -+ error_t err; -+ struct port_info *pi; -+ -+ if (port != introspection_port) -+ return EOPNOTSUPP; -+ -+ pi = ports_lookup_port (0, name, 0); -+ if (pi == NULL) -+ return EINVAL; -+ -+ if (pi->class->debug_info) -+ err = pi->class->debug_info (pi, info, 1024 /* XXX */); -+ else -+ err = default_debug_info (pi, info, 1024 /* XXX */); -+ info[1023 /* XXX */] = 0; -+ -+ ports_port_deref (pi); -+ return err; -+} -+ -+error_t -+ports_S_hurd_port_trace_class_rpcs (mach_port_t port, -+ mach_port_t name, -+ mach_port_t trace_port) -+{ -+ struct port_info *pi; -+ -+ if (port != introspection_port) -+ return EOPNOTSUPP; -+ -+ pi = ports_lookup_port (0, name, 0); -+ if (pi == NULL) -+ return EINVAL; -+ -+ if (MACH_PORT_VALID (pi->class->trace_port)) -+ mach_port_deallocate (mach_task_self (), pi->class->trace_port); -+ -+ pi->class->trace_port = trace_port; -+ ports_port_deref (pi); -+ return 0; -+} -diff --git a/libports/manage-multithread.c b/libports/manage-multithread.c -index 60743d9..d2e7dbe 100644 ---- a/libports/manage-multithread.c -+++ b/libports/manage-multithread.c -@@ -21,6 +21,7 @@ - #include "ports.h" - #include <assert.h> - #include <error.h> -+#include <hurd/introspection.h> - #include <stdio.h> - #include <mach/message.h> - #include <mach/thread_info.h> -@@ -189,6 +190,11 @@ ports_manage_port_operations_multithread (struct port_bucket *bucket, - - if (pi) - { -+ mach_port_t trace_port = pi->class->trace_port; -+ mach_port_t trace_id; -+ if (__builtin_expect (MACH_PORT_VALID (trace_port), 0)) -+ introspection_trace_request (trace_port, inp, &trace_id); -+ - error_t err = ports_begin_rpc (pi, inp->msgh_id, &link); - if (err) - { -@@ -207,6 +213,9 @@ ports_manage_port_operations_multithread (struct port_bucket *bucket, - ports_end_rpc (pi, &link); - } - ports_port_deref (pi); -+ -+ if (__builtin_expect (MACH_PORT_VALID (trace_port), 0)) -+ introspection_trace_message (trace_port, outp, trace_id); - } - else - { -@@ -281,5 +290,8 @@ ports_manage_port_operations_multithread (struct port_bucket *bucket, - master thread from going away. */ - global_timeout = 0; - -+ /* Make sure the introspection server is running. */ -+ _ports_start_introspection_server (); -+ - thread_function ((void *) 1); - } -diff --git a/libports/manage-one-thread.c b/libports/manage-one-thread.c -index b920338..86d575e 100644 ---- a/libports/manage-one-thread.c -+++ b/libports/manage-one-thread.c -@@ -18,6 +18,8 @@ - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -+#include <hurd/introspection.h> -+ - #include "ports.h" - - void -@@ -80,6 +82,11 @@ ports_manage_port_operations_one_thread (struct port_bucket *bucket, - - if (pi) - { -+ mach_port_t trace_port = pi->class->trace_port; -+ mach_port_t trace_id; -+ if (__builtin_expect (MACH_PORT_VALID (trace_port), 0)) -+ introspection_trace_request (trace_port, inp, &trace_id); -+ - err = ports_begin_rpc (pi, inp->msgh_id, &link); - if (err) - { -@@ -96,6 +103,9 @@ ports_manage_port_operations_one_thread (struct port_bucket *bucket, - ports_end_rpc (pi, &link); - } - ports_port_deref (pi); -+ -+ if (__builtin_expect (MACH_PORT_VALID (trace_port), 0)) -+ introspection_trace_message (trace_port, outp, trace_id); - } - else - { -@@ -114,6 +124,9 @@ ports_manage_port_operations_one_thread (struct port_bucket *bucket, - zero. */ - timeout = 0; - -+ /* Make sure the introspection server is running. */ -+ _ports_start_introspection_server (); -+ - _ports_thread_online (&bucket->threadpool, &thread); - do - err = mach_msg_server_timeout (internal_demuxer, 0, bucket->portset, -diff --git a/libports/ports.h b/libports/ports.h -index 9299bc4..e61b38c 100644 ---- a/libports/ports.h -+++ b/libports/ports.h -@@ -76,6 +76,7 @@ struct port_bucket - int flags; - int count; - struct ports_threadpool threadpool; -+ const char *label; - }; - /* FLAGS above are the following: */ - #define PORT_BUCKET_INHIBITED PORTS_INHIBITED -@@ -91,7 +92,10 @@ struct port_class - int count; - void (*clean_routine) (void *); - void (*dropweak_routine) (void *); -+ error_t (*debug_info) (const void *, char *, size_t); - struct ports_msg_id_range *uninhibitable_rpcs; -+ const char *label; -+ mach_port_t trace_port; - }; - /* FLAGS are the following: */ - #define PORT_CLASS_INHIBITED PORTS_INHIBITED -@@ -160,6 +164,9 @@ extern struct ports_msg_id_range *ports_default_uninhibitable_rpcs; - /* Create and return a new bucket. */ - struct port_bucket *ports_create_bucket (void); - -+/* Label BUCKET with LABEL. */ -+void ports_label_bucket (struct port_bucket *bucket, const char *label); -+ - /* Create and return a new port class. If nonzero, CLEAN_ROUTINE will - be called for each allocated port object in this class when it is - being destroyed. If nonzero, DROPWEAK_ROUTINE will be called -@@ -169,6 +176,12 @@ struct port_bucket *ports_create_bucket (void); - struct port_class *ports_create_class (void (*clean_routine)(void *), - void (*dropweak_routine)(void *)); - -+/* Label CLASS with LABEL. Use DEBUG_INFO to format human-readable -+ information about a given object belonging to CLASS into an buffer, -+ or the default formatting function if DEBUG_INFO is NULL. */ -+void ports_label_class (struct port_class *class, const char *label, -+ error_t (*debug_info) (const void *, char *, size_t)); -+ - /* Create and return in RESULT a new port in CLASS and BUCKET; SIZE bytes - will be allocated to hold the port structure and whatever private data the - user desires. */ -@@ -482,5 +495,7 @@ extern int _ports_flags; - void _ports_complete_deallocate (struct port_info *); - error_t _ports_create_port_internal (struct port_class *, struct port_bucket *, - size_t, void *, int); -+error_t _ports_trace_message (mach_port_t, const mach_msg_header_t *); -+void _ports_start_introspection_server (void); - - #endif -diff --git a/tmpfs/Makefile b/tmpfs/Makefile -index fdcae34..fc27909 100644 ---- a/tmpfs/Makefile -+++ b/tmpfs/Makefile -@@ -23,7 +23,8 @@ target = tmpfs - SRCS = tmpfs.c node.c dir.c pager-stubs.c - OBJS = $(SRCS:.c=.o) default_pagerUser.o - # XXX The shared libdiskfs requires libstore even though we don't use it here. --HURDLIBS = diskfs pager iohelp fshelp store ports ihash shouldbeinlibc -+HURDLIBS = diskfs pager iohelp fshelp store ports ihash introspection \ -+ shouldbeinlibc - OTHERLIBS = -lpthread - - include ../Makeconf --- -2.1.4 - diff --git a/debian/patches/introspection0004-utils-implement-portinfo-query-process.patch b/debian/patches/introspection0004-utils-implement-portinfo-query-process.patch deleted file mode 100644 index a1ae28f0..00000000 --- a/debian/patches/introspection0004-utils-implement-portinfo-query-process.patch +++ /dev/null @@ -1,168 +0,0 @@ -From df374a83a66ceab2167ff10857a59df6bcb8e32c Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Wed, 21 May 2014 17:38:46 +0200 -Subject: [PATCH hurd 4/9] utils: implement portinfo --query-process - -Implement portinfo --query-process (hopefully) as envisaged by a -comment in portinfo.c. We use the new Hurd server introspection -protocol to obtain information about the objects related to ports: - -% utils/portinfo --receive --query-process 5586 77 - 77: receive [bucket: diskfs_port_bucket, class: diskfs_protid_class, - node{inode: 48194, hard: 1, weak: 1}, - path: hello/hurd/developers_:)] - -* libshouldbeinlibc/Makefile (OBJS): Add hurd_portUser.o. -* libshouldbeinlibc/portinfo.c (show_portinfo_query): New function. -(print_port_info): Use show_portinfo_query if desired. -* libshouldbeinlibc/portinfo.h (PORTINFO_QUERY): New macro. -* utils/portinfo.c (argp_option): Drop #if 0. -(parse_opt): Handle --query-process. ---- - libshouldbeinlibc/Makefile | 2 +- - libshouldbeinlibc/portinfo.c | 69 ++++++++++++++++++++++++++++++++++++++++++++ - libshouldbeinlibc/portinfo.h | 1 + - utils/portinfo.c | 3 +- - 4 files changed, 72 insertions(+), 3 deletions(-) - -diff --git a/libshouldbeinlibc/Makefile b/libshouldbeinlibc/Makefile -index 633d60e..a41a879 100644 ---- a/libshouldbeinlibc/Makefile -+++ b/libshouldbeinlibc/Makefile -@@ -36,6 +36,6 @@ installhdrs = idvec.h timefmt.h maptime.h \ - - installhdrsubdir = . - --OBJS = $(SRCS:.c=.o) -+OBJS = $(SRCS:.c=.o) hurd_portUser.o - - include ../Makeconf -diff --git a/libshouldbeinlibc/portinfo.c b/libshouldbeinlibc/portinfo.c -index e6305c6..f99b789 100644 ---- a/libshouldbeinlibc/portinfo.c -+++ b/libshouldbeinlibc/portinfo.c -@@ -17,10 +17,77 @@ - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -+#include <assert.h> -+#include <error.h> -+#include <string.h> - #include <sys/types.h> - #include <sys/mman.h> - - #include "portinfo.h" -+#include "hurd_port_U.h" -+ -+static void -+show_portinfo_query (mach_port_t task, mach_port_t name, -+ unsigned show, FILE *stream) -+{ -+ error_t err; -+ static mach_port_t introspection_port; -+ static mach_port_t for_task; -+ -+ if (task != for_task) -+ { -+ mach_port_t *ports; -+ size_t ports_len; -+ -+ err = mach_ports_lookup (task, &ports, &ports_len); -+ if (! err) -+ { -+ size_t i; -+ if (MACH_PORT_VALID (introspection_port)) -+ mach_port_deallocate (mach_task_self (), introspection_port); -+ -+ for (i = 0; i < ports_len; i++) -+ if (i == HURD_PORT_REGISTER_INTROSPECTION) -+ introspection_port = ports[i]; -+ else -+ { -+ if (MACH_PORT_VALID (ports[i])) -+ mach_port_deallocate (mach_task_self (), ports[i]); -+ } -+ } -+ else -+ introspection_port = MACH_PORT_DEAD; -+ -+ for_task = task; -+ } -+ -+ if (! MACH_PORT_VALID (introspection_port)) -+ return; -+ -+ string_t info; /* XXX */ -+ err = hurd_port_debug_info (introspection_port, name, 100, info); -+ if (err) -+ { -+ if (err != EINVAL) -+ error (0, err, "hurd_port_debug_info"); -+ return; -+ } -+ -+ if (strlen (info) > 0) -+ fprintf (stream, " [%s", info); -+ -+ if (show & PORTINFO_DETAILS) -+ { -+ unsigned int hard, weak; -+ err = hurd_port_get_refcounts (introspection_port, name, 100, -+ &hard, &weak); -+ if (! err) -+ fprintf (stream, ", hard: %u, weak: %u", hard, weak); -+ } -+ -+ fprintf (stream, "]"); -+} -+ - - /* Prints info about NAME in TASK to STREAM, in a way described by the flags - in SHOW. If TYPE is non-zero, it should be what mach_port_type returns -@@ -83,6 +150,8 @@ print_port_info (mach_port_t name, mach_port_type_t type, task_t task, - status.mps_nsrequest ? ", ns-req" : ""); - } - } -+ if (show & PORTINFO_QUERY) -+ show_portinfo_query (task, name, show, stream); - } - if (type & MACH_PORT_TYPE_SEND) - { -diff --git a/libshouldbeinlibc/portinfo.h b/libshouldbeinlibc/portinfo.h -index 143c289..bd96eb8 100644 ---- a/libshouldbeinlibc/portinfo.h -+++ b/libshouldbeinlibc/portinfo.h -@@ -31,6 +31,7 @@ - #define PORTINFO_DETAILS 0x1 - #define PORTINFO_MEMBERS 0x4 - #define PORTINFO_HEX_NAMES 0x8 -+#define PORTINFO_QUERY 0x10 - - /* Prints info about NAME in TASK to STREAM, in a way described by the flags - in SHOW. If TYPE is non-zero, it should be what mach_port_type returns -diff --git a/utils/portinfo.c b/utils/portinfo.c -index 4c40352..27998db 100644 ---- a/utils/portinfo.c -+++ b/utils/portinfo.c -@@ -44,10 +44,8 @@ static const struct argp_option options[] = { - {"verbose", 'v', 0, 0, "Give more detailed information"}, - {"members", 'm', 0, 0, "Show members of port-sets"}, - {"hex-names", 'x', 0, 0, "Show port names in hexadecimal"}, --#if 0 /* XXX implement this */ - {"query-process", 'q', 0, 0, "Query the process itself for the identity of" - " the ports in question -- requires the process be in a sane state"}, --#endif - {"hold", '*', 0, OPTION_HIDDEN}, - - {0,0,0,0, "Selecting which names to show:", 2}, -@@ -249,6 +247,7 @@ main (int argc, char **argv) - case 'v': show |= PORTINFO_DETAILS; break; - case 'm': show |= PORTINFO_MEMBERS; break; - case 'x': show |= PORTINFO_HEX_NAMES; break; -+ case 'q': show |= PORTINFO_QUERY; break; - - case 'r': only |= MACH_PORT_TYPE_RECEIVE; break; - case 's': only |= MACH_PORT_TYPE_SEND; break; --- -2.1.4 - diff --git a/debian/patches/introspection0005-libdiskfs-annotate-objects-managed-by-libports.patch b/debian/patches/introspection0005-libdiskfs-annotate-objects-managed-by-libports.patch deleted file mode 100644 index e2f59631..00000000 --- a/debian/patches/introspection0005-libdiskfs-annotate-objects-managed-by-libports.patch +++ /dev/null @@ -1,107 +0,0 @@ -From 47143cc936848f7b155a476831c6050e64a56d6c Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Wed, 21 May 2014 18:17:33 +0200 -Subject: [PATCH hurd 5/9] libdiskfs: annotate objects managed by libports - -Label all port classes and diskfs_port_bucket. Provide -diskfs_format_debug_info which prints a human-readable description of -a protid object, which notably includes the path and the inode number. - -* libdiskfs/diskfs.h (diskfs_format_debug_info): New declaration. -* libdiskfs/init-init.c (diskfs_format_debug_info): New function. -(diskfs_init_diskfs): Add annotations to classes and bucket. ---- - libdiskfs/diskfs.h | 8 ++++++++ - libdiskfs/init-init.c | 41 ++++++++++++++++++++++++++++++++++++----- - 2 files changed, 44 insertions(+), 5 deletions(-) - -diff --git a/libdiskfs/diskfs.h b/libdiskfs/diskfs.h -index 11fb0ad..c2f97ad 100644 ---- a/libdiskfs/diskfs.h -+++ b/libdiskfs/diskfs.h -@@ -591,6 +591,14 @@ error_t (*diskfs_read_symlink_hook)(struct node *np, char *target); - default function always returns EOPNOTSUPP. */ - error_t diskfs_get_source (struct protid *cred, - char *source, size_t source_len); -+ -+/* The user may define this function. The function must provide a -+ human-readable description of PROTID in BUFFER of size SIZE. The -+ default implementation generates a reasonable amount of -+ information. */ -+error_t diskfs_format_debug_info (const void *protid, -+ char *buffer, size_t size); -+ - - /* Libdiskfs contains a node cache. - -diff --git a/libdiskfs/init-init.c b/libdiskfs/init-init.c -index 357960b..07714f0 100644 ---- a/libdiskfs/init-init.c -+++ b/libdiskfs/init-init.c -@@ -24,6 +24,7 @@ - #include <hurd/fsys.h> - #include <stdio.h> - #include <maptime.h> -+#include <inttypes.h> - - /* For safe inlining of diskfs_node_disknode and - diskfs_disknode_node. */ -@@ -52,6 +53,29 @@ struct port_class *diskfs_shutdown_notification_class; - - struct port_bucket *diskfs_port_bucket; - -+/* Provide a human-readable description of the given protid object. */ -+error_t -+diskfs_format_debug_info (const void *port, char *buffer, size_t size) -+{ -+ const struct protid *protid = port; -+ const struct port_info *pi = port; -+ struct references references; -+ -+ refcounts_references (&protid->po->np->refcounts, &references); -+ -+ snprintf (buffer, size, -+ "bucket: %s, class: %s" -+ ", node{inode: %"PRIu64", hard: %u, weak: %u}, path: %s", -+ pi->bucket->label, -+ pi->class->label, -+ protid->po->np->cache_id, -+ references.hard, -+ references.weak, -+ protid->po->path); -+ -+ return 0; -+} -+ - /* Call this after arguments have been parsed to initialize the - library. */ - error_t -@@ -87,13 +111,20 @@ diskfs_init_diskfs (void) - - diskfs_auth_server_port = getauth (); - -- diskfs_protid_class = ports_create_class (diskfs_protid_rele, 0); -- diskfs_control_class = ports_create_class (_diskfs_control_clean, 0); -- diskfs_initboot_class = ports_create_class (0, 0); -- diskfs_execboot_class = ports_create_class (0, 0); -- diskfs_shutdown_notification_class = ports_create_class (0, 0); -+#define MAKE_CLASS(NAME, FN, ARG, DBG) \ -+ NAME = ports_create_class ((FN), (ARG)); \ -+ ports_label_class (NAME, #NAME, (DBG)) -+ -+ MAKE_CLASS (diskfs_protid_class, diskfs_protid_rele, NULL, -+ diskfs_format_debug_info); -+ MAKE_CLASS (diskfs_control_class, _diskfs_control_clean, NULL, NULL); -+ MAKE_CLASS (diskfs_initboot_class, NULL, NULL, NULL); -+ MAKE_CLASS (diskfs_execboot_class, NULL, NULL, NULL); -+ MAKE_CLASS (diskfs_shutdown_notification_class, NULL, NULL, NULL); -+#undef MAKE_CLASS - - diskfs_port_bucket = ports_create_bucket (); -+ ports_label_bucket (diskfs_port_bucket, "diskfs_port_bucket"); - - _hurd_port_init (&_diskfs_exec_portcell, MACH_PORT_NULL); - --- -2.1.4 - diff --git a/debian/patches/introspection0006-libpager-annotate-objects-managed-by-libports.patch b/debian/patches/introspection0006-libpager-annotate-objects-managed-by-libports.patch deleted file mode 100644 index 4a78a1d9..00000000 --- a/debian/patches/introspection0006-libpager-annotate-objects-managed-by-libports.patch +++ /dev/null @@ -1,61 +0,0 @@ -From 9fdbeaed914893c81a696fe6f745cc2a25b74a9b Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Wed, 21 May 2014 18:33:14 +0200 -Subject: [PATCH hurd 6/9] libpager: annotate objects managed by libports - -Label _pager_class and provide a function which prints a -human-readable description of a pager object. - -* libpager/pager-create.c (format_debug_info): New function. -(create_class): Label _pager_class. ---- - libpager/pager-create.c | 20 ++++++++++++++++++++ - 1 file changed, 20 insertions(+) - -diff --git a/libpager/pager-create.c b/libpager/pager-create.c -index b583f02..422e8f4 100644 ---- a/libpager/pager-create.c -+++ b/libpager/pager-create.c -@@ -15,6 +15,8 @@ - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -+#include <stdio.h> -+ - #include "priv.h" - - /* Create and return a new pager with user info UPI. */ -@@ -50,6 +52,23 @@ pager_create (struct user_pager_info *upi, - return p; - } - -+/* Provide a human-readable description of the given pager object. */ -+static error_t -+format_debug_info (const void *port, char *buffer, size_t size) -+{ -+ const struct pager *pager = port; -+ const struct port_info *pi = port; -+ -+ snprintf (buffer, size, -+ "bucket: %s, class: %s, may_cache: %d", -+ pi->bucket->label, -+ pi->class->label, -+ /* XXX I have no idea what might be interesting to print -+ here, but it is straight forward to add stuff. */ -+ pager->may_cache); -+ -+ return 0; -+} - - /* This causes the function to be run at startup by compiler magic. */ - static void create_class (void) __attribute__ ((constructor)); -@@ -58,5 +77,6 @@ static void - create_class () - { - _pager_class = ports_create_class (_pager_clean, _pager_real_dropweak); -+ ports_label_class (_pager_class, "_pager_class", format_debug_info); - (void) &create_class; /* Avoid warning */ - } --- -2.1.4 - diff --git a/debian/patches/introspection0007-ext2fs-annotate-objects-managed-by-libports.patch b/debian/patches/introspection0007-ext2fs-annotate-objects-managed-by-libports.patch deleted file mode 100644 index 0ff099de..00000000 --- a/debian/patches/introspection0007-ext2fs-annotate-objects-managed-by-libports.patch +++ /dev/null @@ -1,99 +0,0 @@ -From 5dd8bcc1e5f76499b5b4c5274f88d1989c6de7ce Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Wed, 21 May 2014 18:39:38 +0200 -Subject: [PATCH hurd 7/9] ext2fs: annotate objects managed by libports - -Install a specialized version of libpagers format_debug_info which -prints more detailed information, like the nodes inode number for file -pager objects. Also label both pager buckets. - -* ext2fs/pager-create.c (format_debug_info): New function. -(create_disk_pager): Install our own format_debug_info function. -Label both pager buckets. ---- - ext2fs/pager.c | 38 ++++++++++++++++++++++++++++++++++++++ - 1 file changed, 38 insertions(+) - -diff --git a/ext2fs/pager.c b/ext2fs/pager.c -index 3e080f8..b737ba7 100644 ---- a/ext2fs/pager.c -+++ b/ext2fs/pager.c -@@ -19,10 +19,12 @@ - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - - #include <unistd.h> -+#include <stdio.h> - #include <string.h> - #include <errno.h> - #include <error.h> - #include <hurd/store.h> -+#include <inttypes.h> - #include "ext2fs.h" - - /* XXX */ -@@ -1196,6 +1198,38 @@ disk_cache_block_is_ref (block_t block) - return ref; - } - -+/* Provide a human-readable description of the given pager object. */ -+static error_t -+format_debug_info (const void *port, char *buffer, size_t size) -+{ -+ const struct pager *pager = port; -+ const struct port_info *pi = port; -+ -+ if (pager->upi->type == FILE_DATA) -+ { -+ struct references references; -+ refcounts_references (&pager->upi->node->refcounts, &references); -+ snprintf (buffer, size, -+ "bucket: %s, class: %s, " -+ "node{inode: %"PRIu64", hard: %u, weak: %u}", -+ pi->bucket->label, -+ pi->class->label, -+ pager->upi->node->cache_id, -+ references.hard, -+ references.weak); -+ } -+ else -+ snprintf (buffer, size, -+ "bucket: %s, class: %s, may_cache: %d", -+ pi->bucket->label, -+ pi->class->label, -+ /* XXX I have no idea what might be interesting to print -+ here, but it is straight forward to add stuff. */ -+ pager->may_cache); -+ -+ return 0; -+} -+ - /* Create the disk pager, and the file pager. */ - void - create_disk_pager (void) -@@ -1204,12 +1238,15 @@ create_disk_pager (void) - pthread_attr_t attr; - error_t err; - -+ ports_label_class (_pager_class, "_pager_class", format_debug_info); -+ - /* The disk pager. */ - struct user_pager_info *upi = malloc (sizeof (struct user_pager_info)); - if (!upi) - ext2_panic ("can't create disk pager: %s", strerror (errno)); - upi->type = DISK; - disk_pager_bucket = ports_create_bucket (); -+ ports_label_bucket (disk_pager_bucket, "disk_pager_bucket"); - get_hypermetadata (); - disk_cache_blocks = DISK_CACHE_BLOCKS; - disk_cache_size = disk_cache_blocks << log2_block_size; -@@ -1219,6 +1256,7 @@ create_disk_pager (void) - - /* The file pager. */ - file_pager_bucket = ports_create_bucket (); -+ ports_label_bucket (file_pager_bucket, "file_pager_bucket"); - - /* Start libpagers worker threads. */ - err = pager_start_workers (file_pager_bucket, &file_pager_requests); --- -2.1.4 - diff --git a/debian/patches/introspection0008-utils-rpctrace-support-attaching-to-servers.patch b/debian/patches/introspection0008-utils-rpctrace-support-attaching-to-servers.patch deleted file mode 100644 index 2a7967a0..00000000 --- a/debian/patches/introspection0008-utils-rpctrace-support-attaching-to-servers.patch +++ /dev/null @@ -1,372 +0,0 @@ -From 0abf2329d31cb9779a16933414202ee8ccda108b Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Fri, 23 May 2014 08:42:45 +0200 -Subject: [PATCH hurd 8/9] utils/rpctrace: support attaching to servers - -* utils/rpctrace.c (options): Add `--pid' and `--reference-port'. -(print_contents): Prevent the translation of rights if `req' is NULL. -We will use this to print messages in `trace_server'. -(parse_task): New function. -(trace_server): Mach server function that displays relayed messages. -(trace_class_rpcs): New function that attaches to a server and starts -tracing. -(parse_opt): Handle `--pid' and `--reference-port'. -(main): Handle new arguments, call trace_class_rpcs if desired. ---- - utils/Makefile | 5 +- - utils/rpctrace.c | 245 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- - 2 files changed, 247 insertions(+), 3 deletions(-) - -diff --git a/utils/Makefile b/utils/Makefile -index 955789b..352494a 100644 ---- a/utils/Makefile -+++ b/utils/Makefile -@@ -34,7 +34,7 @@ SRCS = shd.c ps.c settrans.c syncfs.c showtrans.c addauth.c rmauth.c \ - nullauth.c match-options.c msgids.c rpcscan.c - - OBJS = $(filter-out %.sh,$(SRCS:.c=.o)) --HURDLIBS = ps ihash store fshelp ports ftpconn shouldbeinlibc -+HURDLIBS = ps ihash store fshelp ports ftpconn shouldbeinlibc introspection - LDLIBS += -lpthread - login-LDLIBS = -lutil -lcrypt - addauth-LDLIBS = -lcrypt -@@ -67,7 +67,8 @@ ps w ids settrans syncfs showtrans fsysopts storeinfo login vmstat portinfo \ - - $(filter-out $(special-targets), $(targets)): %: %.o - --rpctrace: ../libports/libports.a -+rpctrace: ../libports/libports.a \ -+ ../libintrospection/libintrospection.a hurd_portUser.o - rpctrace rpcscan: msgids.o \ - ../libihash/libihash.a - msgids-CPPFLAGS = -DDATADIR=\"${datadir}\" -diff --git a/utils/rpctrace.c b/utils/rpctrace.c -index afe6b6d..666ff08 100644 ---- a/utils/rpctrace.c -+++ b/utils/rpctrace.c -@@ -23,6 +23,7 @@ - #include <hurd.h> - #include <hurd/ports.h> - #include <hurd/ihash.h> -+#include <hurd/introspection.h> - #include <mach/message.h> - #include <assert.h> - #include <fcntl.h> -@@ -40,14 +41,22 @@ - #include <envz.h> - - #include "msgids.h" -+#include "hurd_port_U.h" - - const char *argp_program_version = STANDARD_HURD_VERSION (rpctrace); - - static unsigned strsize = 80; -+static int trace_class; - - static const struct argp_option options[] = - { - {"output", 'o', "FILE", 0, "Send trace output to FILE instead of stderr."}, -+ {"pid", 'p', "PID", 0, "Attach to PID and trace all requests to objects " -+ "of the same class as the given reference port. This will only work " -+ "for Hurd servers implementing the introspection protocol."}, -+ {"port", 'P', "PORT", 0, "Trace all requests PORT. " -+ "PORT must denote a receive right in PID."}, -+ {"class", 'c', NULL, 0, "Trace all requests to the same class as PORT."}, - {0, 's', "SIZE", 0, "Specify the maximum string size to print (the default is 80)."}, - {0, 'E', "var[=value]", 0, - "Set/change (var=value) or remove (var) an environment variable among the " -@@ -852,7 +861,7 @@ print_contents (mach_msg_header_t *inp, - what task that port name is meaningful in. If it's meaningful in - a traced task, then it refers to our intercepting port rather than - the original port anyway. */ -- if (MACH_MSG_TYPE_PORT_ANY_RIGHT (name)) -+ if (MACH_MSG_TYPE_PORT_ANY_RIGHT (name) && req != NULL) - { - /* These are port rights. Translate them into wrappers. */ - mach_port_t *const portnames = data; -@@ -1673,10 +1682,217 @@ traced_spawn (char **argv, char **envp) - - return pid; - } -+ -+/* Return the task corresponding to the user argument ARG, exiting with an -+ appriate error message if we can't. */ -+static task_t -+parse_task (char *arg) -+{ -+ error_t err; -+ task_t task; -+ char *arg_end; -+ pid_t pid = strtoul (arg, &arg_end, 10); -+ static process_t proc = MACH_PORT_NULL; -+ -+ if (*arg == '\0' || *arg_end != '\0') -+ error (10, 0, "%s: Invalid process id", arg); -+ -+ if (proc == MACH_PORT_NULL) -+ proc = getproc (); -+ -+ err = proc_pid2task (proc, pid, &task); -+ if (err) -+ error (11, err, "%s", arg); -+ else if (task == MACH_PORT_NULL) -+ error (11, 0, "%s: Process %d is dead and has no task", arg, (int) pid); -+ -+ return task; -+} -+ -+static mach_port_t trace_notification_port; -+static mach_port_t reference_port; -+ -+boolean_t -+trace_server (mach_msg_header_t *inp, -+ mach_msg_header_t *outp) -+{ -+ error_t err; -+ static struct hurd_ihash ongoing_requests = -+ HURD_IHASH_INITIALIZER (HURD_IHASH_NO_LOCP); -+ struct msgid_info *info; -+ mach_port_t trace_id; -+ int is_reply; -+ -+ if (inp->msgh_local_port == trace_notification_port -+ && inp->msgh_id == MACH_NOTIFY_NO_SENDERS) -+ { -+ error (0, 0, "The tracee vanished."); -+ exit (EXIT_SUCCESS); -+ } -+ -+ err = introspection_extract_message (inp, &trace_id); -+ if (err) -+ { -+ error (0, err, "introspection_extract_message"); -+ goto out; -+ } -+ info = msgid_info (inp->msgh_id); -+ -+ /* XXX This hardcodes an assumption about reply message ids. */ -+ is_reply = (inp->msgh_id / 100) % 2 == 1; -+ if (is_reply) -+ { -+ /* This looks like a traced reply or a pseudo-reply. A -+ pseudo-reply is a message containing the result of a simple -+ procedure that is only sent to us. */ -+ mig_reply_header_t *reply = (mig_reply_header_t *) inp; -+ -+ mach_port_t request_port; -+ request_port = hurd_ihash_find (&ongoing_requests, trace_id); -+ if (! MACH_PORT_VALID (request_port)) -+ { -+ fprintf (stderr, "unsolicited reply packet with id: %d\n", -+ trace_id); -+ goto out; -+ } -+ hurd_ihash_remove (&ongoing_requests, trace_id); -+ -+ if (! (trace_class || request_port == reference_port)) -+ goto out; -+ -+ if (last_reply_port != trace_id) -+ { -+ print_ellipsis (); -+ fprintf (ostream, "%u...", (unsigned int) trace_id); -+ } -+ last_reply_port = MACH_PORT_NULL; -+ -+ fprintf (ostream, " = "); -+ -+ if (reply->RetCode == 0) -+ fprintf (ostream, "0"); -+ else -+ { -+ const char *str = strerror (reply->RetCode); -+ if (str == 0) -+ fprintf (ostream, "%#x", reply->RetCode); -+ else -+ fprintf (ostream, "%#x (%s)", reply->RetCode, str); -+ } -+ -+ if (inp->msgh_size > sizeof *reply) -+ { -+ fprintf (ostream, " "); -+ print_contents (inp, (void *) inp + sizeof *reply, NULL); -+ } -+ fprintf (ostream, "\n"); -+ } -+ else -+ { -+ /* Remember the request port. */ -+ hurd_ihash_add (&ongoing_requests, trace_id, inp->msgh_local_port); -+ -+ if (! (trace_class || inp->msgh_local_port == reference_port)) -+ goto out; -+ -+ /* This looks like a traced request. */ -+ print_ellipsis (); -+ last_reply_port = trace_id; -+ -+ if (info) -+ fprintf (ostream, "% 4d->%s (", inp->msgh_local_port, info->name); -+ else -+ fprintf (ostream, "% 4d->%d (", inp->msgh_local_port, inp->msgh_id); -+ -+ print_contents (inp, (void *) inp + sizeof *inp, NULL); -+ fprintf (ostream, ")"); -+ } -+ -+ out: -+ /* vm_deallocate any out-of-band memory. */ -+ mach_msg_destroy (inp); -+ -+ /* Prevent mach_msg_server from sending messages. */ -+ ((mig_reply_header_t *) outp)->RetCode = MIG_NO_REPLY; -+ return TRUE; -+} -+ -+int -+trace_class_rpcs (mach_port_t task, -+ mach_port_t name) -+{ -+ error_t err; -+ mach_port_t trace_port; -+ mach_port_t introspection_port; -+ mach_port_t previous; -+ mach_port_t port_set; -+ -+ err = introspection_get_port (task, &introspection_port); -+ if (err) -+ error (13, err, "Failed to get introspection port"); -+ -+ if (! MACH_PORT_VALID (introspection_port)) -+ error (13, 0, "The server does not implement the introspection protocol"); -+ -+ err = mach_port_allocate (mach_task_self (), MACH_PORT_RIGHT_RECEIVE, -+ &trace_port); -+ if (err) -+ error (13, err, "mach_port_allocate"); -+ -+ err = hurd_port_trace_class_rpcs (introspection_port, name, -+ trace_port, MACH_MSG_TYPE_MAKE_SEND); -+ if (err) -+ { -+ if (err == EINVAL) -+ error (13, 0, -+ "%d does not denote a receive right managed by libports", name); -+ else -+ error (13, err, "hurd_port_trace_class_rpcs"); -+ } -+ -+ err = mach_port_allocate (mach_task_self (), MACH_PORT_RIGHT_RECEIVE, -+ &trace_notification_port); -+ if (err) -+ error (13, err, "mach_port_allocate"); -+ -+ err = mach_port_request_notification (mach_task_self (), -+ trace_port, -+ MACH_NOTIFY_NO_SENDERS, -+ 0, -+ trace_notification_port, -+ MACH_MSG_TYPE_MAKE_SEND_ONCE, -+ &previous); -+ if (err) -+ error (13, err, "mach_port_request_notification"); -+ assert (! MACH_PORT_VALID (previous)); -+ -+ -+ err = mach_port_allocate (mach_task_self (), MACH_PORT_RIGHT_PORT_SET, -+ &port_set); -+ if (err) -+ error (13, err, "mach_port_allocate"); -+ -+ err = mach_port_move_member (mach_task_self (), trace_port, port_set); -+ if (err) -+ error (13, err, "mach_port_move_member"); - -+ err = mach_port_move_member (mach_task_self (), trace_notification_port, -+ port_set); -+ if (err) -+ error (13, err, "mach_port_move_member"); -+ -+ error (0, 0, "entering service loop"); -+ while (1) -+ mach_msg_server (trace_server, 0, port_set); -+ -+ /* Not reached. */ -+ return 0; -+} -+ - int - main (int argc, char **argv, char **envp) - { -+ mach_port_t target_task = MACH_PORT_NULL; - const char *outfile = 0; - char **cmd_argv = 0; - pthread_t thread; -@@ -1688,12 +1904,27 @@ main (int argc, char **argv, char **envp) - /* Parse our options... */ - error_t parse_opt (int key, char *arg, struct argp_state *state) - { -+ char *arg_end; - switch (key) - { - case 'o': - outfile = arg; - break; - -+ case 'p': -+ target_task = parse_task (arg); -+ break; -+ -+ case 'P': -+ reference_port = strtoul (arg, &arg_end, 10); -+ if (*arg == '\0' || *arg_end != '\0') -+ argp_error (state, "Invalid port name: %s", arg); -+ break; -+ -+ case 'c': -+ trace_class = 1; -+ break; -+ - case 's': - strsize = atoi (arg); - break; -@@ -1727,10 +1958,16 @@ main (int argc, char **argv, char **envp) - break; - - case ARGP_KEY_NO_ARGS: -+ if (MACH_PORT_VALID (target_task)) -+ break; -+ - argp_usage (state); - return EINVAL; - - case ARGP_KEY_ARG: -+ if (MACH_PORT_VALID (target_task)) -+ argp_error (state, "Superfluous argument: %s", arg); -+ - cmd_argv = &state->argv[state->next - 1]; - state->next = state->argc; - break; -@@ -1750,6 +1987,9 @@ main (int argc, char **argv, char **envp) - /* Parse our arguments. */ - argp_parse (&argp, argc, argv, ARGP_IN_ORDER, 0, 0); - -+ if (MACH_PORT_VALID (target_task) != MACH_PORT_VALID (reference_port)) -+ error (10, 0, "Please specify either both -p and -P, or neither."); -+ - err = mach_port_allocate (mach_task_self (), MACH_PORT_RIGHT_DEAD_NAME, - &unknown_task); - assert_perror (err); -@@ -1764,6 +2004,9 @@ main (int argc, char **argv, char **envp) - ostream = stderr; - setlinebuf (ostream); - -+ if (MACH_PORT_VALID (target_task)) -+ return trace_class_rpcs (target_task, reference_port); -+ - traced_bucket = ports_create_bucket (); - traced_class = ports_create_class (&traced_clean, NULL); - other_class = ports_create_class (0, 0); --- -2.1.4 - diff --git a/debian/patches/introspection0009-pflocal-annotate-objects-managed-by-libports.patch b/debian/patches/introspection0009-pflocal-annotate-objects-managed-by-libports.patch deleted file mode 100644 index 55147683..00000000 --- a/debian/patches/introspection0009-pflocal-annotate-objects-managed-by-libports.patch +++ /dev/null @@ -1,73 +0,0 @@ -From 12cf4cc389aad578a86d0891ab57d31250fc1d65 Mon Sep 17 00:00:00 2001 -From: Justus Winter <4winter@informatik.uni-hamburg.de> -Date: Sun, 27 Sep 2015 16:49:32 +0200 -Subject: [PATCH hurd 9/9] pflocal: annotate objects managed by libports - -Label buckets and classes, and provide functions to print a -human-readable description of the in use objects. - -* pflocal/sock.c (sock_user_debug_info): New function. -(addr_debug_info): Likewise. -(sock_global_init): Label bucket and classes. ---- - pflocal/sock.c | 28 ++++++++++++++++++++++++++++ - 1 file changed, 28 insertions(+) - -diff --git a/pflocal/sock.c b/pflocal/sock.c -index ef70d2c..c02163a 100644 ---- a/pflocal/sock.c -+++ b/pflocal/sock.c -@@ -181,6 +181,18 @@ sock_user_clean (void *vuser) - sock_deref (user->sock); - } - -+/* Provide a human-readable description of the given sock_user object. */ -+static error_t -+sock_user_debug_info (const void *vuser, char *buffer, size_t size) -+{ -+ struct sock_user *user = vuser; -+ snprintf (buffer, size, -+ "bucket: %s, class: %s, sock{refs: %d}", -+ user->pi.bucket->label, user->pi.class->label, -+ user->sock->refs); -+ return 0; -+} -+ - /* Return a new user port on SOCK in PORT. */ - error_t - sock_create_port (struct sock *sock, mach_port_t *port) -@@ -252,6 +264,17 @@ addr_clean (void *vaddr) - assert (addr->sock == NULL); - } - -+/* Provide a human-readable description of the given sock_user object. */ -+static error_t -+addr_debug_info (const void *vaddr, char *buffer, size_t size) -+{ -+ struct addr *addr = vaddr; -+ snprintf (buffer, size, -+ "bucket: %s, class: %s", -+ addr->pi.bucket->label, addr->pi.class->label); -+ return 0; -+} -+ - /* Return a new address, not connected to any socket yet, ADDR. */ - inline error_t - addr_create (struct addr **addr) -@@ -491,8 +514,13 @@ error_t - sock_global_init () - { - sock_port_bucket = ports_create_bucket (); -+ ports_label_bucket (sock_port_bucket, "sock_port_bucket"); - sock_user_port_class = ports_create_class (sock_user_clean, NULL); -+ ports_label_class (sock_user_port_class, "sock_user_port_class", -+ sock_user_debug_info); - addr_port_class = ports_create_class (addr_clean, addr_unbind); -+ ports_label_class (addr_port_class, "addr_port_class", -+ addr_debug_info); - return 0; - } - --- -2.1.4 - diff --git a/debian/patches/series b/debian/patches/series index 8288e73d..8b4fa423 100644 --- a/debian/patches/series +++ b/debian/patches/series @@ -33,15 +33,6 @@ exec_filename0001-Add-a-new-exec_exec_file_name-RPC.patch exec_filename0002-Add-a-file_exec_file_name-RPC.patch exec_filename0003-Use-the-new-_hurd_exec_file_name-function.patch exec_filename0004-This-patch-is-an-amendment-of-exec_filename_exec.pat.patch -introspection0001-hurd-add-an-Hurd-server-introspection-protocol.patch -introspection0002-libintrospection-a-library-for-Hurd-server-introspec.patch -introspection0003-libports-implement-the-Hurd-server-introspection-pro.patch -introspection0004-utils-implement-portinfo-query-process.patch -introspection0005-libdiskfs-annotate-objects-managed-by-libports.patch -introspection0006-libpager-annotate-objects-managed-by-libports.patch -introspection0007-ext2fs-annotate-objects-managed-by-libports.patch -introspection0008-utils-rpctrace-support-attaching-to-servers.patch -introspection0009-pflocal-annotate-objects-managed-by-libports.patch ihash-as-cache0001-libihash-fix-ill-devised-locp-lookup-interface.patch ihash-as-cache0002-libihash-fix-fast-insertion-corner-case.patch ihash-as-cache0003-libihash-generalize-the-interface-to-support-non-int.patch diff --git a/devnode/ChangeLog b/devnode/ChangeLog deleted file mode 100644 index 54ae55f4..00000000 --- a/devnode/ChangeLog +++ /dev/null @@ -1,34 +0,0 @@ -2008-09-26 Zheng Da <zhengda1936@gmail.com> - - * README: Update. - - * devnode.c (args_doc): New variable. - (options): Remove '-d' and change the description of '-n'. - (parse_opt): Get the device in ARGP_KEY_ARG instead of from '-d'. - (main): Set args_doc to the field of argp. - -2008-08-28 Zheng Da <zhengda1936@gmail.com> - - * devnode.c (ds_device_open): Return the error instead of stopping the - translator. - -2008-08-20 Zheng Da <zhengda1936@gmail.com> - - * devnode.c (ds_device_open): Test device_name before using it. - - * util.h (DEBUG): Remove the macro. - -2008-08-18 Zheng Da <zhengda1936@gmail.com> - - * README: New file. - - * devnode.c (options): Replace the option '-i' with '-d'. - (parse_opt): Handle the option '-d'. - -2008-08-17 Zheng Da <zhengda1936@gmail.com> - - * Makefile: New file. - - * util.h: New file. - - * devnode.c: New file. diff --git a/devnode/Makefile b/devnode/Makefile deleted file mode 100644 index 9529fa7b..00000000 --- a/devnode/Makefile +++ /dev/null @@ -1,30 +0,0 @@ -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 2008 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. - -dir := devnode -makemode := server - -SRCS = devnode.c -LCLHDRS = util.h -HURDLIBS = ports trivfs fshelp shouldbeinlibc -target = devnode -MIGSTUBS = deviceServer.o notifyServer.o -MIGSFLAGS = -imacros $(srcdir)/mig-mutate.h -device-MIGSFLAGS="-DMACH_PAYLOAD_TO_PORT=ports_payload_get_name" -OBJS = $(SRCS:.c=.o) $(MIGSTUBS) - -include ../Makeconf diff --git a/devnode/README b/devnode/README deleted file mode 100644 index 90ca27cc..00000000 --- a/devnode/README +++ /dev/null @@ -1,25 +0,0 @@ -[Introduction] - -devnode is a translator that creates the device file for the kernel device. It provides another way for other programs to open the kernel device. -The device file should be created in /dev with the device name as its file name, so clients can find the device file easily. -Clients need to get the port to the devnode translator by calling file_name_lookup() and uses this port as a master device port to open the device by calling device_open(). The device name used in device_open() is specified by '-n' option of devnode. - - -[Usage] - -Usage: devnode [OPTION...] device -Hurd devnode translator. - - -n, --name=DEVICENAME Accept open from clients only with DEVICENAME - -M, --master_device=FILE Get a pseudo master device port - -?, --help Give this help list - --usage Give a short usage message - -V, --version Print program version - -The '-n' option specifies the device name used by clients in device_open(). It can be optional. If it's specified, clients must use the name to open the device. Otherwise, every device name used by clients in device_open() is acceptable. -The '-M' option specifies the file where devnode can get the master device port. This option can be useful to open the virtual interface created by eth-multiplexer, for example. - - -[Internal] - -devnode is very simple. It implements the server side functions in device.defs, so it can receive the request of opening a device from clients. Only ds_device_open is actually implemented, which opens the device and returns the port to the device. Normally, devnode shouldn't get other requests. diff --git a/devnode/devnode.c b/devnode/devnode.c deleted file mode 100644 index 6ec8a654..00000000 --- a/devnode/devnode.c +++ /dev/null @@ -1,359 +0,0 @@ -/* - Copyright (C) 2008 Free Software Foundation, Inc. - Written by Zheng Da. - - 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. */ - -/* - * This program is a translator that sits on the top of the network - * interface and helps socket servers open the interface. - */ - -#include <argp.h> -#include <argz.h> -#include <errno.h> -#include <error.h> -#include <stddef.h> -#include <fcntl.h> - -#include <hurd.h> -#include <mach.h> -#include <device/device.h> -#include <hurd/trivfs.h> -#include <hurd/ports.h> -#include <version.h> - -#include "device_S.h" -#include "notify_S.h" -#include "util.h" - -/* The name of the network interface that the translator sits on. */ -static char *device_name; -/* The device name used by the socket servers. */ -static char *user_device_name; -static char *master_file; -/* The master device port for opening the interface. */ -static mach_port_t master_device; - -const char *argp_program_version = STANDARD_HURD_VERSION (devnode); - -static const char args_doc[] = "device"; -static const char doc[] = "Hurd devnode translator."; -static const struct argp_option options[] = -{ - {"name", 'n', "DEVICENAME", 0, - "Define the device name used by clients in device_open()", 2}, - {"master-device", 'M', "FILE", 0, - "Get a pseudo master device port", 3}, - {0} -}; - -/* Port bucket we service requests on. */ -struct port_bucket *port_bucket; - -/* Trivfs hooks. */ -int trivfs_fstype = FSTYPE_MISC; -int trivfs_fsid = 0; -int trivfs_support_read = 0; -int trivfs_support_write = 0; -int trivfs_support_exec = 0; -int trivfs_allow_open = O_READ | O_WRITE; - -/* Our port classes. */ -struct port_class *trivfs_protid_class; -struct port_class *trivfs_cntl_class; - -static int -devnode_demuxer (mach_msg_header_t *inp, - mach_msg_header_t *outp) -{ - mig_routine_t routine; - if ((routine = device_server_routine (inp)) || - (routine = notify_server_routine (inp)) || - (routine = NULL, trivfs_demuxer (inp, outp))) - { - if (routine) - (*routine) (inp, outp); - return TRUE; - } - else - return FALSE; -} - -/* Implementation of notify interface */ -kern_return_t -do_mach_notify_port_deleted (struct port_info *pi, - mach_port_t name) -{ - return EOPNOTSUPP; -} - -kern_return_t -do_mach_notify_msg_accepted (struct port_info *pi, - mach_port_t name) -{ - return EOPNOTSUPP; -} - -kern_return_t -do_mach_notify_port_destroyed (struct port_info *pi, - mach_port_t port) -{ - return EOPNOTSUPP; -} - -kern_return_t -do_mach_notify_no_senders (struct port_info *pi, - mach_port_mscount_t mscount) -{ - return ports_do_mach_notify_no_senders (pi, mscount); -} - -kern_return_t -do_mach_notify_send_once (struct port_info *pi) -{ - return EOPNOTSUPP; -} - -kern_return_t -do_mach_notify_dead_name (struct port_info *pi, - mach_port_t name) -{ - return EOPNOTSUPP; -} - -/* Implementation of device interface */ -kern_return_t -ds_device_open (mach_port_t master_port, mach_port_t reply_port, - mach_msg_type_name_t reply_portPoly, - dev_mode_t mode, dev_name_t name, mach_port_t *device, - mach_msg_type_name_t *devicetype) -{ - error_t err; - - debug ("ds_device_open is called\n"); - - if ((user_device_name && strcmp (user_device_name, name)) - || device_name == NULL) - return D_NO_SUCH_DEVICE; - - if (master_file != NULL) - { - if (master_device != MACH_PORT_NULL) - mach_port_deallocate (mach_task_self (), master_device); - - master_device = file_name_lookup (master_file, 0, 0); - if (master_device == MACH_PORT_NULL) - error (1, errno, "file_name_lookup"); - } - - err = device_open (master_device, mode, device_name, device); - *devicetype = MACH_MSG_TYPE_MOVE_SEND; - return err; -} - -kern_return_t -ds_device_close (device_t device) -{ - return D_INVALID_OPERATION; -} - -kern_return_t -ds_device_write (device_t device, mach_port_t reply_port, - mach_msg_type_name_t reply_type, dev_mode_t mode, - recnum_t recnum, io_buf_ptr_t data, size_t datalen, - int *bytes_written) -{ - return D_INVALID_OPERATION; -} - -kern_return_t -ds_device_write_inband (device_t device, mach_port_t reply_port, - mach_msg_type_name_t reply_type, dev_mode_t mode, - recnum_t recnum, io_buf_ptr_inband_t data, - size_t datalen, int *bytes_written) -{ - return D_INVALID_OPERATION; -} - -kern_return_t -ds_device_read (device_t device, mach_port_t reply_port, - mach_msg_type_name_t reply_type, dev_mode_t mode, - recnum_t recnum, int bytes_wanted, - io_buf_ptr_t *data, size_t *datalen) -{ - return D_INVALID_OPERATION; -} - -kern_return_t -ds_device_read_inband (device_t device, mach_port_t reply_port, - mach_msg_type_name_t reply_type, dev_mode_t mode, - recnum_t recnum, int bytes_wanted, - io_buf_ptr_inband_t data, size_t *datalen) -{ - return D_INVALID_OPERATION; -} - -kern_return_t -ds_device_map (device_t device, vm_prot_t prot, vm_offset_t offset, - vm_size_t size, memory_object_t *pager, int unmap) -{ - return D_INVALID_OPERATION; -} - -kern_return_t -ds_device_set_status (device_t device, dev_flavor_t flavor, - dev_status_t status, size_t statuslen) -{ - return D_INVALID_OPERATION; -} - -kern_return_t -ds_device_get_status (device_t device, dev_flavor_t flavor, - dev_status_t status, size_t *statuslen) -{ - return D_INVALID_OPERATION; -} - -kern_return_t -ds_device_set_filter (device_t device, mach_port_t receive_port, - int priority, filter_array_t filter, size_t filterlen) -{ - return D_INVALID_OPERATION; -} - -error_t -trivfs_append_args (struct trivfs_control *fsys, char **argz, size_t *argz_len) -{ - error_t err = 0; - -#define ADD_OPT(fmt, args...) \ - do { char buf[100]; \ - if (! err) { \ - snprintf (buf, sizeof buf, fmt , ##args); \ - err = argz_add (argz, argz_len, buf); } } while (0) - - if (user_device_name) - ADD_OPT ("--name=%s", user_device_name); - if (master_file) - ADD_OPT ("--master-device=%s", master_file); - - ADD_OPT ("%s", device_name); - -#undef ADD_OPT - return err; -} - -void -trivfs_modify_stat (struct trivfs_protid *cred, io_statbuf_t *stat) -{ -} - -error_t -trivfs_goaway (struct trivfs_control *fsys, int flags) -{ - int count; - - /* Stop new requests. */ - ports_inhibit_class_rpcs (trivfs_cntl_class); - ports_inhibit_class_rpcs (trivfs_protid_class); - - count = ports_count_class (trivfs_protid_class); - debug ("the number of ports alive: %d\n", count); - - if (count && !(flags & FSYS_GOAWAY_FORCE)) - { - /* We won't go away, so start things going again... */ - ports_enable_class (trivfs_protid_class); - ports_resume_class_rpcs (trivfs_cntl_class); - ports_resume_class_rpcs (trivfs_protid_class); - return EBUSY; - } - - mach_port_deallocate (mach_task_self (), master_device); - debug ("the translator is gone away\n"); - exit (0); -} - -static error_t -parse_opt (int opt, char *arg, struct argp_state *state) -{ - switch (opt) - { - case 'M': - master_file = arg; - master_device = file_name_lookup (arg, 0, 0); - if (master_device == MACH_PORT_NULL) - error (1, errno, "file_name_lookup"); - break; - case 'n': - user_device_name = arg; - break; - case ARGP_KEY_ARG: - device_name = arg; - break; - case ARGP_KEY_ERROR: - case ARGP_KEY_SUCCESS: - case ARGP_KEY_INIT: - break; - default: - return ARGP_ERR_UNKNOWN; - } - return 0; -} - -int -main (int argc, char *argv[]) -{ - error_t err; - mach_port_t bootstrap; - struct trivfs_control *fsys; - const struct argp argp = { options, parse_opt, args_doc, doc }; - - port_bucket = ports_create_bucket (); - trivfs_cntl_class = ports_create_class (trivfs_clean_cntl, 0); - trivfs_protid_class = ports_create_class (trivfs_clean_protid, 0); - - argp_parse (&argp, argc, argv, 0, 0, 0); - - task_get_bootstrap_port (mach_task_self (), &bootstrap); - if (bootstrap == MACH_PORT_NULL) - error (1, 0, "must be started as a translator"); - - if (master_device == MACH_PORT_NULL) - { - err = get_privileged_ports (0, &master_device); - if (err) - error (1, err, "get_privileged_ports"); - } - - /* Reply to our parent. */ - err = trivfs_startup (bootstrap, 0, - trivfs_cntl_class, port_bucket, - trivfs_protid_class, port_bucket, &fsys); - mach_port_deallocate (mach_task_self (), bootstrap); - if (err) - error (1, err, "Contacting parent"); - - /* Launch. */ - do - { - ports_manage_port_operations_one_thread (port_bucket, - devnode_demuxer, 0); - } while (trivfs_goaway (fsys, 0)); - return 0; -} diff --git a/devnode/mig-mutate.h b/devnode/mig-mutate.h deleted file mode 100644 index 0656014f..00000000 --- a/devnode/mig-mutate.h +++ /dev/null @@ -1,27 +0,0 @@ -/* - 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 <http://www.gnu.org/licenses/>. */ - -#define NOTIFY_INTRAN \ - port_info_t begin_using_port_info_port (mach_port_t) -#define NOTIFY_INTRAN_PAYLOAD \ - port_info_t begin_using_port_info_payload -#define NOTIFY_DESTRUCTOR \ - end_using_port_info (port_info_t) -#define NOTIFY_IMPORTS \ - import "libports/mig-decls.h"; diff --git a/devnode/util.h b/devnode/util.h deleted file mode 100644 index 2efc1ef5..00000000 --- a/devnode/util.h +++ /dev/null @@ -1,42 +0,0 @@ -/* - Copyright (C) 2008 Free Software Foundation, Inc. - Written by Zheng Da. - - 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. */ - -#ifndef UTIL_H -#define UTIL_H - -#include <stdio.h> - -#ifdef DEBUG - -#define debug(format, ...) do \ -{ \ - char buf[1024]; \ - snprintf (buf, 1024, "devnode: %s", format); \ - fprintf (stderr , buf, ## __VA_ARGS__); \ - fflush (stderr); \ -} while (0) - -#else - -#define debug(format, ...) do {} while (0) - -#endif - -#endif diff --git a/libhurd-slab/Makefile b/libhurd-slab/Makefile deleted file mode 100644 index 925f70c1..00000000 --- a/libhurd-slab/Makefile +++ /dev/null @@ -1,33 +0,0 @@ -# -# Copyright (C) 1994,95,96,97,98,99,2000,01,02,2005 Free Software Foundation, Inc. -# -# This program 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. -# -# This program 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 := libhurd-slab -makemode := library - -libname = libhurd-slab -SRCS= slab.c -LCLHDRS = slab.h -installhdrs = slab.h - -MIGSTUBS = -OBJS = $(sort $(SRCS:.c=.o) $(MIGSTUBS)) - -OTHERLIBS = -lpthread - -MIGCOMSFLAGS = - -include ../Makeconf diff --git a/libhurd-slab/slab.c b/libhurd-slab/slab.c deleted file mode 100644 index 5a12a43a..00000000 --- a/libhurd-slab/slab.c +++ /dev/null @@ -1,518 +0,0 @@ -/* Copyright (C) 2003, 2005 Free Software Foundation, Inc. - Written by Johan Rydberg. - - This file is part of the GNU Hurd. - - This program is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This program 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 - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this program; if not, write to the Free - Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA - 02111-1307 USA. */ - -#if HAVE_CONFIG_H -#include <config.h> -#endif - -#include <stdlib.h> -#include <errno.h> -#include <sys/mman.h> -#include <assert.h> -#include <string.h> -#include <unistd.h> -#include <pthread.h> -#include <stdint.h> - -#include "slab.h" - -#define SLAB_PAGES 4 - - -/* Number of pages the slab allocator has allocated. */ -static int __hurd_slab_nr_pages; - - -/* Buffer control structure. Lives at the end of an object. If the - buffer is allocated, SLAB points to the slab to which it belongs. - If the buffer is free, NEXT points to next buffer on free list. */ -union hurd_bufctl -{ - union hurd_bufctl *next; - struct hurd_slab *slab; -}; - - -/* When the allocator needs to grow a cache, it allocates a slab. A - slab consists of one or more pages of memory, split up into equally - sized chunks. */ -struct hurd_slab -{ - struct hurd_slab *next; - struct hurd_slab *prev; - - /* The reference counter holds the number of allocated chunks in - the slab. When the counter is zero, all chunks are free and - the slab can be relinquished. */ - int refcount; - - /* Single linked list of free buffers in the slab. */ - union hurd_bufctl *free_list; -}; - -/* Allocate a buffer in *PTR of size SIZE which must be a power of 2 - and self aligned (i.e. aligned on a SIZE byte boundary) for slab - space SPACE. Return 0 on success, an error code on failure. */ -static error_t -allocate_buffer (struct hurd_slab_space *space, size_t size, void **ptr) -{ - if (space->allocate_buffer) - return space->allocate_buffer (space->hook, size, ptr); - else - { - *ptr = mmap (NULL, size, PROT_READ|PROT_WRITE, - MAP_PRIVATE|MAP_ANONYMOUS, 0, 0); - if (*ptr == MAP_FAILED) - return errno; - else - return 0; - } -} - -/* Deallocate buffer BUFFER of size SIZE which was allocated for slab - space SPACE. Return 0 on success, an error code on failure. */ -static error_t -deallocate_buffer (struct hurd_slab_space *space, void *buffer, size_t size) -{ - if (space->deallocate_buffer) - return space->deallocate_buffer (space->hook, buffer, size); - else - { - if (munmap (buffer, size) == -1) - return errno; - else - return 0; - } -} - -/* Insert SLAB into the list of slabs in SPACE. SLAB is expected to - be complete (so it will be inserted at the end). */ -static void -insert_slab (struct hurd_slab_space *space, struct hurd_slab *slab) -{ - assert (slab->refcount == 0); - if (space->slab_first == 0) - space->slab_first = space->slab_last = slab; - else - { - space->slab_last->next = slab; - slab->prev = space->slab_last; - space->slab_last = slab; - } -} - - -/* Remove SLAB from list of slabs in SPACE. */ -static void -remove_slab (struct hurd_slab_space *space, struct hurd_slab *slab) -{ - if (slab != space->slab_first - && slab != space->slab_last) - { - slab->next->prev = slab->prev; - slab->prev->next = slab->next; - return; - } - if (slab == space->slab_first) - { - space->slab_first = slab->next; - if (space->slab_first) - space->slab_first->prev = NULL; - } - if (slab == space->slab_last) - { - if (slab->prev) - slab->prev->next = NULL; - space->slab_last = slab->prev; - } -} - - -/* Iterate through slabs in SPACE and release memory for slabs that - are complete (no allocated buffers). */ -static error_t -reap (struct hurd_slab_space *space) -{ - struct hurd_slab *s, *next, *new_first; - error_t err = 0; - - for (s = space->slab_first; s; s = next) - { - next = s->next; - - /* If the reference counter is zero there is no allocated - buffers, so it can be freed. */ - if (!s->refcount) - { - remove_slab (space, s); - - /* If there is a destructor it must be invoked for every - buffer in the slab. */ - if (space->destructor) - { - union hurd_bufctl *bufctl; - for (bufctl = s->free_list; bufctl; bufctl = bufctl->next) - { - void *buffer = (((void *) bufctl) - - (space->size - sizeof *bufctl)); - (*space->destructor) (space->hook, buffer); - } - } - /* The slab is located at the end of the page (with the buffers - in front of it), get address by masking with page size. - This frees the slab and all its buffers, since they live on - the same page. */ - err = deallocate_buffer (space, (void *) (((uintptr_t) s) - + sizeof (struct hurd_slab) - - space->slab_size), - space->slab_size); - if (err) - break; - __hurd_slab_nr_pages--; - } - } - - /* Even in the case of an error, first_free must be updated since - that slab may have been deallocated. */ - new_first = space->slab_first; - while (new_first) - { - if (new_first->refcount != space->full_refcount) - break; - new_first = new_first->next; - } - space->first_free = new_first; - - return err; -} - - -/* Initialize slab space SPACE. */ -static void -init_space (hurd_slab_space_t space) -{ - size_t size = space->requested_size + sizeof (union hurd_bufctl); - size_t alignment = space->requested_align; - - /* If SIZE is so big that one object can not fit into a page - something gotta be really wrong. */ - size = (size + alignment - 1) & ~(alignment - 1); - assert (size <= (space->slab_size - - sizeof (struct hurd_slab) - - sizeof (union hurd_bufctl))); - - space->size = size; - - /* Number of objects that fit into one page. Used to detect when - there are no free objects left in a slab. */ - space->full_refcount - = ((space->slab_size - sizeof (struct hurd_slab)) / size); - - /* FIXME: Notify pager's reap functionality about this slab - space. */ - - space->initialized = true; -} - - -/* SPACE has no more memory. Allocate new slab and insert it into the - list, repoint free_list and return possible error. */ -static error_t -grow (struct hurd_slab_space *space) -{ - error_t err; - struct hurd_slab *new_slab; - union hurd_bufctl *bufctl; - int nr_objs, i; - void *p; - - /* If the space has not yet been initialized this is the place to do - so. It is okay to test some fields such as first_free prior to - initialization since they will be a null pointer in any case. */ - if (!space->initialized) - init_space (space); - - err = allocate_buffer (space, space->slab_size, &p); - if (err) - return err; - - __hurd_slab_nr_pages++; - - new_slab = (p + space->slab_size - sizeof (struct hurd_slab)); - memset (new_slab, 0, sizeof (*new_slab)); - - /* Calculate the number of objects that the page can hold. - SPACE->size should be adjusted to handle alignment. */ - nr_objs = ((space->slab_size - sizeof (struct hurd_slab)) - / space->size); - - for (i = 0; i < nr_objs; i++, p += space->size) - { - /* Invoke constructor at object creation time, not when it is - really allocated (for faster allocation). */ - if (space->constructor) - { - error_t err = (*space->constructor) (space->hook, p); - if (err) - { - /* The allocated page holds both slab and memory - objects. Call the destructor for objects that has - been initialized. */ - for (bufctl = new_slab->free_list; bufctl; - bufctl = bufctl->next) - { - void *buffer = (((void *) bufctl) - - (space->size - sizeof *bufctl)); - (*space->destructor) (space->hook, buffer); - } - - deallocate_buffer (space, p, space->slab_size); - return err; - } - } - - /* The most activity is in front of the object, so it is most - likely to be overwritten if a freed buffer gets accessed. - Therefor, put the bufctl structure at the end of the - object. */ - bufctl = (p + space->size - sizeof *bufctl); - bufctl->next = new_slab->free_list; - new_slab->free_list = bufctl; - } - - /* Insert slab into the list of available slabs for this cache. The - only time a slab should be allocated is when there is no more - buffers, so it is safe to repoint first_free. */ - insert_slab (space, new_slab); - space->first_free = new_slab; - return 0; -} - - -/* Initialize the slab space SPACE. */ -error_t -hurd_slab_init (hurd_slab_space_t space, size_t size, size_t alignment, - hurd_slab_allocate_buffer_t allocate_buffer, - hurd_slab_deallocate_buffer_t deallocate_buffer, - hurd_slab_constructor_t constructor, - hurd_slab_destructor_t destructor, - void *hook) -{ - error_t err; - - /* Initialize all members to zero by default. */ - memset (space, 0, sizeof (struct hurd_slab_space)); - - if (!alignment) - /* FIXME: Is this a good default? Maybe eight (8) is better, - since several architectures require that double and friends are - eight byte aligned. */ - alignment = __alignof__ (void *); - - space->requested_size = size; - space->requested_align = alignment; - space->slab_size = getpagesize () * SLAB_PAGES; - - /* Testing the size here avoids an assertion in init_space. */ - size = size + sizeof (union hurd_bufctl); - size = (size + alignment - 1) & ~(alignment - 1); - if (size > (space->slab_size - sizeof (struct hurd_slab) - - sizeof (union hurd_bufctl))) - return EINVAL; - - err = pthread_mutex_init (&space->lock, NULL); - if (err) - return err; - - space->allocate_buffer = allocate_buffer; - space->deallocate_buffer = deallocate_buffer; - space->constructor = constructor; - space->destructor = destructor; - space->hook = hook; - - /* The remaining fields will be initialized by init_space. */ - return 0; -} - - -/* Create a new slab space with the given object size, alignment, - constructor and destructor. ALIGNMENT can be zero. */ -error_t -hurd_slab_create (size_t size, size_t alignment, - hurd_slab_allocate_buffer_t allocate_buffer, - hurd_slab_deallocate_buffer_t deallocate_buffer, - hurd_slab_constructor_t constructor, - hurd_slab_destructor_t destructor, - void *hook, - hurd_slab_space_t *r_space) -{ - hurd_slab_space_t space; - error_t err; - - space = malloc (sizeof (struct hurd_slab_space)); - if (!space) - return ENOMEM; - - err = hurd_slab_init (space, size, alignment, - allocate_buffer, deallocate_buffer, - constructor, destructor, hook); - if (err) - { - free (space); - return err; - } - - *r_space = space; - return 0; -} - - -/* Destroy all objects and the slab space SPACE. Returns EBUSY if - there are still allocated objects in the slab. */ -error_t -hurd_slab_destroy (hurd_slab_space_t space) -{ - error_t err; - - /* The caller wants to destroy the slab. It can not be destroyed if - there are any outstanding memory allocations. */ - pthread_mutex_lock (&space->lock); - err = reap (space); - if (err) - { - pthread_mutex_unlock (&space->lock); - return err; - } - - if (space->slab_first) - { - /* There are still slabs, i.e. there is outstanding allocations. - Return EBUSY. */ - pthread_mutex_unlock (&space->lock); - return EBUSY; - } - - /* FIXME: Remove slab space from pager's reap functionality. */ - - return 0; -} - - -/* Destroy all objects and the slab space SPACE. If there were no - outstanding allocations free the slab space. Returns EBUSY if - there are still allocated objects in the slab space. */ -error_t -hurd_slab_free (hurd_slab_space_t space) -{ - error_t err = hurd_slab_destroy (space); - if (err) - return err; - free (space); - return 0; -} - - -/* Allocate a new object from the slab space SPACE. */ -error_t -hurd_slab_alloc (hurd_slab_space_t space, void **buffer) -{ - error_t err; - union hurd_bufctl *bufctl; - - pthread_mutex_lock (&space->lock); - - /* If there is no slabs with free buffer, the cache has to be - expanded with another slab. If the slab space has not yet been - initialized this is always true. */ - if (!space->first_free) - { - err = grow (space); - if (err) - { - pthread_mutex_unlock (&space->lock); - return err; - } - } - - /* Remove buffer from the free list and update the reference - counter. If the reference counter will hit the top, it is - handled at the time of the next allocation. */ - bufctl = space->first_free->free_list; - space->first_free->free_list = bufctl->next; - space->first_free->refcount++; - bufctl->slab = space->first_free; - - /* If the reference counter hits the top it means that there has - been an allocation boost, otherwise dealloc would have updated - the first_free pointer. Find a slab with free objects. */ - if (space->first_free->refcount == space->full_refcount) - { - struct hurd_slab *new_first = space->slab_first; - while (new_first) - { - if (new_first->refcount != space->full_refcount) - break; - new_first = new_first->next; - } - /* If first_free is set to NULL here it means that there are - only empty slabs. The next call to alloc will allocate a new - slab if there was no call to dealloc in the meantime. */ - space->first_free = new_first; - } - *buffer = ((void *) bufctl) - (space->size - sizeof *bufctl); - pthread_mutex_unlock (&space->lock); - return 0; -} - - -static inline void -put_on_slab_list (struct hurd_slab *slab, union hurd_bufctl *bufctl) -{ - bufctl->next = slab->free_list; - slab->free_list = bufctl; - slab->refcount--; - assert (slab->refcount >= 0); -} - - -/* Deallocate the object BUFFER from the slab space SPACE. */ -void -hurd_slab_dealloc (hurd_slab_space_t space, void *buffer) -{ - struct hurd_slab *slab; - union hurd_bufctl *bufctl; - - assert (space->initialized); - - pthread_mutex_lock (&space->lock); - - bufctl = (buffer + (space->size - sizeof *bufctl)); - put_on_slab_list (slab = bufctl->slab, bufctl); - - /* Try to have first_free always pointing at the slab that has the - most number of free objects. So after this deallocation, update - the first_free pointer if reference counter drops below the - current reference counter of first_free. */ - if (!space->first_free - || slab->refcount < space->first_free->refcount) - space->first_free = slab; - - pthread_mutex_unlock (&space->lock); -} diff --git a/libhurd-slab/slab.h b/libhurd-slab/slab.h deleted file mode 100644 index 6eeb8e48..00000000 --- a/libhurd-slab/slab.h +++ /dev/null @@ -1,338 +0,0 @@ -/* slab.h - The GNU Hurd slab allocator interface. - Copyright (C) 2003, 2005 Free Software Foundation, Inc. - Written by Marcus Brinkmann <marcus@gnu.org> - - This file is part of the GNU Hurd. - - This program is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This program 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 - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this program; if not, write to the Free - Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA - 02111-1307 USA. */ - -#ifndef _HURD_SLAB_H -#define _HURD_SLAB_H 1 - -#include <errno.h> -#include <stdbool.h> -#include <pthread.h> - - -/* Allocate a buffer in *PTR of size SIZE which must be a power of 2 - and self aligned (i.e. aligned on a SIZE byte boundary). HOOK is - as provided to hurd_slab_create. Return 0 on success, an error - code on failure. */ -typedef error_t (*hurd_slab_allocate_buffer_t) (void *hook, size_t size, - void **ptr); - -/* Deallocate buffer BUFFER of size SIZE. HOOK is as provided to - hurd_slab_create. */ -typedef error_t (*hurd_slab_deallocate_buffer_t) (void *hook, void *buffer, - size_t size); - -/* Initialize the slab object pointed to by OBJECT. HOOK is as - provided to hurd_slab_create. */ -typedef error_t (*hurd_slab_constructor_t) (void *hook, void *object); - -/* Destroy the slab object pointed to by OBJECT. HOOK is as provided - to hurd_slab_create. */ -typedef void (*hurd_slab_destructor_t) (void *hook, void *object); - - -/* The type of a slab space. - - The structure is divided into two parts: the first is only used - while the slab space is constructed. Its fields are either - initialized by a static initializer (HURD_SLAB_SPACE_INITIALIZER) - or by the hurd_slab_create function. The initialization of the - space is delayed until the first allocation. After that only the - second part is used. */ - -typedef struct hurd_slab_space *hurd_slab_space_t; -struct hurd_slab_space -{ - /* First part. Used when initializing slab space object. */ - - /* True if slab space has been initialized. */ - bool initialized; - - /* Protects this structure, along with all the slabs. No need to - delay initialization of this field. */ - pthread_mutex_t lock; - - /* The size and alignment of objects allocated using this slab - space. These to fields are used to calculate the final object - size, which is put in SIZE (defined below). */ - size_t requested_size; - size_t requested_align; - - /* The size of each slab. */ - size_t slab_size; - - /* The buffer allocator. */ - hurd_slab_allocate_buffer_t allocate_buffer; - - /* The buffer deallocator. */ - hurd_slab_deallocate_buffer_t deallocate_buffer; - - /* The constructor. */ - hurd_slab_constructor_t constructor; - - /* The destructor. */ - hurd_slab_destructor_t destructor; - - /* The user's private data. */ - void *hook; - - /* Second part. Runtime information for the slab space. */ - - struct hurd_slab *slab_first; - struct hurd_slab *slab_last; - - /* In the doubly-linked list of slabs, empty slabs come first, after - that the slabs that have some buffers allocated, and finally the - complete slabs (refcount == 0). FIRST_FREE points to the first - non-empty slab. */ - struct hurd_slab *first_free; - - /* For easy checking, this holds the value the reference counter - should have for an empty slab. */ - int full_refcount; - - /* The size of one object. Should include possible alignment as - well as the size of the bufctl structure. */ - size_t size; -}; - - -/* Static initializer. TYPE is used to get size and alignment of - objects the slab space will be used to allocate. ALLOCATE_BUFFER - may be NULL in which case mmap is called. DEALLOCATE_BUFFER may be - NULL in which case munmap is called. CTOR and DTOR are the slab's - object constructor and destructor, respectivly and may be NULL if - not required. HOOK is passed as user data to the constructor and - destructor. */ -#define HURD_SLAB_SPACE_INITIALIZER(TYPE, ALLOC, DEALLOC, CTOR, \ - DTOR, HOOK) \ - { \ - false, \ - PTHREAD_MUTEX_INITIALIZER, \ - sizeof (TYPE), \ - __alignof__ (TYPE), \ - ALLOC, \ - DEALLOC, \ - CTOR, \ - DTOR, \ - HOOK \ - /* The rest of the structure will be filled with zeros, \ - which is good for us. */ \ - } - - -/* Create a new slab space with the given object size, alignment, - constructor and destructor. ALIGNMENT can be zero. - ALLOCATE_BUFFER may be NULL in which case mmap is called. - DEALLOCATE_BUFFER may be NULL in which case munmap is called. CTOR - and DTOR are the slabs object constructor and destructor, - respectivly and may be NULL if not required. HOOK is passed as the - first argument to the constructor and destructor. */ -error_t hurd_slab_create (size_t size, size_t alignment, - hurd_slab_allocate_buffer_t allocate_buffer, - hurd_slab_deallocate_buffer_t deallocate_buffer, - hurd_slab_constructor_t constructor, - hurd_slab_destructor_t destructor, - void *hook, - hurd_slab_space_t *space); - -/* Destroy all objects and the slab space SPACE. If there were no - outstanding allocations free the slab space. Returns EBUSY if - there are still allocated objects in the slab space. The dual of - hurd_slab_create. */ -error_t hurd_slab_free (hurd_slab_space_t space); - -/* Like hurd_slab_create, but does not allocate storage for the slab. */ -error_t hurd_slab_init (hurd_slab_space_t space, size_t size, size_t alignment, - hurd_slab_allocate_buffer_t allocate_buffer, - hurd_slab_deallocate_buffer_t deallocate_buffer, - hurd_slab_constructor_t constructor, - hurd_slab_destructor_t destructor, - void *hook); - -/* Destroy all objects and the slab space SPACE. Returns EBUSY if - there are still allocated objects in the slab. The dual of - hurd_slab_init. */ -error_t hurd_slab_destroy (hurd_slab_space_t space); - -/* Allocate a new object from the slab space SPACE. */ -error_t hurd_slab_alloc (hurd_slab_space_t space, void **buffer); - -/* Deallocate the object BUFFER from the slab space SPACE. */ -void hurd_slab_dealloc (hurd_slab_space_t space, void *buffer); - -/* Create a more strongly typed slab interface a la a C++ template. - - NAME is the name of the new slab class. NAME is used to synthesize - names for the class types and methods using the following rule: the - hurd_ namespace will prefix all method names followed by NAME - followed by an underscore and finally the method name. The - following are thus exposed: - - Types: - struct hurd_NAME_slab_space - hurd_NAME_slab_space_t - - error_t (*hurd_NAME_slab_constructor_t) (void *hook, element_type *buffer) - void (*hurd_NAME_slab_destructor_t) (void *hook, element_type *buffer) - - Functions: - error_t hurd_NAME_slab_create (hurd_slab_allocate_buffer_t - allocate_buffer, - hurd_slab_deallocate_buffer_t - deallocate_buffer, - hurd_NAME_slab_constructor_t constructor, - hurd_NAME_slab_destructor_t destructor, - void *hook, - hurd_NAME_slab_space_t *space); - error_t hurd_NAME_slab_free (hurd_NAME_slab_space_t space); - - error_t hurd_NAME_slab_init (hurd_NAME_slab_space_t space, - hurd_slab_allocate_buffer_t allocate_buffer, - hurd_slab_deallocate_buffer_t - deallocate_buffer, - hurd_NAME_slab_constructor_t constructor, - hurd_NAME_slab_destructor_t destructor, - void *hook); - error_t hurd_NAME_slab_destroy (hurd_NAME_slab_space_t space); - - error_t hurd_NAME_slab_alloc (hurd_NAME_slab_space_t space, - element_type **buffer); - void hurd_NAME_slab_dealloc (hurd_NAME_slab_space_t space, - element_type *buffer); - - ELEMENT_TYPE is the type of elements to store in the slab. If you - want the slab to contain struct foo, pass `struct foo' as the - ELEMENT_TYPE (not `struct foo *'!!!). - -*/ -#define SLAB_CLASS(name, element_type) \ -struct hurd_##name##_slab_space \ -{ \ - struct hurd_slab_space space; \ -}; \ -typedef struct hurd_##name##_slab_space *hurd_##name##_slab_space_t; \ - \ -typedef error_t (*hurd_##name##_slab_constructor_t) (void *hook, \ - element_type *buffer); \ - \ -typedef void (*hurd_##name##_slab_destructor_t) (void *hook, \ - element_type *buffer); \ - \ -static inline error_t \ -hurd_##name##_slab_create (hurd_slab_allocate_buffer_t allocate_buffer, \ - hurd_slab_deallocate_buffer_t deallocate_buffer, \ - hurd_##name##_slab_constructor_t constructor, \ - hurd_##name##_slab_destructor_t destructor, \ - void *hook, \ - hurd_##name##_slab_space_t *space) \ -{ \ - union \ - { \ - hurd_##name##_slab_constructor_t t; \ - hurd_slab_constructor_t u; \ - } con; \ - union \ - { \ - hurd_##name##_slab_destructor_t t; \ - hurd_slab_destructor_t u; \ - } des; \ - union \ - { \ - hurd_##name##_slab_space_t *t; \ - hurd_slab_space_t *u; \ - } foo; \ - con.t = constructor; \ - des.t = destructor; \ - foo.t = space; \ - \ - return hurd_slab_create(sizeof (element_type), __alignof__ (element_type), \ - allocate_buffer, deallocate_buffer, \ - con.u, des.u, hook, foo.u); \ -} \ - \ -static inline error_t \ -hurd_##name##_slab_free (hurd_##name##_slab_space_t space) \ -{ \ - return hurd_slab_free (&space->space); \ -} \ - \ -static inline error_t \ -hurd_##name##_slab_init (hurd_##name##_slab_space_t space, \ - hurd_slab_allocate_buffer_t allocate_buffer, \ - hurd_slab_deallocate_buffer_t deallocate_buffer, \ - hurd_##name##_slab_constructor_t constructor, \ - hurd_##name##_slab_destructor_t destructor, \ - void *hook) \ -{ \ - union \ - { \ - hurd_##name##_slab_constructor_t t; \ - hurd_slab_constructor_t u; \ - } con; \ - union \ - { \ - hurd_##name##_slab_destructor_t t; \ - hurd_slab_destructor_t u; \ - } des; \ - con.t = constructor; \ - des.t = destructor; \ - \ - return hurd_slab_init (&space->space, \ - sizeof (element_type), __alignof__ (element_type), \ - allocate_buffer, deallocate_buffer, \ - con.u, des.u, hook); \ -} \ - \ -static inline error_t \ -hurd_##name##_slab_destroy (hurd_##name##_slab_space_t space) \ -{ \ - return hurd_slab_destroy (&space->space); \ -} \ - \ -static inline error_t \ -hurd_##name##_slab_alloc (hurd_##name##_slab_space_t space, \ - element_type **buffer) \ -{ \ - union \ - { \ - element_type **e; \ - void **v; \ - } foo; \ - foo.e = buffer; \ - \ - return hurd_slab_alloc (&space->space, foo.v); \ -} \ - \ -static inline void \ -hurd_##name##_slab_dealloc (hurd_##name##_slab_space_t space, \ - element_type *buffer) \ -{ \ - union \ - { \ - element_type *e; \ - void *v; \ - } foo; \ - foo.e = buffer; \ - \ - hurd_slab_dealloc (&space->space, foo.v); \ -} - -#endif /* _HURD_SLAB_H */ |