Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

add `swank-newlisp.lsp'. and others few modified.

  • Loading branch information...
commit 5846a4448c869bc53fc362b7be6259c17af107bd 1 parent ec9173b
@kosh04 authored
View
216 init.lsp
@@ -1,59 +1,68 @@
-;;; -*- encoding: utf-8 -*-
+;;; -*- encoding: utf-8 -*-
;;;
;;; init.lsp --- newLISP initialization file
;;;
(let ((e (env "NEWLISPDIR")))
(when (and e (not (directory? e)))
- (println (format "warning: directory %s not found." e))))
+ (println "warning: directory " e " not found.")))
+
+(constant 'stdin 0 'stdout 1 'stderr 2)
(define (find-symbol str (cxt (context)))
(sym str cxt nil))
;; (protected? 'define) => true
-;; (primitive? define) => true
+;; (primitive? 'define) => nil
(define (builtin? symbol)
(or (primitive? (eval symbol))
(starts-with (string symbol) "$") ; $0 ... $15
;; or more symbols
(member symbol '(nil true ostype MAIN Tree Class @))
))
+;; (define builtin? protected?)
(define (user-symbols)
(filter (lambda (s) (not (builtin? s)))
(symbols)))
-(define (apropos str (do-print? nil))
- "指定した正規表現STRに一致するシンボルを返します. "
+(define (apropos str (do-print nil))
+ "Return symbols that matches the regexp."
(let (acc)
(dolist (symbol (symbols))
(if (find str (string symbol) 1)
(push symbol acc -1)))
- (if (and acc do-print?)
+ (if (and acc do-print)
(silent (dolist (i acc)
(println i)))
acc)))
+(define top-level reset)
+(define restart reset)
+
(define (utf8?)
- "Non-nil means current newLISP is UTF-8 eoncoding are supported."
+ "Non-nil means newLISP is UTF-8 eoncoding are supported."
(primitive? MAIN:utf8))
(define (newlisp-version)
+ "Return newLISP version as integer."
(sys-info -2))
-;; v10.1.0 で若干使用変更
-(define (newlisp-pid)
- "Return the Process ID of newLISP."
- (sys-info -3))
-(define getpid newlisp-pid)
+(define (getpid) (sys-info -3)) ; Return the Process ID of newLISP.
(define (getppid) (sys-info -4))
-
-;; newlisp.h 参照
+(define newlisp-pid getpid)
+;; (import "libc.so.6" "getpid")
+;; こちらは[parent]newlisp->[child]newlispではなくbash(emacs)->newlisp
+;; (import "libc.so.6" "getppid")
+
+;; see newlisp.h
+(define COMPARE_TYPE_MASK 0x000F)
+(define Cell:types
+ '("bool" "bool" "integer" "float" "string"
+ "symbol" "context" "primitive" "cdecl" "stdcall"
+ "quote" "list" "lambda" "macro" "array"))
(define (type-of x)
- (let (types '("bool" "bool" "integer" "float" "string"
- "symbol" "context" "primitive" "cdecl" "stdcall"
- "quote" "list" "lambda" "macro" "array"))
- (types (& 0xf ((dump x) 1)))))
+ (Cell:types (& COMPARE_TYPE_MASK ((dump x) 1))))
(define (load-guiserver)
(silent
@@ -62,7 +71,7 @@
(gs:init)
(print "done.")))
-(define (load-init.lsp)
+(define (load-init)
(load (real-path (string (env "NEWLISPDIR") "/init.lsp"))))
(define declare (lambda-macro () nil))
@@ -76,17 +85,24 @@
(begin (apply xml-type-tags tags) e)
(begin (apply xml-type-tags tags) (throw-error e))))))
+;; (define (xml-parse-file file parse-dtd parse-ns)
+;; (let ((tags (xml-type-tags)))
+;; (unwind-protect
+;; (xml-parse (read-file file) (+ 1 2 8))
+;; (apply xml-type-tags tags))))
+
(setq default-xml-type-tags (xml-type-tags))
;; ファイルから読み込むと効かない?
;; (xml-type-tags nil 'cdata '!-- nil)
-; (global 'progn 't 'null)
; (constant (global 'cdr) rest) ; 全ての名前空間で使えるように
(define-macro (define-cl-function)
(constant (global (args 0)) (eval (args 1))))
(define (null x) (not (true? x)))
-(define t true) ; or (constant 't true)
-(define car first)
+;; (constant (global 't) true)
+;; (define car first)
+(define (car seq)
+ (if (member seq '(nil ())) nil (first seq)))
(define cdr rest)
(define defconstant
(lambda-macro ()
@@ -104,7 +120,6 @@
(lambda-macro ()
(setf (first (eval (args 0))) (eval (args 1)))
(eval (args 0))))
-;; (subseq nil 0) => nil [CL]
(define rotatef swap)
(define complement
(lambda-macro ()
@@ -117,10 +132,13 @@
(define read-from-string read-expr)
-;; simple-loop
+;; Simple LOOP
(define-macro (loop)
(let ((return throw))
- (catch (while true (map eval (args))))))
+ (catch (while true
+ (map eval (args))))))
+
+(define printf format)
;;; @@filesystem, pathname
(define (merge-pathnames pathname (defaults "."))
@@ -131,11 +149,11 @@
(true (append defaults "/" pathname)))))
(define (user-homedir-pathname) (real-path))
(define (pwd) (real-path))
-(define (namestring pathname) (real-path pathname))
+(define (namestring pathname) (merge-pathnames pathname))
(define set-default-directory change-dir)
;; (define cd change-dir)
(define (cd path)
- (change-dir (or path (env "HOME") ".")))
+ (change-dir (or path (env "HOME") "/")))
(define cat read-file)
(define (file-exist-p pathname)
(or (file? pathname)
@@ -145,18 +163,18 @@
(real-path pathname)))
(define (file-length pathname)
+ "Retun PATHNAMEs file size as byte."
(nth 0 (file-info pathname)))
-;; (define (getenv variable) (env variable))
-;; (define (setenv variable value) (env variable value))
-(define getenv env)
-(define setenv env)
+(define (getenv variable) (env variable))
+(define (setenv variable value) (env variable value))
+;; (define getenv env)
+;; (define setenv env)
;;; @@number
(constant 'most-positive-fixnum 0x7fffffffffffffff)
(constant 'most-negative-fixnum 0x8000000000000000)
-;; (mul (acos 0) 2)
-(defconstant pi (mul (atan 1) 4)) ; 3.141592654
+(defconstant pi (mul (atan 1) 4)) ; 3.141592654 (mul (acos 0) 2)
(define equal =)
(define incf inc)
(define decf dec)
@@ -168,11 +186,15 @@
(define logior |)
(define lognot ~)
(define expt pow)
+;; 全ての数が異なればtrue.
(define (/= number)
- "全ての数が異なればtrue."
+ "true if NUMBER and rest numbers are different all. otherwise nil."
(for-all (lambda (x) (not (= x number))) (args)))
;; (/= 1 2 3 1) ; nil
-;; (!= 1 2 3 1) ; true
+;; (!= 1 2 3 1) ; true ?
+
+;; treat integer operators (+-*/) as float operators (add sub mul div).
+;; (constant '+ add '- sub '* mul '/ div)
;;; @@list
(define intersection intersect)
@@ -191,15 +213,16 @@
(if (string? seq)
(replace item seq "")
(replace item seq)))
-(define (remove-if f seq)
- (filter (lambda (x) (not (f x))) seq))
+;; (define (remove-if f seq) (filter (lambda (x) (not (f x))) seq))
+(define remove-if clean)
(define remove-if-not filter)
(define common-lisp:delete ; 破壊的な意味で
(lambda-macro ()
(if (string? (eval (args 1)))
(replace (eval (args 0)) (eval (args 1)) "")
(replace (eval (args 0)) (eval (args 1))))))
-(define (mapcar f lst) ; (mapcar function list &rest more-lists)
+(define (mapcar f lst)
+ "syntax: (mapcar function list &rest more-lists)"
(letn ((lists (cons lst (args)))
(minlength (apply min (map length lists))))
(apply map (cons f (map (lambda (x)
@@ -219,6 +242,7 @@
(define string-capitalize title-case)
(define compile-regexp regex-comp)
+;; (subseq nil 0) => nil [CL]
(define (subseq seq start end)
(cond (end (slice seq start (- end start)))
(true (slice seq start))))
@@ -229,20 +253,21 @@
(define (substitute-string str pattern replacement)
(replace pattern str replacement))
-(define (regex-quote regexp (extended nil)) ; regexp-quote
+(define (regex-quote regexp (extended nil))
(let (acc)
(dolist (x (explode regexp))
(if (member x '("$" "^" "." "*" "[" "]" "\\" "+" "?"))
(push "\\" acc -1))
(push x acc -1))
(apply string acc)))
+(define regexp-quote regex-quote)
-;; 大文字小文字の区別をしない文字列比較
(define (string-equal string1 string2)
+ "Compare two strings ignore case."
(let ((PCRE_CASELESS 1))
- (if (regex (string "^" (regex-quote string1) "$")
- string2 PCRE_CASELESS)
- true nil)))
+ (list? (regex (string "^" (regex-quote string1) "$")
+ string2
+ PCRE_CASELESS))))
(define (string-left-trim char-bag str)
(if (string? char-bag)
@@ -267,10 +292,6 @@
;; (define (string-left-trim char-bag str) (trim str char-bag ""))
;; (define (string-right-trim char-bag str) (trim str "" char-bag))
-(define (trim-space str) (trim str))
-(define (trim-whitespace str)
- (string-trim " \t\r\n" str))
-
(define (elt seq idx)
(cond ((string? seq) (char seq idx))
(true (seq idx))))
@@ -278,39 +299,45 @@
;;; @@error
(define error throw-error)
-(context 'ignore-errors)
-(define-macro (ignore-errors:ignore-errors)
- (letex ((body (cons 'begin (args))))
- (let (result)
- (if (catch body 'result) result nil))))
-(context MAIN)
-
-;; 再度エラーを投げるとユーザ定義のエラーになってしまうな
-;; (error-number) の値も変わってしまう
-(context 'unwind-protect)
-(define-macro (unwind-protect:unwind-protect)
- (letex ((body (first (args)))
- (cleanup-form* (cons 'begin (rest (args)))))
- (local (*result*) ; letと何が違う?
- (if (catch body '*result*)
- (begin cleanup-form* *result*)
- (begin cleanup-form* (throw-error *result*))))))
-(context MAIN)
+;; (context 'ignore-errors)
+;; (define-macro (ignore-errors:ignore-errors)
+;; (letex ((body (cons 'begin (args))))
+;; (local (result)
+;; (if (catch body 'result) result nil))))
+;; (context MAIN)
+
+(define (prin1-to-string obj)
+ (cond ((string? obj) (format"\"%s\"" (replace "\\" obj "\\\\")))
+ ("else" (string obj))))
+
+(define-macro (ignore-errors)
+ (eval-string (prin1-to-string (args 0)) (context) nil))
+
+;; (context 'unwind-protect)
+;; (define-macro (unwind-protect:unwind-protect)
+;; "syntax: (unwind-protext protected-form cleanup-form*)"
+;; (letex ((body (first (args)))
+;; (cleanup-form* (cons 'begin (rest (args)))))
+;; (local (*result*)
+;; (if (catch body '*result*)
+;; (begin cleanup-form* *result*)
+;; (begin cleanup-form* (print "\n" *result* "\n") nil))))) ; ? throw-error
+;; (context MAIN)
+;; (global 'unwind-protext)
(define (pathname? str)
- (or (file? str) (directory? str)))
+ (or (file? str)
+ (directory? str)))
-(define (curl--head url)
- (silent
- (print (get-url url "header"))))
+(define (curl url) (silent) (print (get-url url)))
+(define (curl--head url) (print (get-url url "header")) (silent))
(define curl-I curl--head)
;; (curl--head "http://www.newlisp.org/")
(define *html-manual*
(or (exists file?
- (list
- (string (env "NEWLISPDIR") "/newlisp_manual.html")
- "/usr/share/doc/newlisp/newlisp_manual.html"))
+ (list (string (env "NEWLISPDIR") "/newlisp_manual.html")
+ "/usr/share/doc/newlisp/newlisp_manual.html"))
"http://www.newlisp.org/newlisp_manual.html"))
(define (arglist fname)
@@ -340,21 +367,34 @@
;; (args)が使われていて、引数が少ない可能性もあるので注意。特にマクロ
(cons fname (first def))))))
-(constant 'PCRE_CASELESS 1)
-(constant 'PCRE_MULTILINE 2)
-(constant 'PCRE_DOTALL 4)
-(constant 'PCRE_EXTENDED 8)
-(constant 'PCRE_ANCHORED 16)
-(constant 'PCRE_DOLLAR_ENDONLY 32)
-(constant 'PCRE_EXTRA 64)
-(constant 'PCRE_NOTBOL 128)
-(constant 'PCRE_NOTEOL 256)
-(constant 'PCRE_UNGREEDY 512)
-(constant 'PCRE_NOTEMPTY 1024)
-(constant 'PCRE_UTF8 2048)
-(constant 'REPLACE_ONCE 0x8000)
-(constant 'PRECOMPILED 0x10000)
-
+;; (setq
+;; PCRE_CASELESS 1
+;; PCRE_MULTILINE 2
+;; PCRE_DOTALL 4
+;; PCRE_EXTENDED 8
+;; PCRE_ANCHORED 16
+;; PCRE_DOLLAR_ENDONLY 32
+;; PCRE_EXTRA 64
+;; PCRE_NOTBOL 128
+;; PCRE_NOTEOL 256
+;; PCRE_UNGREEDY 512
+;; PCRE_NOTEMPTY 1024
+;; PCRE_UTF8 2048
+;; REPLACE_ONCE 0x8000
+;; PRECOMPILED 0x10000
+;; )
+
+(define (shell-command-to-string str-process)
+ (join (exec str-process) "\n"))
+
+(define nslookup net-lookup)
+
+(define (getopt optstring (has-arg nil))
+ "オプション引数の解析."
+ (let ((pos (find optstring $main-args)))
+ (if (and pos has-arg)
+ (main-args (+ pos 1))
+ (integer? pos))))
(when (= ostype "Win32")
@@ -379,5 +419,7 @@
;; (prompt-event (fn (ctx) (string ctx ":" (real-path) "> ")))
+(println "init.lsp loading...done")
+
(context MAIN)
;;; init.lsp ends here
View
78 newlisp.el
@@ -1,6 +1,6 @@
;;; newlisp.el -- newLISP editing mode for Emacs -*- coding:utf-8 -*-
-;;; Time-stamp: <2009-07-13T01:33:09>
+;;; Time-stamp: <2009-09-12T17:19:28JST>
;; Author: Shigeru Kobayashi <shigeru.kb@gmail.com>
;; Version: 0.1b
@@ -14,7 +14,7 @@
;;
;; newLISP Home - http://www.newlisp.org/
;;
-;; 最新バージョンはこちらにあります:
+;; このファイルの最新バージョンはこちらにあります:
;; http://github.com/kosh04/newlisp-files/tree/master
;;; Usage:
@@ -38,6 +38,14 @@
;; - 初回起動時の評価が表示されずに溜まってしまう場合がある
;; - 2バイト文字を含むパスから起動することができない
;; e.g. "c:/Documents and Settings/User/デスクトップ/"
+;; - newlisp.exeが$PATHにないとshell-command-to-stringを実行できない
+
+;; export PATH="$HOME/bin:$PATH"
+;; - emacsのシェルからの起動に必要
+;; (or (string-match #1=(expand-file-name "~/bin") #2=(getenv "PATH"))
+;; (setenv "PATH" (concat #1# ":" #2#)))
+;; - emacsからの起動に必要
+;; (add-to-list 'exec-path "~/bin")
;;; Todo:
;; - シンボル補完 (etags, complete-symbol, [d]abbrev)
@@ -56,7 +64,7 @@
(defvar newlisp-command "newlisp"
"newLISP execute binary filename.")
-;; (defvar newlisp-command-option "")
+;; (defvar newlisp-command-switches "")
(defvar newlisp-process-coding-system '(utf-8 . utf-8)
"Cons of coding systems used for process newLISP (input . output).
@@ -80,18 +88,10 @@ Otherwise maybe '(sjis . sjis).")
(defalias 'run-newlisp 'newlisp-show-repl)
-;; 評価の遅延はおそらく[cmd]~[/cmd]側の問題
-;; [cmd]使わないように改行をまとめようとしたらコメント文|で引っかかる...
(defun newlisp-eval (str-sexp)
"Eval newlisp s-expression."
- (interactive "snewLISP eval: ")
+ (interactive "snewLISP Eval: ")
(let ((proc (newlisp-process)))
-;; '(progn
-;; (princ (concat str-sexp "\n") (process-buffer proc))
-;; (set-marker (process-mark proc) (point-max))
-;; (with-current-buffer (process-buffer proc)
-;; (goto-char (point-max)))
-;; )
(labels ((sendln (str)
(comint-send-string proc (concat str "\n"))))
(cond ((string-match "\n" str-sexp)
@@ -102,6 +102,8 @@ Otherwise maybe '(sjis . sjis).")
(sendln str-sexp))))
(newlisp-show-repl t)))
+;; (defsetf process-filter set-process-filter)
+
(defun newlisp-eval-region (from to)
(interactive "r")
(newlisp-eval (buffer-substring-no-properties from to)))
@@ -131,10 +133,17 @@ Otherwise maybe '(sjis . sjis).")
(read-file-name "Load file: " (buffer-file-name))))
(newlisp-eval (format "(load {%s})" (expand-file-name file))))
-(defun newlisp-kill-process ()
+(defun newlisp-restart-process ()
+ "Restart a new clean newLISP process with same command-line params.
+This mode is not available on Win32."
(interactive)
- ;; (kill-process (newlisp-process))
- (newlisp-eval "(exit)"))
+ (newlisp-eval "(reset true)"))
+
+(defun newlisp-kill-process (&optional force)
+ (interactive "P")
+ (if force
+ (delete-process (newlisp-process))
+ (newlisp-eval "(exit)")))
;; eval sync
(defun newlisp-eval-buffer (arg)
@@ -163,7 +172,7 @@ Otherwise maybe '(sjis . sjis).")
(cond ((zerop (buffer-size outbuf))
(kill-buffer outbuf)
(message "(no output)"))
- (t
+ (:else
(with-current-buffer outbuf
(goto-char (point-min))
(if (< (line-number-at-pos (point-max)) 5)
@@ -178,16 +187,8 @@ Otherwise maybe '(sjis . sjis).")
(interactive)
(error "Undefined"))
-(defun newlisp-begin-cmd ()
- (interactive)
- ;; 今までの入力があればついでに消したいところ
- (insert "[cmd]")
- (comint-send-input))
-
-(defun newlisp-end-cmd ()
- (interactive)
- (insert "[/cmd]")
- (comint-send-input))
+(defun newlisp-begin-cmd () (interactive) (insert "[cmd]") (comint-send-input))
+(defun newlisp-end-cmd () (interactive) (insert "[/cmd]") (comint-send-input))
;; (define-key inferior-newlisp-mode-map "\C-c[" 'newlisp-begin-cmd)
;; (define-key inferior-newlisp-mode-map "\C-c]" 'newlisp-end-cmd)
@@ -259,7 +260,7 @@ Otherwise maybe '(sjis . sjis).")
'(primitive? MAIN:utf8)))))
(if (string-match "true" res)
'(utf-8 . utf-8)
- '(shift_jis . shift_jis)))) ; or 'sjis ?
+ '(shift_jis . shift_jis))))
(setq newlisp-primitive-keywords
(car (read-from-string
(shell-command-to-string
@@ -288,6 +289,7 @@ Otherwise maybe '(sjis . sjis).")
(let ((map (make-sparse-keymap "newlisp")))
(set-keymap-parent map lisp-mode-shared-map)
map))
+(define-key newlisp-mode-map "\M-:" 'newlisp-eval)
(define-key newlisp-mode-map "\e\C-x" 'newlisp-eval-defun)
(define-key newlisp-mode-map "\C-x\C-e" 'newlisp-eval-last-sexp)
(define-key newlisp-mode-map "\C-c\C-r" 'newlisp-eval-region)
@@ -295,6 +297,7 @@ Otherwise maybe '(sjis . sjis).")
(define-key newlisp-mode-map "\C-c\C-z" 'newlisp-show-repl)
(define-key newlisp-mode-map "\e\t" 'newlisp-complete-symbol) ; ESC TAB
(define-key newlisp-mode-map [f5] 'newlisp-execute-file)
+(define-key newlisp-mode-map [(control c) f4] 'newlisp-kill-process) ; C-c f4
(define-key newlisp-mode-map "\C-m" 'newline-and-indent)
(defvar newlisp-mode-syntax-table
@@ -330,12 +333,12 @@ Otherwise maybe '(sjis . sjis).")
(run-mode-hooks 'newlisp-mode-hook))
;; $ html2txt $NEWLISPDIR/newlisp_manual.html -o newlisp_manual.txt
-;; もしくはブラウザの「ページを保存(テキスト)」
+;; or use www browser [File] -> [Save Page As (Text)]
(defvar newlisp-manual-text "newlisp_manual.txt")
(defvar newlisp-manual-html
(or (dolist (path (list "/usr/share/doc/newlisp/manual_frame.html"
- ;; When $ make install_home
+ ;; When build newlisp `make install_home'
"~/share/doc/newlisp/manual_frame.html"
"C:/Program Files/newlisp/manual_frame.html"))
(and (file-exists-p path)
@@ -346,15 +349,18 @@ Otherwise maybe '(sjis . sjis).")
(interactive)
(browse-url-of-file newlisp-manual-html))
+(defsubst newlisp-keywords ()
+ (append newlisp-primitive-keywords
+ newlisp-lambda-keywords
+ newlisp-un*x-based-function-keywords))
+
(defun newlisp-browse-manual-from-text (str)
(interactive
- ;; FIXME: "lambda?" が選択できない
- (list (completing-read "newLISP manual: "
- #1=(append newlisp-primitive-keywords
- newlisp-lambda-keywords
- newlisp-un*x-based-function-keywords)
- nil t
- (car (member (thing-at-point 'symbol) #1#)))))
+ ;; FIXME: "lambda?" が選択できない => C-q ?
+ ;; 空文字("")いらない: REQUIRE-MATCH
+ (list (completing-read "newLISP manual: " (newlisp-keywords) nil t
+ (car (member (thing-at-point 'symbol)
+ (newlisp-keywords))))))
(let ((obuf (current-buffer)))
(pop-to-buffer (find-file-noselect newlisp-manual-text))
(toggle-read-only t)
View
1,043 newlisp_manual.txt
523 additions, 520 deletions not shown
View
BIN  newlisp_manual.txt.tar.gz
Binary file not shown
View
572 swank-newlisp.lsp
@@ -0,0 +1,572 @@
+# swank-newlisp.lsp -- Swank server for newLISP.
+#
+# Copyright (C) 2009, Shigeru Kobayashi
+#
+# This file is licensed under the terms of the GNU General Public
+# License as distributed with newLISP.
+
+;;; Commentary:
+;;
+;; This is tiny Swank server written by newLISP. It has been tested
+;; with newLISP v.10.1.1 on Ubuntu UTF-8.
+;;
+;; * newlISP is a Lisp-like, general-purpose scripting language.
+
+;;; Installation
+;;
+;; 1. Install newlisp binary. <http://www.newlisp.org/downloads/>
+;; (If ubuntu, simply type `apt-get install newlisp')
+;;
+;; 2. Add something like this to your .emacs:
+;;
+[text]
+(defun swank-newlisp-init (port-filename coding-system)
+ (format "%S\n" `(swank:start-server ,port-filename)))
+
+(setq slime-protocol-version nil) ; ignore version query (if need)
+(defvar swank-newlisp-filename "./swank-newlisp.lsp") ; This file
+(defun slime-newlisp ()
+ (interactive)
+ (let ((slime-lisp-implementations
+ `((newlisp ("newlisp" "-n" ,swank-newlisp-filename)
+ :init swank-newlisp-init
+ :coding-system utf-8-unix))))
+ (slime 'newlisp)))
+[/text]
+;;
+;; 3. Use `M-x slime-newlisp' to start it.
+;;
+;; 4. If you want to kill swank process,
+;; use `M-x slime-repl-sayoonara' (or `slime-quit-lisp')
+
+
+;;; Code:
+
+(context MAIN)
+
+(define-macro (defglobal symbol var)
+ (set (global symbol) (eval var)))
+
+(defglobal t true)
+(defglobal *stdin 0)
+(defglobal *stdout 1)
+(defglobal *stderr 2)
+
+(context 'swank) ; (in-package :swank)
+
+
+;;;; Common Lisp like functions
+
+(define let* letn)
+(define defparameter define)
+(define-macro (defvar symbol init doc)
+ "Define variable if SYMBOL value is nil."
+ (if (nil? (eval symbol))
+ (set symbol (eval init)))
+ symbol)
+
+(define-macro (defun)
+ (set (args 0) (append (fn) (cons (args 1) (2 (args))))))
+
+;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via RPC.
+(define defslimefun defun)
+
+(define progn begin)
+(define-macro (prog1 form1)
+ (let ((result (eval form1)))
+ (map eval (args))
+ result))
+
+(define (make-string n (init "\000"))
+ (dup init n))
+
+(define-macro (loop) ; simple loop
+ (let ((return throw))
+ (catch (while true (map eval (args))))))
+
+(define-macro (read-sequence)
+ "syntax: (read-sequence sequence stream)"
+ (net-receive (eval (args 1))
+ (eval (args 0))
+ (string-length (eval (args 0)))))
+
+(define (write-string str (stream *stdout))
+ (net-send stream str))
+
+(define-macro (unwind-protect form)
+ "syntax: (unwind-protect protected-form cleanup-form*) => result"
+ (local (result)
+ (if (catch (eval form) 'result)
+ (begin (map eval (args)) result)
+ (begin (map eval (args)) (throw-error result)))))
+
+;; (define-macro (with-simple-restart) ...)
+;; (define read-from-string read-expr)
+
+
+;;;; newLISP Utility
+
+(if (primitive? utf8len)
+ (define string-length utf8len)
+ (define string-length length))
+
+(define (utf8?)
+ "Non-nil means newLISP is UTF-8 eoncoding are supported."
+ (primitive? MAIN:utf8))
+
+;; to use `sys-error' `last-error' `net-error'
+(define (error-number err) (if (list? err) (nth 0 err) -1))
+(define (error-text err) (if (list? err) (nth 1 err) "What error?"))
+
+(define (find-context obj)
+ "Return context named OBJ. If not found, then return NIL."
+ (let ((x (cond ((string? obj) (eval-string obj MAIN nil))
+ ((symbol? obj) (eval-string (name obj) MAIN nil))
+ ("else" obj))))
+ (if (context? x) x nil)))
+
+(define (symbol-name x) (name x nil))
+(define (context-name x) (name x true))
+(define (symbol-context x) (find-context (context-name x)))
+
+;; (define even? (lambda (n) (= (& n 0x01) 0)))
+
+
+;;;; TCP Server
+
+(define (create-socket host port)
+ (or (net-listen port host)
+ (throw-error (net-error))))
+(define (local-port socket) (nth 1 (net-local socket)))
+(define (close-socket socket) (net-close socket))
+(define (accept-connection socket) (net-accept socket))
+
+(define (getpid) (sys-info -3))
+
+(defvar *coding-system* (if (utf8?) "UTF-8" "SHIFT_JIS"))
+
+(defvar *loopback-interface* "127.0.0.1") ; "localhost"
+(defvar default-server-port 4005)
+
+(defvar *emacs-connection*)
+
+(define (start-server port-file)
+ (setup-server default-server-port
+ (lambda (port)
+ (announce-server-port port-file port)
+ (simple-announce-function port))))
+
+(define (create-server (port default-server-port))
+ (setup-server port simple-announce-function))
+
+(define (setup-server port announce-fn)
+ (let ((socket (create-socket *loopback-interface* port)))
+ (unwind-protect
+ (progn
+ (announce-fn (local-port socket))
+ (let ((accept (accept-connection socket)))
+ (unwind-protect
+ (serve-requests accept)
+ (close-socket accept))))
+ (close-socket socket))))
+
+(define (serve-requests connection)
+ (let ((*emacs-connection* connection))
+ (loop
+ (dispatch-event (read-from-emacs))) ; dispatch-loop
+ ))
+
+;; (define (stop-server port) (close-socket *listener-sockets*))
+;; (define (restart-server port dont-close) (stop-server port) (sleep 500) (create-server port dont-close))
+
+(define (announce-server-port file port)
+ (append-file file (format "%d\n" port)))
+
+(define (simple-announce-function port)
+ (log-event ";; Listening on port: %d\n" port))
+
+(define (read-from-emacs)
+ (decode-message *emacs-connection*))
+
+(define (decode-message stream)
+ (let* ((len (decode-message-length stream))
+ (str (make-string len))
+ (pos (read-sequence str stream)))
+ (if (!= len pos) (log-event ";; Short read: %s\n" str))
+ (string-to-rpc str)))
+
+(define (decode-message-length stream)
+ (let ((buffer (make-string 6 "@")))
+ (read-sequence buffer stream)
+ (integer buffer 0 16))) ; read integer as hex (0x10)
+
+;;; *** enable multibyte char [1]
+(when (and (!= ostype "Win32")
+ (utf8?))
+(define (decode-message stream)
+ (let* ((len (decode-message-length stream))
+ (str (make-string len "@")))
+ (dotimes (i len)
+ (setf (str i) (char (read-utf8 stream))))
+ (if (!= len (string-length str)) (log-event ";; Short read: %s\n" str))
+ ;; (log-event "READ: %s\n" str)
+ (string-to-rpc str)))
+)
+
+;;; *** enable multibyte char [2]
+;; (define (decode-message stream)
+;; (local (header str)
+;; (net-receive stream header 6)
+;; (net-receive stream str 1024) ; read buffer, but HEADER length ignored
+;; (if (!= (int header 0 0x10) (utf8len str))
+;; (log-event ";; Short read: %s\n" str))
+;; (string-to-rpc str)) )
+
+(define (send-to-emacs object)
+ (encode-message object *emacs-connection*))
+
+(define (encode-message message stream)
+ (let* ((str (rpc-to-string message))
+ (len (string-length str)))
+ (log-event "WRITE: %s\n" str)
+ (write-string (format "%06x" len) stream)
+ (write-string str stream)))
+
+;; Normal RPC use (:emacs-rex ...)
+;; newLISP RPC use (":emacs-rex" ...)
+(define (dispatch-event event)
+ (log-event "DISPATCHING: %s\n" (string event))
+ (case (event 0)
+ (":emacs-rex" ; (:emacs-rex form package thread-id id)
+ (apply emacs-rex (rest event)))
+ (true
+ (letex ((_id (event -1)))
+ (log-event "Unhandled event: %s\n" (string event))
+ (send-to-emacs '(":write-string" "; Evaluation aborted.\n" ":repl-result"))
+ (send-to-emacs '(":return" (":abort") _id))
+ ;; (throw-to-toplevel)
+ ))))
+
+;; (define (simple-repl)
+;; (loop
+;; (print (format "%s> " (context-name (context))))
+;; (let ((expr (read-expr (read-line))))
+;; (cond ((null? (current-line)) (println "; No value"))
+;; ("else" (println (eval expr)))))))
+
+;;;; Logging
+
+(defvar *log-events* true)
+(defvar *log-output* *stderr)
+
+(define (log-event)
+ "syntax: (log-event format-string &rest args)"
+ (when *log-events*
+ (write-buffer *log-output* (apply format (args)))))
+
+;;;; IO to Emacs
+
+;; (string-to-rpc "(:emacs-rex (swank:swank-require :swank-presentations) \"COMMON-LISP-USER\" :repl-thread 3)" )
+;; => (":emacs-rex" (swank:swank-require ":swank-presentations") "COMMON-LISP-USER" ":repl-thread" 3)
+(define (string-to-rpc str)
+ (let ((to-rpc
+ (lambda (lst)
+ (let ((rpc '()) (kwd? nil))
+ (dolist (x lst)
+ (cond ((and (symbol? x) (= (symbol-name x) ":"))
+ (setq kwd? true))
+ (kwd?
+ (push (format ":%s" (name x)) rpc -1) ; x -> ":x"
+ (setq kwd? nil))
+ ((list? x)
+ (push (to-rpc x) rpc -1))
+ ("else"
+ (push x rpc -1))))
+ rpc))))
+ (to-rpc (read-expr str))))
+
+;; (rpc-to-string '(":emacs-rex" (":return" expr) id))
+;; => "(:emacs-rex (:return expr) id)"
+(define (rpc-to-string form)
+ (let ((create-rpc
+ (lambda (x)
+ (cond ((and (string? x)
+ ;; (even? $idx)
+ (starts-with x ":"))
+ (sym x)) ; ":x" -> :x
+ ((and (list? x) (not (lambda? x)) (not (macro? x)))
+ (map create-rpc x))
+ ("else" x)))))
+ (string (map create-rpc form))))
+
+;; or prin1-to-string
+;; (read-expr (to-string STRING)) == STRING
+(define (to-string obj)
+ (cond ((string? obj) (format"\"%s\"" (replace "\\" obj "\\\\")))
+ ("else" (string obj))))
+
+;; (define (pseudo-debug exc)
+;; (let ((level 1))
+;; (send-to-emacs `(":debug" 0 ,level ,@(sldb-info exc 0 20)))
+;; (unwind-protect
+;; (sldb-loop exc)
+;; (send-to-emacs `(":debug-return" 0 ,level nil)))))
+
+;; (define (sldb-loop exc) (while true (dispatch (read-packet @io))))
+;; (define (sldb-info exc start _end) )
+;; (define (sldb-restarts exc) '(("Quit" "SLIME top-level.")))
+;; (define (sldb-backtrace exc start _end) )
+;; (define (frame-src-loc exc frame) )
+
+(defslimefun connection-info ()
+ (letex ((_pid (getpid))
+ (_version (sys-info -2)))
+ '(":pid" _pid
+ ":style" nil
+ ":package" (":name" "MAIN"
+ ":prompt" "")
+ ":lisp-implementation" (":type" "newLISP"
+ ":name" "newlisp"
+ ":version" _version)
+ ":machine" (":instance" "" ":type" "" ":version" "")
+ ":features" ()
+ ;; ":version" *swank-wire-protocol-version*
+ )))
+
+(defslimefun create-repl (target)
+ (list "MAIN" ""))
+
+(defslimefun swank-require (modules filename)
+ nil)
+
+(defslimefun default-directory ()
+ (real-path))
+
+(defslimefun set-default-directory (dir)
+ (unless (change-dir dir)
+ (log-event "change-dir error: `%s' %s\n" dir (last (sys-error))))
+ dir)
+
+(defslimefun load-file (filename)
+ (load filename))
+
+(defslimefun quit-lisp ()
+ (exit))
+
+;;;; Evaluation
+
+(defvar *buffer-context* MAIN) ; *buffer-package*
+
+(defvar *error-object* (sym "#:ERR"))
+(define (error? obj) (= obj *error-object*))
+
+(define (eval-string-for-emacs str)
+ (let ((value (eval-string str *buffer-context* *error-object*)))
+ (prog1
+ (cond ((error? value)
+ (log-event "EVAL-STRING ERROR [%s]: %s\n"
+ (string *buffer-context*) (error-text (last-error)))
+ (error-text (eval-error)))
+ ("else"
+ (to-string value)))
+ (set-context-maybe str) )))
+
+(define (set-context-maybe str)
+ (when (regex "\\(context '?(\\w+)\\)" str)
+ (let* ((cname $1) (ctx (find-context cname)))
+ (when (context? ctx)
+ (setf *buffer-context* ctx)
+ ;; (:new-package PACKAGE-NAME PACKAGE-STRING-FOR-PROMPT)
+ (send-to-emacs
+ (list ":new-package" cname (context-string-for-prompt cname)))))))
+
+(define (context-string-for-prompt ctx)
+ (or (context? ctx)
+ (setq ctx (find-context ctx)))
+ (if (= ctx MAIN) "" (string ctx)))
+
+;; > (+ 1 2 3 nil) => #:ERR
+;; > (println (error-text (last-error)))
+;; ERR: value expected in function + : nil
+;; called from user defined function swank:eval-string-for-emacs
+;; called from user defined function swank:listener-eval
+;; called from user defined function swank:dispatch-event
+;; called from user defined function swank:serve-requests
+;; called from user defined function swank:setup-server
+;; called from user defined function swank:start-server
+;; > (println (error-text (eval-error)))
+;; ERR: invalid function
+(define (eval-error)
+ "Reports the last error without swank-server error."
+ (let ((err (last-error)))
+ (and err (let ((n (error-number err)))
+ (list n (format "ERR: %s" (error-text (last-error n))))))))
+
+;; or eval-for-emacs
+(define (emacs-rex form ctx thread-id id)
+ (local (error-handler)
+ (or (catch
+ (letex ((_expr (eval form)) (_id id))
+ (send-to-emacs '(":return" (":ok" _expr) _id)))
+ 'error-handler)
+ (letex ((_id id)) ; error occurred at (EVAL FORM)
+ (log-event "ABORT: %s\n" error-handler)
+ (send-to-emacs '(":write-string" "; Evaluation aborted.\n" ":repl-result"))
+ (send-to-emacs '(":return" (":abort") _id)))
+ )))
+
+(defslimefun interactive-eval (str)
+ (eval-string-for-emacs str))
+
+(defslimefun interactive-eval-region (str)
+ (interactive-eval str))
+
+;; C-u C-x C-e
+;; (defslimefun eval-and-grab-output (str)
+;; (listener-eval str))
+
+(defslimefun throw-to-toplevel ()
+ (throw 'swank-toplevel))
+
+;;;; Listener eval
+
+(defslimefun listener-eval (str)
+ (letex ((_result (eval-string-for-emacs str) ))
+ (send-to-emacs '(":write-string" _result ":repl-result"))
+ (send-to-emacs '(":write-string" "\n" ":repl-result"))
+ nil))
+
+(defslimefun buffer-first-change (filename) nil)
+
+;;;; Compilation
+
+;; (define (swank-compile-string str &key buffer position directory) nil)
+(define (swank-compile-file filename load-p external-format) nil)
+(define (find-external-format coding-system) :default)
+(define (guess-external-format filename) nil)
+
+(defslimefun compile-string-for-emacs (str buffer pos dir)
+ (eval-string-for-emacs str)
+ '("T" "0.01")) ; ?
+
+;; *** This function Removed at 2008-07-16 (see SLIME Changelog)
+(defslimefun compiler-notes-for-emacs () nil)
+
+;; snarf-string
+;; call-compiler
+
+(defslimefun simple-completions (str package) '(nil nil))
+(defslimefun list-all-package-names (str) nil)
+
+;;;; Streams
+
+(define (make-fn-streams input-fn output-fn) nil)
+(define (make-stream-interactive stream) nil)
+
+;;; Arglist
+
+(defslimefun operator-arglist (fname ctx)
+ (let* ((*buffer-context* (or (find-context ctx)
+ *buffer-context*))
+ (symbol (read-expr fname *buffer-context* nil))
+ (alist (arglist symbol)))
+ (cond ((list? alist) (to-string (cons symbol alist)))
+ ("else" "nil"))))
+
+(defslimefun arglist-for-echo-area (raw-specs)
+ "syntax: (raw-specs &key arg-indices print-right-margin print-lines)"
+ (let ((lst (match '((?) *) raw-specs)))
+ (and lst
+ (let* ((symbol (read-expr (first lst) *buffer-context* nil))
+ (alist (arglist symbol)))
+ (and (!= alist nil)
+ (to-string (cons symbol alist))))
+ )))
+
+;;;; Documentation
+
+(define (arglist fname)
+ "Return function arguments list."
+ (let ((def (eval fname)))
+ (cond ((or (lambda? def) (macro? def))
+ (first def))
+ ("else" nil)))) ; ":not-available"
+
+(define (function-name function) nil)
+(define (macroexpand-all form) nil)
+(define (compiler-macroexpand-1 form &optional e) nil)
+(define (compiler-macroexpand form &optional e) nil)
+(define (describe-symbol-for-emacs symbol) nil)
+(define (describe-definition def-name type) nil)
+(define (variable-desc-for-echo-area) nil)
+
+;; (defslimefun find-definitions-for-emacs (str) "./swank-newlisp.lsp")
+
+;;;; Fuzzy Symbol Completion
+
+;; contrib/swank-fuzzy.lisp
+(defslimefun fuzzy-completions
+ (str default-package-name &key limit time-limit-in-msec)
+ '(() nil))
+
+;;;; Macroexpansion
+
+(defslimefun swank-macroexpand-1 (str) nil)
+
+;;;; Debugging
+
+;;;; XREF
+
+(define (who-calls function-name) nil)
+(define (who-references variable-name) nil)
+(define (who-binds variable-name) nil)
+(define (who-sets variable-name) nil)
+(define (who-macroexpands macro-name) nil)
+(define (who-specializes class-name) nil)
+(define (list-callers function-name) nil)
+(define (list-callees function-name) nil)
+
+;;;; Profiling
+
+(define (profile fname) nil)
+(define (profiled-functions) nil)
+(define (unprofile fname) nil)
+(define (unprofile-all) nil)
+(define (profile-report) nil)
+(define (profile-reset) nil)
+(define (profile-package package callers-p methods) nil)
+
+;;;; Apropos
+
+(defslimefun apropos-list-for-emacs
+ (pattern only-external? case-sensitive? package)
+ nil)
+
+;;;; Inspector
+
+;;;; Multithreading
+
+;;;; Auxilary functions
+
+(define (swank:io-speed-test (n 1000) (m 1)) nil)
+
+(define (save-image filename (restart-function nil))
+ (save filename))
+
+(define ignore (lambda () nil))
+
+(define cl:defparameter define)
+(define cl:compile ignore)
+(define cl:foobar ignore)
+(define cl:m-v-l ignore)
+(define (cl:lisp-implementation-type) "newLISP")
+(define (cl:class-name class) nil)
+(define cl:aref ignore)
+(define cl:loop ignore)
+
+;; (signal (constant 'SIGINT 2) exit)
+
+
+(context MAIN)
+
+;;; swank-newlisp.lsp ends here.
View
10 swank-newlisp.sh
@@ -0,0 +1,10 @@
+#!/bin/sh
+
+newlisp -n swank-newlisp.lsp -e "(swank:create-server)"
+
+# newlisp -n <<EOF
+# (load "./swank-newlisp.lsp")
+# (swank:create-server)
+# EOF
+
+# and then `M-x slime-connect' Host:127.0.0.1, Port:4005
Please sign in to comment.
Something went wrong with that request. Please try again.