From aed248d24bb67ab58126b8420e57878d2d6e111a Mon Sep 17 00:00:00 2001 From: mainzelm Date: Thu, 16 May 2002 14:50:46 +0000 Subject: [PATCH] First version of libscsh. --- Makefile.in | 6 +++-- scheme/vm/interp.scm | 1 + scsh/libscsh.c | 46 +++++++++++++++++++++++++++++++ scsh/libscsh.h | 15 +++++++++++ scsh/libscsh.scm | 63 +++++++++++++++++++++++++++++++++++++++++++ scsh/scsh-package.scm | 14 ++++++++++ 6 files changed, 143 insertions(+), 2 deletions(-) create mode 100644 scsh/libscsh.c create mode 100644 scsh/libscsh.h create mode 100644 scsh/libscsh.scm diff --git a/Makefile.in b/Makefile.in index 2270830..c08168d 100644 --- a/Makefile.in +++ b/Makefile.in @@ -131,13 +131,14 @@ SCSHOBJS = \ scsh/time1.o \ scsh/tty1.o \ scsh/userinfo1.o \ - scsh/sighandlers1.o + scsh/sighandlers1.o \ + scsh/libscsh.o SCSH_INITIALIZERS = s48_init_syslog s48_init_posix_regexp \ s48_init_userinfo s48_init_sighandlers \ s48_init_syscalls s48_init_network s48_init_flock \ s48_init_dirstuff s48_init_time s48_init_tty \ - s48_init_cig + s48_init_cig s48_init_libscsh UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o @@ -779,6 +780,7 @@ SCHEME =scsh/awk.scm \ scsh/glob.scm \ scsh/dot-locking.scm \ scsh/here.scm \ + scsh/libscsh.scm \ scsh/machine/bufpol.scm \ scsh/machine/errno.scm \ scsh/machine/fdflags.scm \ diff --git a/scheme/vm/interp.scm b/scheme/vm/interp.scm index 48938d3..c2bf5fb 100644 --- a/scheme/vm/interp.scm +++ b/scheme/vm/interp.scm @@ -639,6 +639,7 @@ ((and (false? cont) (fixnum? *val*)) ; VM returns here (set! s48-*callback-return-stack-block* false) ; not from a callback + (reset-stack-pointer false) ; for libscsh (extract-fixnum *val*)) (else (set-current-continuation! false) diff --git a/scsh/libscsh.c b/scsh/libscsh.c new file mode 100644 index 0000000..cf7f4b9 --- /dev/null +++ b/scsh/libscsh.c @@ -0,0 +1,46 @@ +/* This file is part of scsh. + * Copyright (c) 2002 by Martin Gasbichler and Richard Kelsey. See file COPYING. + */ + +#include +#include +#include "scheme48.h" +#include "libscsh.h" + +s48_value s48_command_binding; +s48_value s48_to_string_binding; + +s48_value s48_command (char* fmt, ...) +{ + va_list ap; + va_start (ap, fmt); + return s48_vcommand (fmt, ap); +} + +s48_value s48_vcommand (char* fmt, va_list ap) +{ + char* command; + s48_value ret; + + if (vasprintf(&command, fmt, ap) == -1){ + fprintf(stderr, "error in vasprintf\n"); + exit(1); + } + fprintf (stderr,"The command is: %s\n", command); + S48_SHARED_BINDING_CHECK (s48_command_binding); + + ret = s48_call_scheme (S48_SHARED_BINDING_REF (s48_command_binding), + 1, + s48_enter_string (command)); + + free (command); + va_end (ap); + return ret; +} + + +s48_value s48_init_libscsh(void) +{ + s48_command_binding = s48_get_imported_binding ("s48-command"); + return S48_UNSPECIFIC; +} diff --git a/scsh/libscsh.h b/scsh/libscsh.h new file mode 100644 index 0000000..2c21489 --- /dev/null +++ b/scsh/libscsh.h @@ -0,0 +1,15 @@ +/* This file is part of scsh. + * Copyright (c) 2002 by Martin Gasbichler. See file COPYING. + * Interface to libscsh + */ + +#ifndef LIBSCSH_H +#define LIBSCSH_H +#include + + +s48_value s48_command (char* format, ...); +s48_value s48_vcommand (char* format, va_list ap); +s48_value s48_init_libscsh(void); + +#endif diff --git a/scsh/libscsh.scm b/scsh/libscsh.scm new file mode 100644 index 0000000..a6515a5 --- /dev/null +++ b/scsh/libscsh.scm @@ -0,0 +1,63 @@ +;;; This file is part of scsh. +;;; Copyright (c) 2002 by Martin Gasbichler and Richard Kelsey. +;;; See file COPYING. + +(define (return-from-vm n) + (with-continuation (if #t #f) (lambda () n))) + +(define *user-context*) + +;; must be called from a running command processor +(define (save-user-envs!) + (set! *user-context* (user-context))) + +(define (startup args) + (start-new-session *user-context* + (current-input-port) + (current-output-port) + (current-error-port) + args + #t) ;batch? + (with-interaction-environment + (user-environment) + (lambda () + (return-from-vm 0)))) + +(define (s48-command command-string) + (let* ((in (make-string-input-port command-string)) + (s-exp (read in))) + (if (and (not (eof-object? s-exp)) + (eof-object? (read in))) + (call-with-values + (lambda () + (call-with-current-continuation + (lambda (k) + (with-handler + (lambda (cond more) + (display "error is "(current-error-port)) + (display cond (current-error-port)) + (newline (current-error-port)) + (k cond)) + (lambda () + (eval s-exp (user-command-environment))))))) + (lambda args + (cond ((null? args) + (display "null as result" + (current-error-port))) + ((null? (cdr args)) + (display "evaluated:" (current-error-port)) + (display (car args)(current-error-port)) + (newline (current-error-port)) + (car args)) + (else + (display "multiple return values in s48-command" + (current-error-port)) + )))) + (display "s48-command got not exactly one s-exp" + (current-error-port))))) + +(define (dump-libscsh-image filename) + (dump-scsh-program startup filename)) + +(define-exported-binding "s48-command" s48-command) + diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index e320448..3806340 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -481,3 +481,17 @@ bitwise) (files syslog)) +(define-structure libscsh (export startup + save-user-envs!) + (open scheme + external-calls + (subset i/o (current-error-port)) + (subset extended-ports (make-string-input-port)) + (subset handle (with-handler)) + (subset escapes (with-continuation)) + (subset environments (with-interaction-environment)) + (subset package-commands-internal (user-environment)) + (subset command-levels (user-context start-new-session)) + (subset command-processor (user-command-environment)) + (subset scsh-startup-package (dump-scsh-program))) + (files libscsh))