summaryrefslogtreecommitdiff
path: root/scheme
diff options
context:
space:
mode:
authorDan Leslie <dan@ironoxide.ca>2014-11-20 17:36:50 -0800
committerJose Antonio Ortega Ruiz <jao@gnu.org>2015-02-09 06:01:56 +0100
commit383585e44e56be0e690ad96895f73abf8454d3be (patch)
treee4e7b0ca78e23942b390e46a5678e0a739d53dab /scheme
parentebbb1f69de76d8dac705ef3b977b1598572b87f7 (diff)
downloadgeiser-guile-383585e44e56be0e690ad96895f73abf8454d3be.tar.gz
geiser-guile-383585e44e56be0e690ad96895f73abf8454d3be.tar.bz2
Initial Chicken support
Diffstat (limited to 'scheme')
-rw-r--r--scheme/Makefile.am3
-rw-r--r--scheme/chicken/geiser/emacs.scm665
2 files changed, 667 insertions, 1 deletions
diff --git a/scheme/Makefile.am b/scheme/Makefile.am
index 2eaadfe..0e25acc 100644
--- a/scheme/Makefile.am
+++ b/scheme/Makefile.am
@@ -18,4 +18,5 @@ nobase_dist_pkgdata_DATA = \
racket/geiser/server.rkt \
racket/geiser/startup.rkt \
racket/geiser/user.rkt \
- racket/geiser/utils.rkt
+ racket/geiser/utils.rkt \
+ chicken/geiser/emacs.scm
diff --git a/scheme/chicken/geiser/emacs.scm b/scheme/chicken/geiser/emacs.scm
new file mode 100644
index 0000000..8ec6bf5
--- /dev/null
+++ b/scheme/chicken/geiser/emacs.scm
@@ -0,0 +1,665 @@
+(module geiser
+ ;; A bunch of these needn't be toplevel functions
+ (geiser-eval
+ geiser-no-values
+ geiser-newline
+ geiser-start-server
+ geiser-completions
+ geiser-autodoc
+ geiser-object-signature
+ geiser-symbol-location
+ geiser-symbol-documentation
+ geiser-find-file
+ geiser-add-to-load-path
+ geiser-load-file
+ geiser-compile-file
+ geiser-compile
+ geiser-module-exports
+ geiser-module-path
+ geiser-module-location
+ geiser-module-completions
+ geiser-macroexpand
+ make-geiser-toplevel-bindings)
+
+ ;; Necessary built in units
+ (import chicken
+ scheme
+ extras
+ data-structures
+ ports
+ csi
+ irregex
+ srfi-1
+ posix
+ utils)
+
+ (use apropos
+ regex
+ chicken-doc
+ tcp
+ srfi-18)
+
+ (define use-debug-log #f)
+
+ (if use-debug-log
+ (use posix))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Symbol lists
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define geiser-r4rs-symbols
+ (make-parameter
+ '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar
+ caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar
+ cddadr cdddar cddddr set-car! set-cdr! null? list? list length
+ list-tail list-ref append reverse memq memv member assq assv assoc
+ symbol? symbol->string string->symbol number? integer? exact? real?
+ complex? inexact? rational? zero? odd? even? positive? negative?
+ max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs
+ floor ceiling truncate round exact->inexact inexact->exact exp log
+ expt sqrt sin cos tan asin acos atan number->string string->number
+ char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<?
+ char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace?
+ char-numeric? char-upper-case? char-lower-case? char-upcase
+ char-downcase char->integer integer->char string? string=? string>?
+ string<? string>=? string<=? string-ci=? string-ci<? string-ci>?
+ string-ci>=? string-ci<=? make-string string-length string-ref
+ string-set! string-append string-copy string->list list->string
+ substring string-fill! vector? make-vector vector-ref vector-set!
+ string vector vector-length vector->list list->vector vector-fill!
+ procedure? map for-each apply force call-with-current-continuation
+ input-port? output-port? current-input-port current-output-port
+ call-with-input-file call-with-output-file open-input-file
+ open-output-file close-input-port close-output-port load
+ read eof-object? read-char peek-char write display write-char
+ newline with-input-from-file with-output-to-file eval char-ready?
+ imag-part real-part magnitude numerator denominator
+ scheme-report-environment null-environment interaction-environment
+ else)))
+
+ (define geiser-r5rs-symbols
+ (make-parameter
+ '(abs acos and angle append apply asin assoc assq assv atan begin
+ boolean? caar cadr call-with-current-continuation
+ call-with-input-file call-with-output-file call-with-values
+ car case cdddar cddddr cdr ceiling char->integer char-alphabetic?
+ char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>? char-downcase
+ char-lower-case? char-numeric? char-ready? char-upcase
+ char-upper-case? char-whitespace? char<=? char<? char=? char>=?
+ char>? char? close-input-port close-output-port complex? cond cons
+ cos current-input-port current-output-port define define-syntax
+ delay denominator display do dynamic-wind else eof-object? eq?
+ equal? eqv? eval even? exact->inexact exact? exp expt floor
+ for-each force gcd if imag-part inexact->exact inexact? input-port?
+ integer->char integer? interaction-environment lambda lcm length
+ let let* let-syntax letrec letrec-syntax list list->string
+ list->vector list-ref list-tail list? load log magnitude make-polar
+ make-rectangular make-string make-vector map max member memq memv
+ min modulo negative? newline not null-environment null?
+ number->string number? numerator odd? open-input-file
+ open-output-file or output-port? pair? peek-char port? positive?
+ procedure? quasiquote quote quotient rational? rationalize read
+ read-char real-part real? remainder reverse round
+ scheme-report-environment set! set-car! set-cdr! setcar sin sqrt
+ string string->list string->number string->symbol string-append
+ string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>?
+ string-copy string-fill! string-length string-ref string-set!
+ string<=? string<? string=? string>=? string>? string? substring
+ symbol->string symbol? syntax-rules tan transcript-off transcript-on
+ truncate values vector vector->list vector-fill! vector-length
+ vector-ref vector-set! vector? with-input-from-file with-output-to-file
+ write write-char zero?)))
+
+ (define geiser-r7rs-small-symbols
+ (make-parameter
+ '(* + - ... / < <= = => > >= abs and append apply assoc assq
+ assv begin binary-port? boolean=? boolean? bytevector
+ bytevector-append bytevector-copy bytevector-copy! bytevector-length
+ bytevector-u8-ref bytevector-u8-set! bytevector? caar cadr
+ call-with-current-continuation call-with-port call-with-values call/cc
+ car case cdar cddr cdr ceiling char->integer char-ready? char<=?
+ char<? char=? char>=? char>? char? close-input-port
+ close-output-port close-port complex? cond cond-expand cons
+ current-error-port current-input-port current-output-port
+ define define-record-type define-syntax define-values denominator do
+ dynamic-wind else eof-object? equal? error error-object-message
+ even? exact-integer-sqrt exact? features floor floor-remainder
+ flush-output-port gcd get-output-string if include-ci inexact?
+ input-port? integer? lcm let let*-values let-values letrec* list
+ list->vector list-ref list-tail make-bytevector make-parameter
+ make-vector max memq min negative? not number->string numerator
+ open-input-bytevector open-output-bytevector or output-port?
+ parameterize peek-u8 positive? quasiquote quotient raise-continuable
+ rationalize read-bytevector! read-error? read-string real? reverse
+ set! set-cdr! string string->number string->utf8 string-append
+ eof-object eq? eqv? error-object-irritants error-object? exact
+ exact-integer? expt file-error? floor-quotient floor/ for-each
+ get-output-bytevector guard include inexact input-port-open?
+ integer->char lambda length let* let-syntax letrec letrec-syntax
+ list->string list-copy list-set! list? make-list make-string map
+ member memv modulo newline null? number? odd? open-input-string
+ open-output-string output-port-open? pair? peek-char port?
+ procedure? quote raise rational? read-bytevector read-char read-line
+ read-u8 remainder round set-car! square string->list string->symbol
+ string->vector string-copy string-copy! string-for-each string-map
+ string-set! string<? string>=? string? symbol->string symbol?
+ syntax-rules truncate truncate-remainder u8-ready? unquote
+ utf8->string vector vector->string vector-copy vector-fill!
+ vector-length vector-ref vector? with-exception-handler write-char
+ write-u8 string-fill! string-length string-ref string<=?
+ string=? string>? substring symbol=? syntax-error textual-port?
+ truncate-quotient truncate/ unless unquote-splicing values
+ vector->list vector-append vector-copy! vector-for-each vector-map
+ vector-set! when write-bytevector write-string zero?)))
+
+ (define geiser-chicken-builtin-symbols
+ (make-parameter
+ '(and-let* assume compiler-typecase cond-expand condition-case cut cute declare define-constant
+ define-inline define-interface define-record define-record-type define-specialization
+ define-syntax-rule define-type define-values dotimes ecase fluid-let foreign-lambda
+ foreign-lambda* foreign-primitive foreign-safe-lambda foreign-safe-lambda* functor
+ handle-exceptions import let*-values let-location let-optionals let-optionals*
+ let-values letrec* letrec-values match-letrec module parameterize regex-case
+ require-extension select set! unless use when with-input-from-pipe match
+ match-lambda match-lambda* match-let match-let* receive)))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; Utilities
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define find-module ##sys#find-module)
+ (define current-module ##sys#current-module)
+ (define switch-module ##sys#switch-module)
+ (define module-name ##sys#module-name)
+ (define (list-modules) (map car ##sys#module-table))
+
+ (define (write-to-log form) #f)
+ (define debug-log (make-parameter #f))
+
+ (if use-debug-log
+ (begin
+ (define (write-to-log form)
+ (when (not (debug-log))
+ (debug-log (file-open "~/geiser-log.txt" (+ open/wronly open/append open/text open/creat)))
+ (set-file-position! (debug-log) 0 seek/end))
+ (file-write (debug-log) (with-all-output-to-string (lambda () (write form) (newline))))
+ (file-write (debug-log) "\n"))))
+
+ ;; This really should be a chicken library function
+ (define (write-exception exn)
+ (define (write-call-entry call)
+ (let ((type (vector-ref call 0))
+ (line (vector-ref call 1)))
+ (cond
+ ((equal? type "<syntax>")
+ (display (string-append type " ")) (write line) (newline))
+ ((equal? type "<eval>")
+ (display (string-append type " ")) (write line) (newline)))))
+
+ (display (format "Error: (~s) ~s: ~s"
+ ((condition-property-accessor 'exn 'location) exn)
+ ((condition-property-accessor 'exn 'message) exn)
+ ((condition-property-accessor 'exn 'arguments) exn)))
+ (newline)
+ (display "Call history: ") (newline)
+ (map write-call-entry ((condition-property-accessor 'exn 'call-chain) exn))
+ (newline))
+
+ ;; And this should be a chicken library function as well
+ (define (with-all-output-to-string thunk)
+ (with-output-to-string
+ (lambda ()
+ (with-error-output-to-port
+ (current-output-port)
+ thunk))))
+
+ (define (maybe-call func val)
+ (if val (func val) #f))
+
+ (define (make-apropos-regex prefix)
+ (string-append "^([^#]+#)*" (regexp-escape prefix)))
+
+ (define (describe-symbol sym #!key (exact? #f))
+ (let* ((str (symbol->string sym))
+ (found (apropos-information-list (regexp (make-apropos-regex str)) #:macros? #t)))
+ (if exact?
+ (filter (lambda (v)
+ (equal? str (string-substitute ".*#([^#]+)" "\\1" (symbol->string (car v)))))
+ found)
+ found)))
+
+ ;; Wraps output from geiser functions
+ (define (call-with-result module thunk)
+ (let* ((result (if #f #f))
+ (output (if #f #f))
+ (module (maybe-call (lambda (v) (find-module module)) module))
+ (original-module (current-module)))
+
+ (set! output
+ (handle-exceptions exn
+ (with-all-output-to-string
+ (lambda () (write-exception exn)))
+ (with-all-output-to-string
+ (lambda ()
+ (switch-module module)
+ (call-with-values thunk (lambda v (set! result v)))))))
+
+ (switch-module original-module)
+
+ (set! result (if (list? result)
+ (map (lambda (v) (with-output-to-string (lambda () (write v)))) result)
+ (list (with-output-to-string (lambda () (write result))))))
+
+ (let ((out-form
+ `((result ,@result)
+ (output . ,output))))
+ (write out-form)
+ (write-to-log out-form))
+
+ (newline)))
+
+ (define geiser-toplevel-functions (make-parameter '()))
+
+ ;; This macro aids in the creation of toplevel definitions for the interpreter which are also available to code
+ ;; toplevel passes parameters via the current-input-port, and so in order to make the definition behave nicely
+ ;; in both usage contexts I defined a (get-arg) function which iteratively pulls arguments either from the
+ ;; input port or from the variable arguments, depending on context.
+ (define-syntax define-toplevel-for-geiser
+ (lambda (f r c)
+ (let* ((name (cadr f))
+ (body (cddr f)))
+ `(begin
+ (,(r 'define) (,name . !!args)
+ (,(r 'define) !!read-arg (null? !!args))
+ (,(r 'define) (get-arg)
+ (if !!read-arg
+ (read)
+ (let ((arg (car !!args)))
+ (set! !!args (cdr !!args))
+ arg)))
+ (begin ,@body))
+ (,(r 'geiser-toplevel-functions) (cons (cons ',name ,name) (geiser-toplevel-functions)))))))
+
+ (define (find-standards-with-symbol sym)
+ (append
+ (if (any (cut eq? <> sym) (geiser-r4rs-symbols))
+ '(r4rs)
+ '())
+ (if (any (cut eq? <> sym) (geiser-r5rs-symbols))
+ '(r5rs)
+ '())
+ (if (any (cut eq? <> sym) (geiser-r7rs-small-symbols))
+ '(r7rs)
+ '())
+ (if (any (cut eq? <> sym) (geiser-chicken-builtin-symbols))
+ '(chicken)
+ '())))
+
+ ;; Locates any paths at which a particular symbol might be located
+ (define (find-library-paths sym types)
+ ;; Removes the given sym from the node path
+ (define (remove-self sym path)
+ (cond
+ ((not (list? path)) path)
+ ((null? path) path)
+ ((null? (cdr path))
+ (if (eq? (car path) sym)
+ '()
+ path))
+ (else
+ (cons (car path) (remove-self sym (cdr path))))))
+
+ (append
+ (map
+ (cut list <>)
+ (find-standards-with-symbol sym))
+ (map
+ (lambda (node)
+ (remove-self sym (node-path node)))
+ (filter
+ (lambda (n)
+ (let ((type (node-type n)))
+ (any (cut eq? type <>) types)))
+ (match-nodes sym)))))
+
+ ;; Builds a signature list from an identifier
+ (define (find-signatures toplevel-module sym)
+ (define str (symbol->string sym))
+
+ (define (make-module-list sym module-sym)
+ (if (null? module-sym)
+ (find-standards-with-symbol sym)
+ (cons module-sym (find-standards-with-symbol sym))))
+
+ (define (fmt node)
+ (let* ((entry-str (car node))
+ (module (cadr node))
+ (rest (cddr node))
+ (type (if (or (list? rest) (pair? rest)) (car rest) rest)))
+ (cond
+ ((equal? 'macro type)
+ `(,entry-str ("args" (("required" <macro>)
+ ("optional" ...)
+ ("key")))
+ ("module" ,@(make-module-list sym module))))
+ ((or (equal? 'variable type)
+ (equal? 'constant type))
+ (if (null? module)
+ `(,entry-str ("value" . ,(eval sym)))
+ (let* ((original-module (current-module))
+ (desired-module (find-module (string->symbol module)))
+ (value (begin (switch-module desired-module)
+ (eval sym))))
+ (switch-module original-module)
+ `(,entry-str ("value" . ,value)
+ ("module" ,@(make-module-list sym module))))))
+ (else
+ (let ((reqs '())
+ (opts '())
+ (keys '())
+ (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
+
+ (define (clean-arg arg)
+ (string->symbol (string-substitute "(.*[^0-9]+)[0-9]+" "\\1" (symbol->string arg))))
+
+ (define (collect-args args #!key (reqs? #t) (opts? #f) (keys? #f))
+ (when (not (null? args))
+ (cond
+ ((or (pair? args) (list? args))
+ (cond
+ ((eq? '#!key (car args))
+ (collect-args (cdr args) reqs?: #f opts?: #f keys?: #t))
+ ((eq? '#!optional (car args))
+ (collect-args (cdr args) reqs?: #f opts?: #t keys?: #f))
+ (else
+ (begin
+ (cond
+ (reqs?
+ (set! reqs (append reqs (list (clean-arg (car args))))))
+ (opts?
+ (set! opts (append opts (list (cons (clean-arg (caar args)) (cdar args))))))
+ (keys?
+ (set! keys (append keys (list (cons (clean-arg (caar args)) (cdar args)))))))
+ (collect-args (cdr args))))))
+ (else
+ (set! opts (list (clean-arg args) '...))))))
+
+ (collect-args args)
+
+ `(,entry-str ("args" (("required" ,@reqs)
+ ("optional" ,@opts)
+ ("key" ,@keys)))
+ ("module" ,@(make-module-list sym module))))))))
+
+ (define (find sym)
+ (map
+ (lambda (s)
+ ;; Remove egg name and add module
+ (let* ((str (symbol->string (car s)))
+ (name (string-substitute ".*#([^#]+)" "\\1" str))
+ (module
+ (if (string-search "#" str)
+ (string-substitute "^([^#]+)#[^#]+$" "\\1" str)
+ '())))
+ (cons name (cons module (cdr s)))))
+ (describe-symbol sym exact?: #t)))
+
+ (map fmt (find sym)))
+
+ ;; Builds the documentation from Chicken Doc for a specific ymbol
+ (define (make-doc symbol #!optional (filter-for-type #f))
+ (with-output-to-string
+ (lambda ()
+ (map (lambda (node)
+ (display (string-append "= Node: " (->string (node-id node)) " " " =\n"))
+ (describe node)
+ (display "\n\n"))
+ (filter
+ (lambda (n)
+ (or (not filter-for-type)
+ (eq? (node-type n) filter-for-type)))
+ (match-nodes symbol))))))
+
+ (define (make-geiser-toplevel-bindings)
+ (map
+ (lambda (pair)
+ (toplevel-command (car pair) (cdr pair)))
+ (geiser-toplevel-functions)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Geiser toplevel functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; Basically all non-core functions pass through geiser-eval
+
+ (define-toplevel-for-geiser geiser-eval
+ ;; We can't allow nested module definitions in Chicken
+ (define (form-has-module? form)
+ (let ((reg "\\( *module +|\\( *define-library +"))
+ (string-search reg form)))
+
+ ;; Chicken doesn't support calling toplevel functions through eval,
+ ;; So when we're in a module or calling into an environment we have
+ ;; to first call from the toplevel environment and then switch
+ ;; into the desired env.
+ (define (form-has-geiser? form)
+ (let ((reg "\\( *geiser-"))
+ (string-search reg form)))
+
+ ;; All calls start at toplevel
+ (let* ((module (get-arg))
+ (form (get-arg))
+ (str-form (format "~s" form))
+ (is-module? (form-has-module? str-form))
+ (is-geiser? (form-has-geiser? str-form))
+ (host-module (and (not is-module?)
+ (not is-geiser?)
+ (any (cut equal? module <>) (list-modules))
+ module)))
+
+ (when (and module (not (symbol? module)))
+ (error "Module should be a symbol"))
+
+ ;; Inject the desired module as the first parameter
+ (when is-geiser?
+ (let ((module (maybe-call (lambda (v) (symbol->string module)) module)))
+ (set! form (cons (car form) (cons module (cdr form))))))
+
+ (define (thunk)
+ (eval form))
+
+ (write-to-log form)
+
+ (call-with-result host-module thunk)))
+
+ ;; Load a file
+
+ (define-toplevel-for-geiser geiser-load-file
+ (let* ((file (get-arg))
+ (file (if (symbol? file) (symbol->string file) file))
+ (found-file (geiser-find-file #f file)))
+ (call-with-result #f
+ (lambda ()
+ (when found-file
+ (load found-file))))))
+
+ ;; The no-values identity
+
+ (define-toplevel-for-geiser geiser-no-values
+ (values))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Miscellaneous
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; Invoke a newline
+
+ (define (geiser-newline . rest)
+ (newline))
+
+ ;; Spawn a server for remote repl access
+
+ (define (geiser-start-server . rest)
+ (let* ((listener (tcp-listen 0))
+ (port (tcp-listener-port listener)))
+ (define (remote-repl)
+ (receive (in out) (tcp-accept listener)
+ (current-input-port in)
+ (current-output-port out)
+ (current-error-port out)
+
+ (repl)))
+
+ (thread-start! (make-thread remote-repl))
+
+ (write-to-log `(geiser-start-server . ,rest))
+ (write-to-log `(port ,port))
+
+ (write `(port ,port))
+ (newline)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Completions, Autodoc and Signature
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define (geiser-completions toplevel-module prefix . rest)
+ ;; We search both toplevel definitions and module definitions
+ (let* ((prefix (if (symbol? prefix) (symbol->string prefix) prefix))
+ (re (regexp (make-apropos-regex prefix))))
+ (sort! (map (lambda (sym)
+ ;; Strip out everything before the prefix
+ (string-substitute (string-append ".*(" (regexp-escape prefix) ".*)") "\\1" (symbol->string sym)))
+ (append (apropos-list re #:macros? #t)
+ (geiser-module-completions toplevel-module prefix)))
+ string<?)))
+
+ (define (geiser-module-completions toplevel-module prefix . rest)
+ (let* ((match (string-append "^" (regexp-escape prefix))))
+ (filter (lambda (v) (string-search match (symbol->string v)))
+ (list-modules))))
+
+ (define (geiser-autodoc toplevel-module ids . rest)
+ (define (generate-details sym)
+ (find-signatures toplevel-module sym))
+
+ (if (list? ids)
+ (foldr append '()
+ (map generate-details ids))
+ '()))
+
+ (define (geiser-object-signature toplevel-module name object . rest)
+ (let* ((sig (geiser-autodoc toplevel-module `(,name))))
+ (if (null? sig) '() (car sig))))
+
+ ;; TODO: Divine some way to support this functionality
+
+ (define (geiser-symbol-location toplevel-module symbol . rest)
+ '(("file") ("line")))
+
+ (define (geiser-symbol-documentation toplevel-module symbol . rest)
+ (let* ((sig (find-signatures toplevel-module symbol)))
+ `(("signature" ,@(car sig))
+ ("docstring" . ,(make-doc symbol)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; File and Buffer Operations
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define geiser-load-paths (make-parameter '()))
+
+ (define (geiser-find-file toplevel-module file . rest)
+ (let ((paths (append '("" ".") (geiser-load-paths))))
+ (define (try-find file paths)
+ (cond
+ ((null? paths) #f)
+ ((file-exists? (string-append (car paths) file))
+ (string-append (car paths) file))
+ (else (try-find file (cdr paths)))))
+ (try-find file paths)))
+
+ (define (geiser-add-to-load-path toplevel-module directory . rest)
+ (let* ((directory (if (symbol? directory)
+ (symbol->string directory)
+ directory))
+ (directory (if (not (equal? #\/ (string-ref directory (- (string-length directory 1)))))
+ (string-append directory "/")
+ directory)))
+ (call-with-result #f
+ (lambda ()
+ (when (directory-exists? directory)
+ (geiser-load-paths (cons directory (geiser-load-paths))))))))
+
+ (define (geiser-compile-file toplevel-module file . rest)
+ (let* ((file (if (symbol? file) (symbol->string file) file))
+ (found-file (geiser-find-file toplevel-module file)))
+ (call-with-result #f
+ (lambda ()
+ (when found-file
+ (compile-file found-file))))))
+
+ ;; TODO: Support compiling regions
+
+ (define (geiser-compile toplevel-module form module . rest)
+ (error "Chicken does not support compiling regions"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Modules
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; Should return:
+ ;; '(("modules" . sub-modules) ("procs" . procedures) ("syntax" . macros) ("vars" . variables))
+ (define (geiser-module-exports toplevel-module module-name . rest)
+ (let* ((nodes (match-nodes module-name)))
+ (if (null? nodes)
+ '()
+ (let ((mod '())
+ (proc '())
+ (syn '())
+ (var '()))
+ (map
+ (lambda (node)
+ (let ((type (node-type node))
+ (name (node-id node))
+ (path (node-path node)))
+ (cond
+ ((memq type '(unit egg))
+ (set! mod (cons name mod)))
+ ((memq type '(procedure record setter class method))
+ (set! proc (cons name proc)))
+ ((memq type '(read syntax))
+ (set! syn (cons name syn)))
+ ((memq type '(parameter constant))
+ (set! var (cons name var))))))
+ nodes)
+ `(("modules" . ,mod)
+ ("proces" . ,proc)
+ ("syntax" . ,syn)
+ ("vars" . ,var))))))
+
+ ;; Returns the path for the file in which an egg or module was defined
+
+ (define (geiser-module-path toplevel-module module-name . rest)
+ #f)
+
+ ;; Returns:
+ ;; `(("file" . ,(module-path name)) ("line"))
+
+ (define (geiser-module-location toplevel-module name . rest)
+ #f)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Misc
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define (geiser-macroexpand toplevel-module form . rest)
+ (with-output-to-string
+ (lambda ()
+ (pretty-print (expand form)))))
+
+;; End module
+ )
+
+(import geiser)
+(make-geiser-toplevel-bindings)