diff options
author | jao <jao@gnu.org> | 2020-07-20 18:57:35 +0100 |
---|---|---|
committer | jao <jao@gnu.org> | 2020-07-20 18:57:35 +0100 |
commit | 94296d8dcfb46812bb142e4fb6a41e9bc810d287 (patch) | |
tree | 07e6a73926708fb06fdfa0ad3cbf17c8141ced52 /scheme/chez/geiser/geiser.ss | |
parent | 9d66c63c5374001608b2e1807c3e136c82c44f60 (diff) | |
download | geiser-chez-94296d8dcfb46812bb142e4fb6a41e9bc810d287.tar.gz geiser-chez-94296d8dcfb46812bb142e4fb6a41e9bc810d287.tar.bz2 |
files moved from original import locations
Diffstat (limited to 'scheme/chez/geiser/geiser.ss')
-rw-r--r-- | scheme/chez/geiser/geiser.ss | 155 |
1 files changed, 0 insertions, 155 deletions
diff --git a/scheme/chez/geiser/geiser.ss b/scheme/chez/geiser/geiser.ss deleted file mode 100644 index 33d1b39..0000000 --- a/scheme/chez/geiser/geiser.ss +++ /dev/null @@ -1,155 +0,0 @@ -(library (geiser) - (export geiser:eval - geiser:completions - geiser:module-completions - geiser:autodoc - geiser:no-values - geiser:load-file - geiser:newline - geiser:macroexpand) - (import (chezscheme)) - - (define (last-index-of str-list char idx last-idx) - (if (null? str-list) - last-idx - (last-index-of (cdr str-list) char (+ 1 idx) (if (char=? char (car str-list)) idx last-idx)))) - - (define (obj-file-name name) - (let ((idx (last-index-of (string->list name) #\. 0 -1))) - (if (= idx -1) - (string-append name ".so") - (string-append (substring name 0 idx) ".so")))) - - (define (geiser:load-file filename) - (let ((output-filename (obj-file-name filename))) - (maybe-compile-file filename output-filename) - (load output-filename))) - - (define string-prefix? - (lambda (x y) - (let ([n (string-length x)]) - (and (fx<= n (string-length y)) - (let prefix? ([i 0]) - (or (fx= i n) - (and (char=? (string-ref x i) (string-ref y i)) - (prefix? (fx+ i 1))))))))) - - (define (geiser:completions prefix . rest) - rest - (sort string-ci<? - (filter (lambda (el) - (string-prefix? prefix el)) - (map write-to-string (environment-symbols (interaction-environment)))))) - - (define (write-to-string x) - (with-output-to-string - (lambda () - (write x)))) - - (define (geiser:eval module form . rest) - rest - (let ((output-string (open-output-string))) - (write - (call/cc - (lambda (k) - (with-exception-handler - (lambda (e) - (k `((result "") - (output . ,(with-output-to-string - (lambda () - (display-condition e)))) - (error (key . chez-error-message))))) - (lambda () - (call-with-values - ;; evaluate form, allow for multiple return values, - ;; and capture output in output-string. - (lambda () - (parameterize ((current-output-port output-string)) - (if module - (eval form (environment module)) - (eval form)))) - (lambda result - `((result ,(with-output-to-string - (lambda () - (pretty-print - (if (null? (cdr result)) (car result) result))))) - (output . ,(get-output-string output-string)))))))))) - (newline) - (close-output-port output-string))) - - (define (geiser:module-completions prefix . rest) - (define (substring? s1 s2) - (let ([n1 (string-length s1)] [n2 (string-length s2)]) - (let loop2 ([i2 0]) - (let loop1 ([i1 0] [j i2]) - (if (fx= i1 n1) - i2 - (and (not (fx= j n2)) - (if (char=? (string-ref s1 i1) (string-ref s2 j)) - (loop1 (fx+ i1 1) (fx+ j 1)) - (loop2 (fx+ i2 1))))))))) - (filter (lambda (el) - (substring? prefix el)) - (map write-to-string (library-list)))) - - (define (procedure-parameter-list p) - ;; same as (inspect object), then hitting c - (let ((s (((inspect/object p) 'code) 'source))) - (if s - (let ((form (s 'value))) - (if (and (list? form) - (> (length form) 2) - (eq? (car form) 'lambda)) - (cadr form) - #f)) - #f))) - - (define (operator-arglist operator) - (let ((binding (eval operator))) - (if binding - (let ((arglist (procedure-parameter-list binding))) - (let loop ((arglist arglist) - (optionals? #f) - (required '()) - (optional '())) - (cond ((null? arglist) - `(,operator ("args" (("required" ,@(reverse required)) - ("optional" ,@(reverse optional)) - ("key") - ;; ("module" ,module) - )))) - ((symbol? arglist) - (loop '() - #t - required - (cons "..." (cons arglist optional)))) - (else - (loop - (cdr arglist) - optionals? - (if optionals? required (cons (car arglist) required)) - (if optionals? (cons (car arglist) optional) optional)))))) - '()))) - - (define (geiser:autodoc ids . rest) - (cond ((null? ids) '()) - ((not (list? ids)) - (geiser:autodoc (list ids))) - ((not (symbol? (car ids))) - (geiser:autodoc (cdr ids))) - (else - (map (lambda (id) - (operator-arglist id)) - ids)))) - - (define (geiser:no-values) - #f) - - (define (geiser:newline) - #f) - - (define (geiser:macroexpand form . rest) - (with-output-to-string - (lambda () - (pretty-print - (syntax->datum (expand form))))))) |