summaryrefslogtreecommitdiff
path: root/scheme/mit/geiser
diff options
context:
space:
mode:
authorPeter <craven@gmx.net>2016-04-26 07:19:36 +0200
committerPeter <craven@gmx.net>2016-04-26 07:19:36 +0200
commitfe2c79adce933b29e4bfcc6ca6f5c5e5546095a5 (patch)
treecd8ed8493a6f7c053d74f0a0cd37e813951df797 /scheme/mit/geiser
parentdcaf849ccdfd488fb26e0d9131bbc59928690e0d (diff)
downloadgeiser-guile-fe2c79adce933b29e4bfcc6ca6f5c5e5546095a5.tar.gz
geiser-guile-fe2c79adce933b29e4bfcc6ca6f5c5e5546095a5.tar.bz2
Add preliminary support for MIT/GNU Scheme.
Diffstat (limited to 'scheme/mit/geiser')
-rw-r--r--scheme/mit/geiser/compile.scm9
-rw-r--r--scheme/mit/geiser/emacs.scm252
-rw-r--r--scheme/mit/geiser/geiser.pkg20
-rw-r--r--scheme/mit/geiser/load.scm11
4 files changed, 292 insertions, 0 deletions
diff --git a/scheme/mit/geiser/compile.scm b/scheme/mit/geiser/compile.scm
new file mode 100644
index 0000000..5817aa2
--- /dev/null
+++ b/scheme/mit/geiser/compile.scm
@@ -0,0 +1,9 @@
+(declare (usual-integrations))
+
+(load-option 'CREF)
+
+(with-working-directory-pathname
+ (directory-pathname (current-load-pathname))
+ (lambda ()
+ (cf "emacs")
+ (cref/generate-constructors "geiser" 'ALL)))
diff --git a/scheme/mit/geiser/emacs.scm b/scheme/mit/geiser/emacs.scm
new file mode 100644
index 0000000..d94c105
--- /dev/null
+++ b/scheme/mit/geiser/emacs.scm
@@ -0,0 +1,252 @@
+;;;; package: (runtime geiser)
+(declare (usual-integrations))
+
+(load-option 'format)
+
+(define (all-completions prefix environment)
+ (let (;; (prefix
+ ;; (if (environment-lookup environment 'PARAM:PARSER-CANONICALIZE-SYMBOLS?)
+ ;; (string-downcase prefix)
+ ;; prefix))
+ (completions '()))
+ (for-each-interned-symbol
+ (lambda (symbol)
+ (if (and (string-prefix-ci? prefix (symbol-name symbol)) ; was string-prefix?, now defaults to case-insensitive (MIT/GNU Scheme's default)
+ (environment-bound? environment symbol))
+ (set! completions (cons (symbol-name symbol) completions)))
+ unspecific))
+ completions))
+
+(define (operator-arglist symbol env)
+ (let ((type (environment-reference-type env symbol)))
+ (let ((ans (if (eq? type 'normal)
+ (let ((binding (environment-lookup env symbol)))
+ (if (and binding
+ (procedure? binding))
+ (cons symbol (read-from-string (string-trim (with-output-to-string
+ (lambda () (pa binding))))))
+ #f))
+ #f ;; macros
+ )))
+ ans)))
+
+(define (geiser:operator-arglist symbol env)
+ (let* ((arglist (operator-arglist symbol env))
+ (operator symbol))
+ (if arglist
+ (let loop ((arglist (cdr 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))))
+ ((eq? (car arglist) #!optional)
+ (loop (cdr arglist)
+ #t
+ required
+ optional))
+ (else
+ (loop
+ (cdr arglist)
+ optionals?
+ (if optionals? required (cons (car arglist) required))
+ (if optionals? (cons (car arglist) optional) optional)))))
+ '())))
+
+
+(define (read-from-string str)
+ (with-input-from-string str
+ read))
+
+(define (all-packages)
+ (let loop ((package (name->package '()))) ;; system-global-package
+ (cons package
+ (append-map loop (package/children package)))))
+
+(define anonymous-package-prefix
+ "environment-")
+
+(define (env->pstring env)
+ (let ((package (environment->package env)))
+ (if package
+ (write-to-string (package/name package))
+ (string anonymous-package-prefix (object-hash env)))))
+
+(define geiser-repl (nearest-repl))
+
+(define (set-geiser-repl-prompt! env)
+ (set-repl/prompt! geiser-repl (format #f "~s =>" (package/name (environment->package env))))
+ env)
+
+(define geiser-env #f)
+
+(define (get-symbol-definition-location object)
+ (let ((file (cond ((and (entity? object)
+ (procedure? object))
+ (receive (a b)
+ (compiled-entry/filename-and-index (entity-procedure object))
+ b
+ a))
+ ((compiled-procedure? object)
+ (receive (a b)
+ (compiled-entry/filename-and-index object)
+ b
+ a))
+ (else
+ '()))))
+ (fix-mit-source-dir
+ (if (and (string? file)
+ (string-suffix? ".inf" file))
+ (string-append (substring file 0 (- (string-length file) 3)) "scm")
+ file))))
+
+(define (fix-mit-source-dir filename)
+ (let ((default-location "/usr/lib/mit-scheme-x86-64/"))
+ (if (and geiser:mit-scheme-source-directory
+ (not (string-null? geiser:mit-scheme-source-directory)))
+ (if (string-prefix? default-location filename)
+ (string-append geiser:mit-scheme-source-directory (substring filename (string-length default-location) (string-length filename)))
+ filename)
+ filename)))
+
+(define geiser:mit-scheme-source-directory #f)
+
+;;;; ***************************************************************************
+
+(define (geiser:eval module form . rest)
+ rest
+ (let* ((output (open-output-string))
+ (environment (package/environment (find-package (if module module '(user)) #t)))
+ (result (with-output-to-port output
+ (lambda ()
+ (eval form environment)))))
+ (write `((result ,(write-to-string result)) (output . ,(get-output-string output))))))
+
+(define (geiser:autodoc ids . rest)
+ rest
+ (cond ((null? ids) '())
+ ((not (list? ids))
+ (geiser:autodoc (list ids)))
+ ((not (symbol? (car ids)))
+ (geiser:autodoc (cdr ids)))
+ (else
+ (let ((details (map (lambda (id) (geiser:operator-arglist id (->environment '(user)))) ids)))
+ details))))
+
+(define (geiser:module-completions prefix . rest)
+ rest
+ (filter (lambda (pstring)
+ (substring? prefix (write-to-string pstring)))
+ (map (lambda (package) (env->pstring (package/environment package))) (all-packages))))
+
+(define (geiser:completions prefix . rest)
+ rest
+ (sort (all-completions prefix (->environment '(user)))
+ string<?))
+
+(define (geiser:ge environment)
+ (let ((env (package/environment (find-package environment #t))))
+ (set-geiser-repl-prompt! env)
+ (set! geiser-env env))
+ (ge environment))
+
+(define (geiser:load-file filename)
+ (load filename))
+
+(define (geiser:module-exports module)
+ (let* ((pkg (find-package module #t))
+ (children (map package/name (package/children pkg)))
+ (env (package/environment pkg)))
+ (let loop ((vars '())
+ (procs '())
+ (syntax '())
+ (bindings (environment-bindings env)))
+ (if (null? bindings)
+ `(("vars" . ,vars) ("procs" . ,procs) ("syntax" . ,syntax) ("modules" . ,(map list children)))
+ (let* ((binding (car bindings))
+ (name (car binding))
+ (value (if (null? (cdr binding)) 'unassigned (cadr binding)))
+ (ref-type (environment-reference-type env name)))
+ (cond ((eq? 'macro ref-type)
+ (loop vars
+ procs
+ (cons `(,name ("signature")) syntax)
+ (cdr bindings)))
+ ((procedure? value)
+ (loop vars
+ (cons `(,name ("signature" . ,(geiser:operator-arglist name env))) procs)
+ syntax
+ (cdr bindings)))
+ (else
+ (loop (cons `(,name) vars)
+ procs
+ syntax
+ (cdr bindings)))))))))
+
+(define (geiser:symbol-documentation symbol)
+ (if (environment-bound? geiser-env symbol)
+ (let ((ref-type (environment-reference-type geiser-env symbol))
+ (value (environment-safe-lookup geiser-env symbol)))
+ (case ref-type
+ ((macro)
+ `(("signature" ,symbol ("args"))
+ ("docstring" . "Macro")))
+ ((unassigned)
+ `(("signature" ,symbol ("args"))
+ ("docstring" . "Value: Unassigned~%")))
+ ((normal)
+ (if (procedure? value)
+ (let ((signature (geiser:operator-arglist symbol geiser-env)))
+ `(("signature" . ,signature)
+ ("docstring" . ,(format #f "Procedure:~%~a~%" (with-output-to-string (lambda () (pp value)))))))
+ `(("signature" ,symbol ("args"))
+ ("docstring" . ,(format #f "Value:~%~a~%" (with-output-to-string (lambda () (pp value))))))
+ ))
+ (else
+ `(("signature" ,symbol ("args"))
+ ("docstring" . "Unknown thing...")))))
+ '()))
+
+(define (geiser:symbol-location symbol)
+ (if (environment-bound? geiser-env symbol)
+ (let ((ref-type (environment-reference-type geiser-env symbol))
+ (value (environment-safe-lookup geiser-env symbol)))
+ (if (eq? ref-type 'normal)
+ (let ((file (get-symbol-definition-location value)))
+ `(("name" . ,symbol)
+ ("file" . ,file)
+ ("line")))
+ '()))
+ `(("name" . ,symbol)
+ ("file")
+ ("line"))))
+
+(define (geiser:module-location symbol)
+ `(("name" . ,symbol)
+ ("file")
+ ("line")))
+
+
+(define (geiser:newline)
+ #f)
+
+(define (geiser:no-values)
+ #f)
+
+(define (geiser:set-mit-scheme-source-directory dir)
+ (set! geiser:mit-scheme-source-directory dir))
+
+(define (geiser:callers symbol)
+ symbol
+ #f)
+
+(define (geiser:callees symbol)
+ symbol
+ #f)
+
+(set-geiser-repl-prompt! (package/environment (find-package '(user))))
diff --git a/scheme/mit/geiser/geiser.pkg b/scheme/mit/geiser/geiser.pkg
new file mode 100644
index 0000000..7f67343
--- /dev/null
+++ b/scheme/mit/geiser/geiser.pkg
@@ -0,0 +1,20 @@
+;; -*-Scheme-*-
+(define-package (runtime geiser)
+ (files "emacs")
+ (parent ())
+ (export ()
+ geiser:eval
+ geiser:autodoc
+ geiser:module-completions
+ geiser:completions
+ geiser:ge
+ geiser:load-file
+ geiser:module-exports
+ geiser:symbol-documentation
+ geiser:symbol-location
+ geiser:module-location
+ geiser:callers
+ geiser:callees
+ geiser:set-mit-scheme-source-directory
+ geiser:newline
+ geiser:no-values))
diff --git a/scheme/mit/geiser/load.scm b/scheme/mit/geiser/load.scm
new file mode 100644
index 0000000..2dffd59
--- /dev/null
+++ b/scheme/mit/geiser/load.scm
@@ -0,0 +1,11 @@
+(declare (usual-integrations))
+
+(with-working-directory-pathname
+ (directory-pathname (current-load-pathname))
+ (lambda ()
+ (load "compile.scm")
+ (load-package-set "geiser"
+ `())))
+
+(add-subsystem-identification! "Geiser" '(0 1))
+