# HG changeset patch
# Parent  469e8cca7db710f011f9c43a61bf4ca82b1f5e60

diff -r 469e8cca7db7 src/shiva.cpp
--- a/src/shiva.cpp bb607d1e17c0c4025e74d298c4fc3a65a824ed8c55401748fb6ff1f73fec5b5a2c92cf686516dcc119ffb28128bf07162cc70e7f144de2773a0c28832aab3c8a
+++ b/src/shiva.cpp 0426d5093fae535b2b688ee21846f9ef4ad63ba7ddd4cf662fa6a893d8c374bf2006d3b9039a3fa77d2f511694309bfcaeaac487f344f3bafead0b88188e2d0e
@@ -115,7 +115,7 @@
   FILE* fp;
   fp = fopen(shiva_init_path, "r");
   if (fp != NULL) {
-    if (fd_socket)
+    if (fd_socket && !GetBoolArg("-swank"))
       fprintf(fd_socket, "Shiva: using init file %s\n", shiva_init_path);
     scheme_load_named_file(sc, fp, shiva_init_path);
     if (sc->retcode!=0 && fd_socket) {
@@ -155,7 +155,13 @@
   read_init_file(mapArgs["-shivainit"].c_str(), &sc, fdout);
   init_shiva_hooks(&sc);
   /* Jump into session */
-  scheme_load_named_file(&sc, fdin, 0);
+  if(GetBoolArg("-swank")) {
+    sc.interactive_repl = 0;
+    scheme_set_input_port_file(&sc, fdin);
+    scheme_apply0(&sc,"swank-loop");
+  } else {
+    scheme_load_named_file(&sc, fdin, 0);
+  }
 
   printf("Shiva: closed session.\n");
 
@@ -187,9 +193,19 @@
   return sc->NIL;
 }
 
+static pointer btc_log(scheme *sc, pointer args) {
+  if(args!=sc->NIL) {
+    if(sc->vptr->is_string(sc->vptr->pair_car(args))) {
+      char *string=sc->vptr->string_value(sc->vptr->pair_car(args));
+      printf("%s\n", string);
+    }
+  }
+  return sc->NIL;
+}
 
 /* Install the hooks. For each of the above, must do this: */
 static void init_shiva_hooks(scheme *sc) {
   scheme_define(sc, sc->global_env, mk_symbol(sc, "btc-get-best-height" ), mk_foreign_func(sc, btc_get_best_height));
   scheme_define(sc, sc->global_env, mk_symbol(sc, "btc-shutdown" ), mk_foreign_func(sc, btc_shutdown));
+  scheme_define(sc, sc->global_env, mk_symbol(sc, "btc-log"), mk_foreign_func(sc, btc_log));
 }
diff -r 469e8cca7db7 src/shiva/init.scm
--- a/src/shiva/init.scm 816c72ca3fe3ed9f9a2c1c1e779adca1279edabaf547e70d5bbebd00300c2062d7c2ba51a3ed200472639640577fb3643d780e204546aca62807978ba3f54449
+++ b/src/shiva/init.scm d2cc8040a67ed0a4e5b5aad53f9882e4f4d15f96d4aec88d2a4f5cf3f77987a34e699acf7a96b4f27736993fa8e4adccb2786b8b5f3da26b5ee9004a39245f9f
@@ -566,19 +566,27 @@
 
 (define (throw . x)
      (if (more-handlers?)
-          (apply (pop-handler))
+          (apply (pop-handler) x)
           (apply error x)))
 
 (macro (catch form)
      (let ((label (gensym)))
           `(call/cc (lambda (exit)
-               (push-handler (lambda () (exit ,(cadr form))))
+               (push-handler (lambda err (exit ,(cadr form))))
                (let ((,label (begin ,@(cddr form))))
                     (pop-handler)
                     ,label)))))
 
 (define *error-hook* throw)
 
+(unless (defined? 'error-internal)
+  (let ((outer-env (current-environment)))
+    (eval '(define error-internal error) outer-env)
+    (eval '(define (error msg)
+             (if (more-handlers?)
+                 (throw msg)
+                 (error-internal msg)))
+          outer-env)))
 
 ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
 
@@ -713,4 +721,265 @@
                      (not (cond-eval (cadr condition)))))
             (else (error "cond-expand : unknown operator" (car condition)))))))
 
+;;; utilities
+
+(define-macro (prog1 value . body)
+  (let ((gvalue (gensym)))
+    `(let ((,gvalue ,value))
+       ,@body
+       ,gvalue)))
+
+(define-macro (destructuring-bind bindings thunk  . body)
+  `(apply (lambda ,bindings ,@body) ,thunk))
+
+(define-macro (with-output-port port . body)
+  (let ((gport (gensym)) (gprevious (gensym)))
+    `(let ((,gprevious #f) (,gport ,port))
+       (dynamic-wind
+           (lambda ()
+             (set! ,gprevious (current-output-port))
+             (set-output-port ,gport))
+           (lambda ()
+             ,@body)
+           (lambda () (set-output-port ,gprevious))))))
+
+(define t #t)
+(define nil ())
+(define (void))
+(define (identity value) value)
+
+(define (format port f . args)
+  (cond
+   ((eq? port #f)
+    (let ((port (open-output-string)))
+      (apply format port f args)
+      (get-output-string port)))
+   ((eq? port #t)
+    (apply format (current-output-port) f args))
+   (else (let ((len (string-length f))
+               (arg (lambda ()
+                      (prog1 (car args)
+                        (set! args (cdr args))))))
+           (let loop ((i 0))
+             (cond ((= i len))
+                   ((and (char=? (string-ref f i) #\~)
+                         (< (+ i 1) len))
+                    (let ((eat (dispatch-format
+                                (string-ref f (+ i 1)) port arg)))
+                      (loop (+ i 2))))
+                   (else
+                    (write-char (string-ref f i) port)
+                    (loop (+ i 1) args))))))))
+
+(define (dispatch-format char port arg)
+  (let ((probe (assoc char format-dispatch-table)))
+    (cond (probe ((cdr probe) arg port) #t)
+          (else (error "invalid format char: " char)))))
+
+(define format-dispatch-table 
+  `((#\a . ,(lambda (arg port) (display (arg) port)))
+    (#\s . ,(lambda (arg port) (write (arg) port)))
+    (#\d . ,(lambda (arg port) (display (number->string (arg) 10) port)))
+    (#\x . ,(lambda (arg port) (display (number->string (arg) 16) port)))
+    (#\c . ,(lambda (arg port) (write-char (arg) port)))
+    (#\% . ,(lambda (arg port) (newline port)))))
+
+(define (string-pad s len char)
+  (let* ((result (make-string len))
+         (sl (string-length s))
+         (break (- len sl)))
+    (let loop ((i 0))
+      (when (< i len)
+            (if (>= i break)
+                (string-set! result i (string-ref s (- i break)))
+                (string-set! result i char))
+            (loop (+ i 1))))
+    result))
+
+(define (string-prefix-length s1 s2)
+  (let ((stop (min (string-length s1) (string-length s2))))
+   (let loop ((i 0))
+     (if (and (< i stop)
+              (char=? (string-ref s1 i) (string-ref s2 i)))
+         (loop (+ i 1))
+         i))))
+
+(define (string-prefix? s1 s2)
+  (cond ((< (string-length s2) (string-length s1)) #f)
+        ((string=? s1 (substring s2 0 (string-length s1))) #t)
+        (else #f)))
+
+(define (prin1-to-string form)
+  (let ((port (open-output-string)))
+    (write form port)
+    (get-output-string port)))
+
+(define (read-string size)
+  (let ((result (make-string size)))
+    (let loop ((i 0))
+      (when (< i size)
+        (string-set! result i (read-char))
+        (loop (+ i 1))))
+    result))
+
+(define (read-line)
+  (let ((port (open-output-string)))
+    (let loop ((char (peek-char)))
+      (unless (or (eof-object? char)
+                  (member char '(#\newline #\return)))
+        (read-char)
+        (write-char char port)
+        (loop (peek-char))))))
+
+;; development environment
+
+(define (debug v)
+  (let ((port (open-output-string)))
+    (display "SHIVA: " port)
+    (display v port)
+    (btc-log (get-output-string port))
+    v))
+
+(define-macro (time . form)
+  (let ((gtime (gensym)))
+    `(let ((,gtime (get-unix-time)))
+       (prog1 (begin
+                ,@form)
+              (format #t "time: ~a~%" (- (get-unix-time) ,gtime))))))
+
+(define (apropos match)
+  (let ((typemap `((,procedure? "procedure" #f)
+                   (,macro? "macro" #f)
+                   (,list? "list" #f)
+                   (,closure? "closure" #f)
+                   (,boolean? "boolean" #f)
+                   (,eof-object? "eof-object" #f)
+                   (,symbol? "symbol" #f)
+                   (,number? "number" #f)
+                   (,string? "string" #f)
+                   (,integer? "integer" #f)
+                   (,real? "real" #f)
+                   (,null? "null" #f)
+                   (,char? "char" #f)
+                   (,port? "port" #f)
+                   (,input-port? "input-port" #f)
+                   (,output-port? "output-port" #f)
+                   (,pair? "pair" #f)
+                   (,environment? "environment" #f)
+                   (,vector? "vector" #f)
+                   )))
+    (for-each
+     (lambda (symbol)
+       (if (defined? symbol)
+           (let ((value (symbol-value symbol)))
+             (display (symbol->string symbol))
+             (display "\t")
+             (let loop ((tm typemap))
+               (when (pair? tm)
+                 (destructuring-bind (test disp more) (car tm)
+                   (if (test value)
+                       (display disp)
+                       (loop (cdr tm))))))
+             (newline))))
+     (apropos-internal match))
+    nil))
+
+;;; swank
+
+(define (find-symbols-by-prefix prefix)
+  (let ((symbols ())
+        (new-prefix #f))
+    (for-each
+     (lambda (symbol)
+       (let ((symbol-name (symbol->string symbol)))
+         (when (string-prefix? prefix symbol-name)
+           (set! new-prefix (if new-prefix
+                                (substring
+                                 symbol-name 0
+                                 (string-prefix-length
+                                  new-prefix symbol-name))
+                                symbol-name))
+           (set! symbols (cons symbol-name symbols)))))
+     (apropos-internal prefix))
+    (list symbols (or new-prefix prefix))))
+
+(define (swank:connection-info) 
+  '(:version "2015-06-01" :encoding (:coding-systems ("iso-latin-1-unix"))))
+
+(define (swank:swank-require packages) '("SWANK-REPL"))
+
+(define (swank:init-presentations) nil)
+
+(define (swank:autodoc sexp . rest) `("DISABLE AUTODOC" t))
+
+(define (swank:operator-arglist operator package)
+  (let* ((symbol (string->symbol operator))
+         (symbol-value (catch #f (eval symbol)))
+         (code (get-closure-code symbol-value)))
+    (if (pair? code)
+        (cons symbol (cadr code))
+        (prin1-to-string symbol-value))))
+
+(define (swank:clear-repl-results) nil)
+
+(define (swank-repl:clear-repl-variables) nil)
+
+(define (swank-repl:create-repl . args) `("BITCOIND" "BITCOIND"))
+
+(define (swank-repl:listener-eval form-string)
+  (let* ((form (read (open-input-string form-string)))
+         (port (open-output-string))
+         (result (with-output-port port
+                   (eval form (interaction-environment)))))
+    (write-swank-event `(:write-string ,(get-output-string port) :repl-result))
+    (write-swank-event `(:write-string
+                         ,(string-append (prin1-to-string result) "\n")
+                         :repl-result))
+    nil))
+
+(define (swank:interactive-eval form-string)
+  (let* ((form (read (open-input-string form-string)))
+         (port (open-output-string)))
+    (prog1
+        (prin1-to-string (with-output-port port
+                           (eval form (interaction-environment))))
+      (write-swank-event `(:write-string ,(get-output-string port) :repl-result)))))
+
+(define (swank:completions prefix package) (find-symbols-by-prefix prefix))
+
+(define (swank:buffer-first-change filename) nil)
+
+(define (read-swank-event)
+  (let ((size (string->number (read-string 6) 16)))
+    (unless size (error "wrong size"))
+    (let ((payload (read-string size)))
+      (read (open-input-string payload)))))
+
+(define (write-swank-event sexp)
+  (let* ((payload (let ((port (open-output-string)))
+                    (write sexp port)
+                    (get-output-string port)))
+         (size (string-pad 
+                (number->string (+ 1 (string-length payload)) 16)
+                6
+                #\0)))
+    (display size)
+    (display payload)
+    (newline)))
+
+(define (process-swank-event event)
+  (case (car event)
+    ((:emacs-rex)
+     (destructuring-bind
+      (command sexp package _ cbid) event
+      (catch `(:return (:abort ,(prin1-to-string err)) ,cbid)
+             (let ((result (eval sexp (interaction-environment))))
+               `(:return (:ok ,result) ,cbid)))))))
+
+(define (swank-loop)
+  (catch (debug (string-append "error in mainloop " (prin1-to-string err)))
+         (let loop ((event (read-swank-event)))
+           (write-swank-event (debug (process-swank-event (debug event))))
+           (loop (read-swank-event)))))
+
 (gc-verbose #f)
diff -r 469e8cca7db7 src/shiva/opdefines.h
--- a/src/shiva/opdefines.h 1bbaef06ab4b1e168a42b4cd74605bdb7d55412544ff177e2ce07ce7aa07a7fd7b8b44cfba2b7e28dc057fcc8b4cfa0e00ed66dac30933e909dd13c81a99760b
+++ b/src/shiva/opdefines.h 909e93dacf324cbeebbc66783b42e4e4eded33a8a4fe861c70ba2756b03b0f7c0e411021dfd7ed01c404ad4e0114db73db08ec991d9a7ad29296f7da3a1b24e2
@@ -152,8 +152,11 @@
     _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, "get-unix-time",                  0,  0,       0,                               OP_TIME             )
     _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, "symbol-value",                   1,  1,       TST_SYMBOL,                      OP_SYMVAL           )
+    _OP_DEF(opexe_4, "apropos-internal",               1,  1,       TST_STRING,                      OP_APROPOS          )    
     _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      )
diff -r 469e8cca7db7 src/shiva/scheme-private.h
--- a/src/shiva/scheme-private.h 62a1b04fbb7a56b1dd6e95ded0b845416cd42f6691fb87b570878e1f9b3bfb9b4172daa1655699b931a4b573f1e3dddf23399f922719a63f8444d1b6b28fcba7
+++ b/src/shiva/scheme-private.h 9f277e935f0c395cc0a8ac00693ee699fe676348894f96f0f59da4422491a735c96a3b7fe578056cfc2d5e622a493b89d86e0f28e16aead42617dbe6e928067d
@@ -129,7 +129,7 @@
 
 #define LINESIZE 1024
 char    linebuff[LINESIZE];
-#define STRBUFFSIZE 256
+#define STRBUFFSIZE 2048
 char    strbuff[STRBUFFSIZE];
 
 FILE *tmpfp;
@@ -178,6 +178,7 @@
 pointer set_cdr(pointer p, pointer q);
 
 int is_symbol(pointer p);
+int is_keyword(pointer p);
 char *symname(pointer p);
 int hasprop(pointer p);
 
diff -r 469e8cca7db7 src/shiva/scheme.c
--- a/src/shiva/scheme.c b9f2c8885474fd6b4f7d36955799716e68161be8f8cfce3640ade942fe0064a00d64c7dabc3ec36b24797760b99ea6c79d74a8f984dcc3aeac2eef183b3ed70b
+++ b/src/shiva/scheme.c fa43f0b3cf6ea09c625bf66d37c10276f0a66010b8913c9e99ca4df82d73f976b32a972a1caa7624074ab5e423c6437c3e1e4e7a240759c1badccaf595893431
@@ -196,6 +196,7 @@
 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 int is_keyword(pointer p)  { return (type(p)==T_SYMBOL) && (strvalue(car(p))[0]==':'); }
 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); }
@@ -842,6 +843,24 @@
   return sc->NIL;
 }
 
+static pointer oblist_apropos(scheme *sc, const char *match)
+{
+  int i;
+  pointer x;
+  char *s;
+  pointer apropos_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)) {
+      s = symname(car(x));
+      if(strcasestr(s, match)) {
+        apropos_list = cons(sc, car(x), apropos_list);
+      }
+    }
+  }
+  return apropos_list;
+}
+
 static pointer oblist_all_symbols(scheme *sc)
 {
   int i;
@@ -1554,8 +1573,7 @@
   port *pt=sc->outport->_object._port;
   if(pt->kind&port_file) {
     fputs(s,pt->rep.stdio.file);
-    if( pt->rep.stdio.interactive )
-         fflush( pt->rep.stdio.file );
+    fflush( pt->rep.stdio.file );
   } else {
     for(;*s;s++) {
       if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
@@ -2562,7 +2580,9 @@
        /* fall through */
      case OP_REAL_EVAL:
 #endif
-          if (is_symbol(sc->code)) {    /* symbol */
+          if (is_keyword(sc->code)) { /* keyword */
+               s_return(sc,sc->code);
+          } else 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));
@@ -2729,6 +2749,9 @@
           if (!is_symbol(x)) {
                Error_0(sc,"variable is not a symbol");
           }
+          if (is_keyword(x)) {
+               Error_0(sc,"unable to alter a keyword");
+          }
           s_save(sc,OP_DEF1, sc->NIL, x);
           s_goto(sc,OP_EVAL);
 
@@ -3858,6 +3881,13 @@
           s_retbool(was);
      }
 
+     case OP_TIME:
+       {
+         struct timeval te;
+         gettimeofday(&te, NULL);
+         s_return(sc,mk_real(sc,(double)te.tv_sec + ((double)te.tv_usec / 1000000)));
+       }
+     
      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");
@@ -3868,6 +3898,17 @@
      case OP_OBLIST: /* oblist */
           s_return(sc, oblist_all_symbols(sc));
 
+     case OP_SYMVAL: /* symbol-value */
+          x=find_slot_in_env(sc,sc->envir,car(sc->args),1);
+          if (x != sc->NIL) {
+               s_return(sc,slot_value_in_env(x));
+          } else {
+               Error_1(sc,"symbol-value: unbound variable:", car(sc->args));
+          }
+
+     case OP_APROPOS: /* apropos */
+       s_return(sc, oblist_apropos(sc, strvalue(car(sc->args))));
+          
      case OP_CURR_INPORT: /* current-input-port */
           s_return(sc,sc->inport);