summaryrefslogtreecommitdiff
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
parentebbb1f69de76d8dac705ef3b977b1598572b87f7 (diff)
downloadgeiser-chez-383585e44e56be0e690ad96895f73abf8454d3be.tar.gz
geiser-chez-383585e44e56be0e690ad96895f73abf8454d3be.tar.bz2
Initial Chicken support
-rw-r--r--AUTHORS1
-rw-r--r--INSTALL10
-rw-r--r--Makefile.am3
-rw-r--r--README4
-rw-r--r--README.elpa12
-rw-r--r--elisp/Makefile.am1
-rw-r--r--elisp/geiser-chicken.el295
-rw-r--r--elisp/geiser-impl.el2
-rw-r--r--elisp/geiser.el12
-rw-r--r--scheme/Makefile.am3
-rw-r--r--scheme/chicken/geiser/emacs.scm665
11 files changed, 1006 insertions, 2 deletions
diff --git a/AUTHORS b/AUTHORS
index f8de9b2..fecd39d 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -11,5 +11,6 @@ Ray Racine
Nick Parker
Darren Hoo
Ludovic Courtès
+Daniel J. Leslie
See also <https://github.com/jaor/geiser/contributors>.
diff --git a/INSTALL b/INSTALL
index 5148ea4..ea45e67 100644
--- a/INSTALL
+++ b/INSTALL
@@ -50,6 +50,16 @@ package-install-file.
(require 'geiser-install)
+* Chicken Addendum
+ These steps are necessary to fully support Chicken Scheme, but are
+ not required for any other scheme.
+
+ - Install the necessary support eggs:
+ $ chicken-install -s apropos chicken-doc
+ - Update the Chicken documentation database:
+ $ cd `csi -p '(chicken-home)'`
+ $ curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | sudo tar zx
+
You're ready to go!
Geiser's makefile accepts also all those other standard autotools
diff --git a/Makefile.am b/Makefile.am
index 38be6b2..75d3ac4 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -25,10 +25,13 @@ elpa: README.elpa info
$(mkdir_p) $(scheme_dir)/guile/geiser
$(mkdir_p) $(scheme_dir)/racket/geiser
+ $(mkdir_p) $(scheme_dir)/chicken/geiser
$(INSTALL_DATA) $(abs_top_srcdir)/scheme/guile/geiser/* \
$(scheme_dir)/guile/geiser
$(INSTALL_DATA) $(abs_top_srcdir)/scheme/racket/geiser/* \
$(scheme_dir)/racket/geiser
+ $(INSTALL_DATA) $(abs_top_srcdir)/scheme/chicken/geiser/* \
+ $(scheme_dir)/chicken/geiser
$(INSTALL_DATA) $(srcdir)/doc/geiser.info $(elpa_dir)
(cd $(elpa_dir) && install-info --dir=dir geiser.info 2>/dev/null)
diff --git a/README b/README
index 3537cea..cc8bf7e 100644
--- a/README
+++ b/README
@@ -32,6 +32,7 @@
supported scheme implementations:
- Guile 2.0 or better.
- PLT Racket 5.3 or better.
+ - Chicken 4.8.0 or better.
* Installation
@@ -42,6 +43,9 @@
or byte-compiled and installed after perfoming the standard
configure/make/make install dance. See the INSTALL file for more details.
+ Chicken Scheme requires additional steps which are detailed in the INSTALL
+ file and the README.elpa file.
+
* Basic configuration
The loading invocations above install all supported Scheme
diff --git a/README.elpa b/README.elpa
index 6b1cd66..e470dcc 100644
--- a/README.elpa
+++ b/README.elpa
@@ -34,6 +34,18 @@ Main functionalities:
- Support for inline images in schemes, such as Racket, that treat
them as first order values.
+
+Chicken Addendum:
+ These steps are necessary to fully support Chicken Scheme, but are
+ not required for any other scheme.
+
+ - Install the necessary support eggs:
+ $ chicken-install -s apropos chicken-doc
+
+ - Update the Chicken documentation database:
+ $ cd `csi -p '(chicken-home)'`
+ $ curl http://3e8.org/pub/chicken-doc/chicken-doc-repo.tgz | sudo tar zx
+
See http://www.nongnu.org/geiser/ for the full manual in HTML form, or
the the info manual installed by this package.
diff --git a/elisp/Makefile.am b/elisp/Makefile.am
index 4b2b511..085d716 100644
--- a/elisp/Makefile.am
+++ b/elisp/Makefile.am
@@ -20,6 +20,7 @@ dist_lisp_LISP = \
geiser-menu.el \
geiser-mode.el \
geiser-racket.el \
+ geiser-chicken.el \
geiser-popup.el \
geiser-reload.el \
geiser-repl.el \
diff --git a/elisp/geiser-chicken.el b/elisp/geiser-chicken.el
new file mode 100644
index 0000000..8abdec3
--- /dev/null
+++ b/elisp/geiser-chicken.el
@@ -0,0 +1,295 @@
+;; geiser-chicken.el -- chicken's implementation of the geiser protocols
+
+;; Copyright (C) 2014 Daniel Leslie
+
+;; Based on geiser-guile.el by Jose Antonio Ortego Ruize
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the Modified BSD License. You should
+;; have received a copy of the license along with this program. If
+;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
+
+;; Start date: Sun Mar 08, 2009 23:03
+
+
+(require 'geiser-connection)
+(require 'geiser-syntax)
+(require 'geiser-custom)
+(require 'geiser-base)
+(require 'geiser-eval)
+(require 'geiser-edit)
+(require 'geiser-log)
+(require 'geiser)
+
+(require 'compile)
+(require 'info-look)
+
+(eval-when-compile (require 'cl))
+
+
+(defconst geiser-chicken-builtin-keywords
+ '("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"))
+
+;;; Customization:
+
+(defgroup geiser-chicken nil
+ "Customization for Geiser's Chicken flavour."
+ :group 'geiser)
+
+(geiser-custom--defcustom geiser-chicken-binary
+ (cond ((eq system-type 'windows-nt) "csi.exe")
+ ((eq system-type 'darwin) "csi")
+ (t "csi"))
+ "Name to use to call the Chicken executable when starting a REPL."
+ :type '(choice string (repeat string))
+ :group 'geiser-chicken)
+
+(geiser-custom--defcustom geiser-chicken-load-path nil
+ "A list of paths to be added to Chicken's load path when it's
+started."
+ :type '(repeat file)
+ :group 'geiser-chicken)
+
+(geiser-custom--defcustom geiser-chicken-init-file "~/.chicken-geiser"
+ "Initialization file with user code for the Chicken REPL.
+If all you want is to load ~/.csirc, set
+`geiser-chicken-load-init-file-p' instead."
+ :type 'string
+ :group 'geiser-chicken)
+
+(geiser-custom--defcustom geiser-chicken-load-init-file-p nil
+ "Whether to load ~/.chicken when starting Chicken.
+Note that, due to peculiarities in the way Chicken loads its init
+file, using `geiser-chicken-init-file' is not equivalent to setting
+this variable to t."
+ :type 'boolean
+ :group 'geiser-chicken)
+
+(geiser-custom--defcustom geiser-chicken-extra-keywords nil
+ "Extra keywords highlighted in Chicken scheme buffers."
+ :type '(repeat string)
+ :group 'geiser-chicken)
+
+(geiser-custom--defcustom geiser-chicken-case-sensitive-p t
+ "Non-nil means keyword highlighting is case-sensitive."
+ :type 'boolean
+ :group 'geiser-chicken)
+
+
+;;; REPL support:
+
+(defun geiser-chicken--binary ()
+ (if (listp geiser-chicken-binary)
+ (car geiser-chicken-binary)
+ geiser-chicken-binary))
+
+(defun geiser-chicken--parameters ()
+ "Return a list with all parameters needed to start Chicken.
+This function uses `geiser-chicken-init-file' if it exists."
+ (let ((init-file (and (stringp geiser-chicken-init-file)
+ (expand-file-name geiser-chicken-init-file)))
+ (n-flags (and (not geiser-chicken-load-init-file-p) '("-n"))))
+ `(,@(and (listp geiser-chicken-binary) (cdr geiser-chicken-binary))
+ ,@n-flags "-include-path" ,(expand-file-name "chicken/" geiser-scheme-dir)
+ ,@(apply 'append (mapcar (lambda (p) (list "-include-path" p))
+ geiser-chicken-load-path))
+ ,@(and init-file (file-readable-p init-file) (list init-file)))))
+
+(defconst geiser-chicken--prompt-regexp "#[^;]*;[^:0-9]*:?[0-9]+> ")
+
+;;; Evaluation support:
+
+(defun geiser-chicken--geiser-procedure (proc &rest args)
+ (let ((fmt
+ (case proc
+ ((eval compile)
+ (let ((form (mapconcat 'identity (cdr args) " ")))
+ (format ",geiser-eval %s %s" (or (car args) "#f") form)))
+ ((load-file compile-file)
+ (format ",geiser-load-file %s" (car args)))
+ ((no-values)
+ ",geiser-no-values")
+ (t
+ (let ((form (mapconcat 'identity args " ")))
+ (format "(geiser-%s %s)" proc form))))))
+ ;;(message fmt)
+ fmt))
+
+(defconst geiser-chicken--module-re
+ "( *module +\\(([^)]+)\\|[^ ]+\\)\\|( *define-library +\\(([^)]+)\\|[^ ]+\\)")
+
+(defun geiser-chicken--get-module (&optional module)
+ (cond ((null module)
+ (save-excursion
+ (geiser-syntax--pop-to-top)
+ (if (or (re-search-backward geiser-chicken--module-re nil t)
+ (looking-at geiser-chicken--module-re)
+ (re-search-forward geiser-chicken--module-re nil t))
+ (geiser-chicken--get-module (match-string-no-properties 1))
+ :f)))
+ ((listp module) module)
+ ((stringp module)
+ (condition-case nil
+ (car (geiser-syntax--read-from-string module))
+ (error :f)))
+ (t :f)))
+
+(defun geiser-chicken--module-cmd (module fmt &optional def)
+ (when module
+ (let* ((module (geiser-chicken--get-module module))
+ (module (cond ((or (null module) (eq module :f)) def)
+ (t (format "%s" module)))))
+ (and module (format fmt module)))))
+
+(defun geiser-chicken--import-command (module)
+ (geiser-chicken--module-cmd module "(use %s)"))
+
+(defun geiser-chicken--enter-command (module)
+ (geiser-chicken--module-cmd module ",m %s" module))
+
+(defun geiser-chicken--exit-command () ",q")
+
+(defun geiser-chicken--symbol-begin (module)
+ (save-excursion (skip-syntax-backward "^-()>") (point)))
+
+;;; Error display
+
+(defun geiser-chicken--display-error (module key msg)
+ (newline)
+ (when (stringp msg)
+ (save-excursion (insert msg))
+ (geiser-edit--buttonize-files))
+ (and (not key) msg (not (zerop (length msg)))))
+
+;;; Trying to ascertain whether a buffer is Chicken Scheme:
+
+(defconst geiser-chicken--guess-re
+ (regexp-opt (append '("csi" "chicken") geiser-chicken-builtin-keywords)))
+
+(defun geiser-chicken--guess ()
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward geiser-chicken--guess-re nil t)))
+
+(defun geiser-chicken--external-help (id module)
+ "Loads chicken doc into a buffer"
+ (browse-url (format "http://api.call-cc.org/cdoc?q=%s&query-name=Look+up" id)))
+
+;;; Keywords and syntax
+
+(defun geiser-chicken--keywords ()
+ `((,(format "[[(]%s\\>" (regexp-opt geiser-chicken-builtin-keywords 1)) . 1)))
+
+(geiser-syntax--scheme-indent
+ (receive 2)
+ (match 1)
+ (match-lambda 0)
+ (match-lambda* 0)
+ (match-let scheme-let-indent)
+ (match-let* 1)
+ (match-letrec 1)
+ (declare 0)
+ (cond-expand 0)
+ (let-values scheme-let-indent)
+ (let*-values scheme-let-indent)
+ (letrec-values 1)
+ (letrec* 1)
+ (parameterize scheme-let-indent)
+ (let-location 1)
+ (foreign-lambda 2)
+ (foreign-lambda* 2)
+ (foreign-primitive 2)
+ (foreign-safe-lambda 2)
+ (foreign-safe-lambda* 2)
+ (set! 1)
+ (let-optionals* 2)
+ (let-optionals 2)
+ (condition-case 1)
+ (fluid-let 1)
+ (and-let* 1)
+ (assume 1)
+ (cut 1)
+ (cute 1)
+ (when 1)
+ (unless 1)
+ (dotimes 1)
+ (compiler-typecase 1)
+ (ecase 1)
+ (use 0)
+ (require-extension 0)
+ (import 0)
+ (handle-exceptions 2)
+ (regex-case 1)
+ (define-inline 1)
+ (define-constant 1)
+ (define-syntax-rule 1)
+ (define-record-type 1)
+ (define-values 1)
+ (define-record 1)
+ (define-specialization 1)
+ (define-type 1)
+ (with-input-from-pipe 1)
+ (select 1)
+ (functor 3)
+ (define-interface 1)
+ (module 2))
+
+;;; REPL startup
+
+(defconst geiser-chicken-minimum-version "4.8.0.0")
+
+(defun geiser-chicken--version (binary)
+ (shell-command-to-string (format "%s -e \"(display (chicken-version))\""
+ binary)))
+
+(defun connect-to-chicken ()
+ "Start a Chicken REPL connected to a remote process."
+ (interactive)
+ (geiser-connect 'chicken))
+
+(defun geiser-chicken--startup (remote)
+ (compilation-setup t)
+ (let ((geiser-log-verbose-p t))
+ (geiser-eval--send/wait (format "(load \"%s\")\n"
+ (expand-file-name "chicken/geiser/emacs.scm" geiser-scheme-dir)))))
+
+;;; Implementation definition:
+
+(define-geiser-implementation chicken
+ (unsupported-procedures '(callers callees generic-methods))
+ (binary geiser-chicken--binary)
+ (arglist geiser-chicken--parameters)
+ (version-command geiser-chicken--version)
+ (minimum-version geiser-chicken-minimum-version)
+ (repl-startup geiser-chicken--startup)
+ (prompt-regexp geiser-chicken--prompt-regexp)
+ (debugger-prompt-regexp nil)
+ (enter-debugger nil)
+ (marshall-procedure geiser-chicken--geiser-procedure)
+ (find-module geiser-chicken--get-module)
+ (enter-command geiser-chicken--enter-command)
+ (exit-command geiser-chicken--exit-command)
+ (import-command geiser-chicken--import-command)
+ (find-symbol-begin geiser-chicken--symbol-begin)
+ (display-error geiser-chicken--display-error)
+ (external-help geiser-chicken--external-help)
+ (check-buffer geiser-chicken--guess)
+ (keywords geiser-chicken--keywords)
+ (case-sensitive geiser-chicken-case-sensitive-p))
+
+(geiser-impl--add-to-alist 'regexp "\\.scm$" 'chicken t)
+(geiser-impl--add-to-alist 'regexp "\\.release-info$" 'chicken t)
+(geiser-impl--add-to-alist 'regexp "\\.meta$" 'chicken t)
+(geiser-impl--add-to-alist 'regexp "\\.setup$" 'chicken t)
+
+(provide 'geiser-chicken)
diff --git a/elisp/geiser-impl.el b/elisp/geiser-impl.el
index 38d22fa..d2b440a 100644
--- a/elisp/geiser-impl.el
+++ b/elisp/geiser-impl.el
@@ -28,7 +28,7 @@
:type 'symbol
:group 'geiser-implementation)
-(geiser-custom--defcustom geiser-active-implementations '(guile racket)
+(geiser-custom--defcustom geiser-active-implementations '(guile racket chicken)
"List of active installed Scheme implementations."
:type '(repeat symbol)
:group 'geiser-implementation)
diff --git a/elisp/geiser.el b/elisp/geiser.el
index 1905a0c..fb5b46a 100644
--- a/elisp/geiser.el
+++ b/elisp/geiser.el
@@ -81,6 +81,17 @@
"Connect to a remote Geiser Racket REPL." t)
;;;###autoload
+(autoload 'run-chicken "geiser-chicken" "Start a Geiser Chicken REPL." t)
+
+;;;###autoload
+(autoload 'switch-to-chicken "geiser-chicken"
+ "Start a Geiser Chicken REPL, or switch to a running one." t)
+
+;;;###autoload
+(autoload 'connect-to-chicken "geiser-chicken"
+ "Connect to a remote Geiser Chicken REPL." t)
+
+;;;###autoload
(autoload 'geiser-mode "geiser-mode"
"Minor mode adding Geiser REPL interaction to Scheme buffers." t)
@@ -109,6 +120,7 @@
geiser-guile
geiser-image
geiser-racket
+ geiser-chicken
geiser-implementation
geiser-xref))
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)