all signers:
antecedents:
press order:
patch:
(115 . 7)(115 . 7)- 816C72CA3FE3ED9F9A2C1C1E779ADCA1279EDABAF547E70D5BBEBD00300C2062D7C2BA51A3ED200472639640577FB3643D780E204546ACA62807978BA3F54449
8 FILE* fp;
9 fp = fopen(shiva_init_path, "r");
10 if (fp != NULL) {
11 if (fd_socket)
12 if (fd_socket && !GetBoolArg("-swank"))
13 fprintf(fd_socket, "Shiva: using init file %s\n", shiva_init_path);
14 scheme_load_named_file(sc, fp, shiva_init_path);
15 if (sc->retcode!=0 && fd_socket) {
(155 . 7)(155 . 13)
17 read_init_file(mapArgs["-shivainit"].c_str(), &sc, fdout);
18 init_shiva_hooks(&sc);
19 /* Jump into session */
20 scheme_load_named_file(&sc, fdin, 0);
21 if(GetBoolArg("-swank")) {
22 sc.interactive_repl = 0;
23 scheme_set_input_port_file(&sc, fdin);
24 scheme_apply0(&sc,"swank-loop");
25 } else {
26 scheme_load_named_file(&sc, fdin, 0);
27 }
28
29 printf("Shiva: closed session.\n");
30
(187 . 9)(193 . 19)
32 return sc->NIL;
33 }
34
35 static pointer btc_log(scheme *sc, pointer args) {
36 if(args!=sc->NIL) {
37 if(sc->vptr->is_string(sc->vptr->pair_car(args))) {
38 char *string=sc->vptr->string_value(sc->vptr->pair_car(args));
39 printf("%s\n", string);
40 }
41 }
42 return sc->NIL;
43 }
44
45 /* Install the hooks. For each of the above, must do this: */
46 static void init_shiva_hooks(scheme *sc) {
47 scheme_define(sc, sc->global_env, mk_symbol(sc, "btc-get-best-height" ), mk_foreign_func(sc, btc_get_best_height));
48 scheme_define(sc, sc->global_env, mk_symbol(sc, "btc-shutdown" ), mk_foreign_func(sc, btc_shutdown));
49 scheme_define(sc, sc->global_env, mk_symbol(sc, "btc-log"), mk_foreign_func(sc, btc_log));
50 }
(566 . 19)(566 . 27)- 1BBAEF06AB4B1E168A42B4CD74605BDB7D55412544FF177E2CE07CE7AA07A7FD7B8B44CFBA2B7E28DC057FCC8B4CFA0E00ED66DAC30933E909DD13C81A99760B
55
56 (define (throw . x)
57 (if (more-handlers?)
58 (apply (pop-handler))
59 (apply (pop-handler) x)
60 (apply error x)))
61
62 (macro (catch form)
63 (let ((label (gensym)))
64 `(call/cc (lambda (exit)
65 (push-handler (lambda () (exit ,(cadr form))))
66 (push-handler (lambda err (exit ,(cadr form))))
67 (let ((,label (begin ,@(cddr form))))
68 (pop-handler)
69 ,label)))))
70
71 (define *error-hook* throw)
72
73 (unless (defined? 'error-internal)
74 (let ((outer-env (current-environment)))
75 (eval '(define error-internal error) outer-env)
76 (eval '(define (error msg)
77 (if (more-handlers?)
78 (throw msg)
79 (error-internal msg)))
80 outer-env)))
81
82 ;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
83
(713 . 4)(721 . 265)
85 (not (cond-eval (cadr condition)))))
86 (else (error "cond-expand : unknown operator" (car condition)))))))
87
88 ;;; utilities
89
90 (define-macro (prog1 value . body)
91 (let ((gvalue (gensym)))
92 `(let ((,gvalue ,value))
93 ,@body
94 ,gvalue)))
95
96 (define-macro (destructuring-bind bindings thunk . body)
97 `(apply (lambda ,bindings ,@body) ,thunk))
98
99 (define-macro (with-output-port port . body)
100 (let ((gport (gensym)) (gprevious (gensym)))
101 `(let ((,gprevious #f) (,gport ,port))
102 (dynamic-wind
103 (lambda ()
104 (set! ,gprevious (current-output-port))
105 (set-output-port ,gport))
106 (lambda ()
107 ,@body)
108 (lambda () (set-output-port ,gprevious))))))
109
110 (define t #t)
111 (define nil ())
112 (define (void))
113 (define (identity value) value)
114
115 (define (format port f . args)
116 (cond
117 ((eq? port #f)
118 (let ((port (open-output-string)))
119 (apply format port f args)
120 (get-output-string port)))
121 ((eq? port #t)
122 (apply format (current-output-port) f args))
123 (else (let ((len (string-length f))
124 (arg (lambda ()
125 (prog1 (car args)
126 (set! args (cdr args))))))
127 (let loop ((i 0))
128 (cond ((= i len))
129 ((and (char=? (string-ref f i) #\~)
130 (< (+ i 1) len))
131 (let ((eat (dispatch-format
132 (string-ref f (+ i 1)) port arg)))
133 (loop (+ i 2))))
134 (else
135 (write-char (string-ref f i) port)
136 (loop (+ i 1) args))))))))
137
138 (define (dispatch-format char port arg)
139 (let ((probe (assoc char format-dispatch-table)))
140 (cond (probe ((cdr probe) arg port) #t)
141 (else (error "invalid format char: " char)))))
142
143 (define format-dispatch-table
144 `((#\a . ,(lambda (arg port) (display (arg) port)))
145 (#\s . ,(lambda (arg port) (write (arg) port)))
146 (#\d . ,(lambda (arg port) (display (number->string (arg) 10) port)))
147 (#\x . ,(lambda (arg port) (display (number->string (arg) 16) port)))
148 (#\c . ,(lambda (arg port) (write-char (arg) port)))
149 (#\% . ,(lambda (arg port) (newline port)))))
150
151 (define (string-pad s len char)
152 (let* ((result (make-string len))
153 (sl (string-length s))
154 (break (- len sl)))
155 (let loop ((i 0))
156 (when (< i len)
157 (if (>= i break)
158 (string-set! result i (string-ref s (- i break)))
159 (string-set! result i char))
160 (loop (+ i 1))))
161 result))
162
163 (define (string-prefix-length s1 s2)
164 (let ((stop (min (string-length s1) (string-length s2))))
165 (let loop ((i 0))
166 (if (and (< i stop)
167 (char=? (string-ref s1 i) (string-ref s2 i)))
168 (loop (+ i 1))
169 i))))
170
171 (define (string-prefix? s1 s2)
172 (cond ((< (string-length s2) (string-length s1)) #f)
173 ((string=? s1 (substring s2 0 (string-length s1))) #t)
174 (else #f)))
175
176 (define (prin1-to-string form)
177 (let ((port (open-output-string)))
178 (write form port)
179 (get-output-string port)))
180
181 (define (read-string size)
182 (let ((result (make-string size)))
183 (let loop ((i 0))
184 (when (< i size)
185 (string-set! result i (read-char))
186 (loop (+ i 1))))
187 result))
188
189 (define (read-line)
190 (let ((port (open-output-string)))
191 (let loop ((char (peek-char)))
192 (unless (or (eof-object? char)
193 (member char '(#\newline #\return)))
194 (read-char)
195 (write-char char port)
196 (loop (peek-char))))))
197
198 ;; development environment
199
200 (define (debug v)
201 (let ((port (open-output-string)))
202 (display "SHIVA: " port)
203 (display v port)
204 (btc-log (get-output-string port))
205 v))
206
207 (define-macro (time . form)
208 (let ((gtime (gensym)))
209 `(let ((,gtime (get-unix-time)))
210 (prog1 (begin
211 ,@form)
212 (format #t "time: ~a~%" (- (get-unix-time) ,gtime))))))
213
214 (define (apropos match)
215 (let ((typemap `((,procedure? "procedure" #f)
216 (,macro? "macro" #f)
217 (,list? "list" #f)
218 (,closure? "closure" #f)
219 (,boolean? "boolean" #f)
220 (,eof-object? "eof-object" #f)
221 (,symbol? "symbol" #f)
222 (,number? "number" #f)
223 (,string? "string" #f)
224 (,integer? "integer" #f)
225 (,real? "real" #f)
226 (,null? "null" #f)
227 (,char? "char" #f)
228 (,port? "port" #f)
229 (,input-port? "input-port" #f)
230 (,output-port? "output-port" #f)
231 (,pair? "pair" #f)
232 (,environment? "environment" #f)
233 (,vector? "vector" #f)
234 )))
235 (for-each
236 (lambda (symbol)
237 (if (defined? symbol)
238 (let ((value (symbol-value symbol)))
239 (display (symbol->string symbol))
240 (display "\t")
241 (let loop ((tm typemap))
242 (when (pair? tm)
243 (destructuring-bind (test disp more) (car tm)
244 (if (test value)
245 (display disp)
246 (loop (cdr tm))))))
247 (newline))))
248 (apropos-internal match))
249 nil))
250
251 ;;; swank
252
253 (define (find-symbols-by-prefix prefix)
254 (let ((symbols ())
255 (new-prefix #f))
256 (for-each
257 (lambda (symbol)
258 (let ((symbol-name (symbol->string symbol)))
259 (when (string-prefix? prefix symbol-name)
260 (set! new-prefix (if new-prefix
261 (substring
262 symbol-name 0
263 (string-prefix-length
264 new-prefix symbol-name))
265 symbol-name))
266 (set! symbols (cons symbol-name symbols)))))
267 (apropos-internal prefix))
268 (list symbols (or new-prefix prefix))))
269
270 (define (swank:connection-info)
271 '(:version "2015-06-01" :encoding (:coding-systems ("iso-latin-1-unix"))))
272
273 (define (swank:swank-require packages) '("SWANK-REPL"))
274
275 (define (swank:init-presentations) nil)
276
277 (define (swank:autodoc sexp . rest) `("DISABLE AUTODOC" t))
278
279 (define (swank:operator-arglist operator package)
280 (let* ((symbol (string->symbol operator))
281 (symbol-value (catch #f (eval symbol)))
282 (code (get-closure-code symbol-value)))
283 (if (pair? code)
284 (cons symbol (cadr code))
285 (prin1-to-string symbol-value))))
286
287 (define (swank:clear-repl-results) nil)
288
289 (define (swank-repl:clear-repl-variables) nil)
290
291 (define (swank-repl:create-repl . args) `("BITCOIND" "BITCOIND"))
292
293 (define (swank-repl:listener-eval form-string)
294 (let* ((form (read (open-input-string form-string)))
295 (port (open-output-string))
296 (result (with-output-port port
297 (eval form (interaction-environment)))))
298 (write-swank-event `(:write-string ,(get-output-string port) :repl-result))
299 (write-swank-event `(:write-string
300 ,(string-append (prin1-to-string result) "\n")
301 :repl-result))
302 nil))
303
304 (define (swank:interactive-eval form-string)
305 (let* ((form (read (open-input-string form-string)))
306 (port (open-output-string)))
307 (prog1
308 (prin1-to-string (with-output-port port
309 (eval form (interaction-environment))))
310 (write-swank-event `(:write-string ,(get-output-string port) :repl-result)))))
311
312 (define (swank:completions prefix package) (find-symbols-by-prefix prefix))
313
314 (define (swank:buffer-first-change filename) nil)
315
316 (define (read-swank-event)
317 (let ((size (string->number (read-string 6) 16)))
318 (unless size (error "wrong size"))
319 (let ((payload (read-string size)))
320 (read (open-input-string payload)))))
321
322 (define (write-swank-event sexp)
323 (let* ((payload (let ((port (open-output-string)))
324 (write sexp port)
325 (get-output-string port)))
326 (size (string-pad
327 (number->string (+ 1 (string-length payload)) 16)
328 6
329 #\0)))
330 (display size)
331 (display payload)
332 (newline)))
333
334 (define (process-swank-event event)
335 (case (car event)
336 ((:emacs-rex)
337 (destructuring-bind
338 (command sexp package _ cbid) event
339 (catch `(:return (:abort ,(prin1-to-string err)) ,cbid)
340 (let ((result (eval sexp (interaction-environment))))
341 `(:return (:ok ,result) ,cbid)))))))
342
343 (define (swank-loop)
344 (catch (debug (string-append "error in mainloop " (prin1-to-string err)))
345 (let loop ((event (read-swank-event)))
346 (write-swank-event (debug (process-swank-event (debug event))))
347 (loop (read-swank-event)))))
348
349 (gc-verbose #f)
(152 . 8)(152 . 11)
354 _OP_DEF(opexe_4, "quit", 0, 1, TST_NUMBER, OP_QUIT )
355 _OP_DEF(opexe_4, "gc", 0, 0, 0, OP_GC )
356 _OP_DEF(opexe_4, "gc-verbose", 0, 1, TST_NONE, OP_GCVERB )
357 _OP_DEF(opexe_4, "get-unix-time", 0, 0, 0, OP_TIME )
358 _OP_DEF(opexe_4, "new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT )
359 _OP_DEF(opexe_4, "oblist", 0, 0, 0, OP_OBLIST )
360 _OP_DEF(opexe_4, "symbol-value", 1, 1, TST_SYMBOL, OP_SYMVAL )
361 _OP_DEF(opexe_4, "apropos-internal", 1, 1, TST_STRING, OP_APROPOS )
362 _OP_DEF(opexe_4, "current-input-port", 0, 0, 0, OP_CURR_INPORT )
363 _OP_DEF(opexe_4, "current-output-port", 0, 0, 0, OP_CURR_OUTPORT )
364 _OP_DEF(opexe_4, "open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE )
- 62A1B04FBB7A56B1DD6E95DED0B845416CD42F6691FB87B570878E1F9B3BFB9B4172DAA1655699B931A4B573F1E3DDDF23399F922719A63F8444D1B6B28FCBA7(129 . 7)(129 . 7)- B9F2C8885474FD6B4F7D36955799716E68161BE8F8CFCE3640ADE942FE0064A00D64C7DABC3EC36B24797760B99EA6C79D74A8F984DCC3AEAC2EEF183B3ED70B
369
370 #define LINESIZE 1024
371 char linebuff[LINESIZE];
372 #define STRBUFFSIZE 256
373 #define STRBUFFSIZE 2048
374 char strbuff[STRBUFFSIZE];
375
376 FILE *tmpfp;
(178 . 6)(178 . 7)
378 pointer set_cdr(pointer p, pointer q);
379
380 int is_symbol(pointer p);
381 int is_keyword(pointer p);
382 char *symname(pointer p);
383 int hasprop(pointer p);
384
(196 . 6)(196 . 7)
389 INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
390
391 INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); }
392 INTERFACE INLINE int is_keyword(pointer p) { return (type(p)==T_SYMBOL) && (strvalue(car(p))[0]==':'); }
393 INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); }
394 #if USE_PLIST
395 SCHEME_EXPORT INLINE int hasprop(pointer p) { return (typeflag(p)&T_SYMBOL); }
(842 . 6)(843 . 24)
397 return sc->NIL;
398 }
399
400 static pointer oblist_apropos(scheme *sc, const char *match)
401 {
402 int i;
403 pointer x;
404 char *s;
405 pointer apropos_list = sc->NIL;
406
407 for(i=0; i<ivalue_unchecked(sc->oblist); i++) {
408 for(x=vector_elem(sc->oblist, i); x!=sc->NIL; x=cdr(x)) {
409 s = symname(car(x));
410 if(strcasestr(s, match)) {
411 apropos_list = cons(sc, car(x), apropos_list);
412 }
413 }
414 }
415 return apropos_list;
416 }
417
418 static pointer oblist_all_symbols(scheme *sc)
419 {
420 int i;
(1554 . 8)(1573 . 7)
422 port *pt=sc->outport->_object._port;
423 if(pt->kind&port_file) {
424 fputs(s,pt->rep.stdio.file);
425 if( pt->rep.stdio.interactive )
426 fflush( pt->rep.stdio.file );
427 fflush( pt->rep.stdio.file );
428 } else {
429 for(;*s;s++) {
430 if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
(2562 . 7)(2580 . 9)
432 /* fall through */
433 case OP_REAL_EVAL:
434 #endif
435 if (is_symbol(sc->code)) { /* symbol */
436 if (is_keyword(sc->code)) { /* keyword */
437 s_return(sc,sc->code);
438 } else if (is_symbol(sc->code)) { /* symbol */
439 x=find_slot_in_env(sc,sc->envir,sc->code,1);
440 if (x != sc->NIL) {
441 s_return(sc,slot_value_in_env(x));
(2729 . 6)(2749 . 9)
443 if (!is_symbol(x)) {
444 Error_0(sc,"variable is not a symbol");
445 }
446 if (is_keyword(x)) {
447 Error_0(sc,"unable to alter a keyword");
448 }
449 s_save(sc,OP_DEF1, sc->NIL, x);
450 s_goto(sc,OP_EVAL);
451
(3858 . 6)(3881 . 13)
453 s_retbool(was);
454 }
455
456 case OP_TIME:
457 {
458 struct timeval te;
459 gettimeofday(&te, NULL);
460 s_return(sc,mk_real(sc,(double)te.tv_sec + ((double)te.tv_usec / 1000000)));
461 }
462
463 case OP_NEWSEGMENT: /* new-segment */
464 if (!is_pair(sc->args) || !is_number(car(sc->args))) {
465 Error_0(sc,"new-segment: argument must be a number");
(3868 . 6)(3898 . 17)
467 case OP_OBLIST: /* oblist */
468 s_return(sc, oblist_all_symbols(sc));
469
470 case OP_SYMVAL: /* symbol-value */
471 x=find_slot_in_env(sc,sc->envir,car(sc->args),1);
472 if (x != sc->NIL) {
473 s_return(sc,slot_value_in_env(x));
474 } else {
475 Error_1(sc,"symbol-value: unbound variable:", car(sc->args));
476 }
477
478 case OP_APROPOS: /* apropos */
479 s_return(sc, oblist_apropos(sc, strvalue(car(sc->args))));
480
481 case OP_CURR_INPORT: /* current-input-port */
482 s_return(sc,sc->inport);
483