diff options
Diffstat (limited to 'scheme/chez')
| -rw-r--r-- | scheme/chez/geiser/geiser.ss | 155 | ||||
| -rw-r--r-- | scheme/chez/geiser/test.ss | 120 |
2 files changed, 0 insertions, 275 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))))))) diff --git a/scheme/chez/geiser/test.ss b/scheme/chez/geiser/test.ss deleted file mode 100644 index 2407448..0000000 --- a/scheme/chez/geiser/test.ss +++ /dev/null @@ -1,120 +0,0 @@ -(import (geiser) - (chezscheme)) - -(define-syntax assert-equal - (syntax-rules () - ((_ a b) - (if (equal? a b) - #t - (begin - (display (format "failed assertion `~a' == `~a'" a b)) - (assert (equal? a b))))))) - -(define-syntax get-result - (syntax-rules () - ((_ form) - (with-output-to-string - (lambda () - (geiser:eval #f form)))))) - -(define-syntax do-test - (syntax-rules () - ((_ form result) - (assert - (equal? - (get-result form) - result))))) - -(define-syntax do-test-macroexpand - (syntax-rules () - ((_ form result) - (assert - (equal? (geiser:macroexpand form) - result))))) - -(define-syntax test-or - (syntax-rules () - ((_ x) x) - ((_ x xs ...) - (if x - x - (test-or xs ...))))) - -(do-test-macroexpand - '(test-or 1) - '1) - -(do-test-macroexpand - '(test-or 1 2) - '(if 1 1 2)) - -;; (something-doesnot-exist) -;;=> Error: Exception: variable something-doesnot-exist is not bound -(do-test - '(something-doesnot-exist) - "((result \"\") (output . \"\") (error (key . \"Exception: variable something-doesnot-exist is not bound\")))\n" - ) - -;; (make-violation) -;;=> #<condition &violation> -(do-test - '(make-violation) - "((result \"#<condition &violation>\\n\") (output . \"\"))\n") - -;; (values 1 2 3) -;;==> (1 2 3) -(do-test - '(values 1 2 3) - "((result \"(1 2 3)\\n\") (output . \"\"))\n") - -;; 1 -;;=> 1 -(do-test '1 "((result \"1\\n\") (output . \"\"))\n") - - -;; '(case-lambda -;; [(x1 x2) (+ x1 x2)] -;; [(x1 x2 x3) (+ (+ x1 x2) x3)] -;; [(x1 x2 . rest) -;; ((letrec ([loop (lambda (x1 x2 rest) -;; (let ([x (+ x1 x2)]) -;; (if (null? rest) -;; x -;; (loop x (car rest) (cdr rest)))))]) -;; loop) -;; x1 -;; x2 -;; rest)] -;; [(x1) (+ x1)] -;; [() (+)]) -#|=> (case-lambda - [(x1 x2) (+ x1 x2)] - [(x1 x2 x3) (+ (+ x1 x2) x3)] - [(x1 x2 . rest) - ((letrec ([loop (lambda (x1 x2 rest) - (let ([x (+ x1 x2)]) - (if (null? rest) - x - (loop x (car rest) (cdr rest)))))]) - loop) - x1 - x2 - rest)] - [(x1) (+ x1)] - [() (+)]) - |# -(do-test (quote '(case-lambda - [(x1 x2) (+ x1 x2)] - [(x1 x2 x3) (+ (+ x1 x2) x3)] - [(x1 x2 . rest) - ((letrec ([loop (lambda (x1 x2 rest) - (let ([x (+ x1 x2)]) - (if (null? rest) - x - (loop x (car rest) (cdr rest)))))]) - loop) - x1 - x2 - rest)] - [(x1) (+ x1)] - [() (+)])) "((result \"(case-lambda\\n [(x1 x2) (+ x1 x2)]\\n [(x1 x2 x3) (+ (+ x1 x2) x3)]\\n [(x1 x2 . rest)\\n ((letrec ([loop (lambda (x1 x2 rest)\\n (let ([x (+ x1 x2)])\\n (if (null? rest)\\n x\\n (loop x (car rest) (cdr rest)))))])\\n loop)\\n x1\\n x2\\n rest)]\\n [(x1) (+ x1)]\\n [() (+)])\\n\") (output . \"\"))\n") |