Permalink
Browse files

add Commentary

  • Loading branch information...
1 parent 2fbde47 commit 48be6f33ef35f38377740c1cc87adfa45ef16b24 @kosh04 committed Jun 9, 2009
Showing with 274 additions and 66 deletions.
  1. +106 −19 init.lsp
  2. +168 −47 newlisp.el
View
125 init.lsp
@@ -1,10 +1,10 @@
-;;; -*- encoding: utf-8 -*-
+;;; -*- encoding: utf-8 -*-
;;;
;;; init.lsp --- newLISP initialization file
;;;
(let ((e (env "NEWLISPDIR")))
- (unless (directory? e)
+ (when (and e (not (directory? e)))
(println (format "warning: directory %s not found." e))))
(define (find-symbol str (cxt (context)))
@@ -35,6 +35,7 @@
acc)))
(define (utf8?)
+ "unicode対応のnewLISPならばtrue,そうでなければnilを返す."
(primitive? MAIN:utf8))
(define (newlisp-version)
@@ -54,16 +55,28 @@
(define (load-guiserver)
(silent
- (print "loading guiser...")
- (load (merge-pathnames "guiserver.lsp" (env "NEWLISPDIR")))
+ (print "loading guiserver...")
+ (load (real-path (append (env "NEWLISPDIR") "/guiserver.lsp")))
(gs:init)
(print "done.")))
(define (load-init.lsp)
- (load (real-path "init.lsp" (env "NEWLISPDIR"))))
+ (load (real-path (string (env "NEWLISPDIR") "/init.lsp"))))
+
+(define declare (lambda-macro () nil))
(define (xml-parse-file file parse-dtd parse-ns)
- (xml-parse (read-file file)))
+ (declare (ignore parse-dtd parse-dtd))
+ (let ((tags (xml-type-tags)))
+ (local (e)
+ (xml-type-tags nil 'cdata '!-- nil)
+ (if (catch (xml-parse (read-file file) (+ 1 2 8)) 'e)
+ (begin (apply xml-type-tags tags) e)
+ (begin (apply xml-type-tags tags) (throw-error e))))))
+
+(setq default-xml-type-tags (xml-type-tags))
+;; ファイルから読み込むと効かない?
+;; (xml-type-tags nil 'cdata '!-- nil)
; (global 'progn 't 'null)
; (constant (global 'cdr) rest) ; 全ての名前空間で使えるように
@@ -80,7 +93,7 @@
(define progn begin)
(define (funcall f) (apply f (args)))
(define let* letn)
-(define lexical-let letex) ; Emacs cl-package
+(define lexical-let letex) ; from Emacs cl-package
(define intern sym) ; or make-symbol
(define symbol-name name)
(define char-code char) ; (char "A") => 65
@@ -96,10 +109,17 @@
(letex ((f (args 0)))
(lambda ()
(not (apply f (args)))))))
-(define-macro (identity) (eval (args 0)))
+(define identity
+ (lambda-macro ()
+ (eval (args 0))))
(define read-from-string read-expr)
+;; simple-loop
+(define-macro (loop)
+ (let ((return throw))
+ (catch (while true (map eval (args))))))
+
;;; @@filesystem, pathname
(define (merge-pathnames pathname (defaults "."))
(real-path (cond ((file? pathname) pathname)
@@ -111,15 +131,20 @@
(define set-default-directory change-dir)
(define cd change-dir)
(define cat read-file)
-(define file-exist-p file?)
-(define (probe-file pathname)
+(define (file-exist-p pathname)
(or (file? pathname)
- (real-path pathname)))
+ (directory? pathname)))
+(define (probe-file pathname)
+ (and (file? pathname)
+ (real-path pathname)))
+;; (define (getenv variable) (env variable))
+;; (define (setenv variable value) (env variable value))
(define getenv env)
+(define setenv env)
;;; @@number
-(constant 'most-positive-fixnum 0x7fffffffffffffff) ; 63bit?
+(constant 'most-positive-fixnum 0x7fffffffffffffff)
(constant 'most-negative-fixnum 0x8000000000000000)
(defconstant pi (mul (atan 1) 4)) ; 3.141592654
(define equal =)
@@ -161,15 +186,19 @@
(define remove-if-not filter)
(define common-lisp:delete ; 破壊的な意味で
(lambda-macro ()
- (replace (eval (args 0)) (eval (args 1)))))
+ (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)
(letn ((lists (cons lst (args)))
(minlength (apply min (map length lists))))
(apply map (cons f (map (lambda (x)
(slice x 0 minlength))
lists)))))
;; (mapcar list '(1 2 3 4) '(10 nil 30) '(100 200 300 400 500 600))
-;;=> ((1 10 100) (2 nil 200) (3 30 300))
+;; => ((1 10 100) (2 nil 200) (3 30 300))
+;; (map list '(1 2 3 4) '(10 nil 30) '(100 200 300 400 500 600))
+;; => ((1 10 100) (2 nil 200) (3 30 300) (4 nil 400))
;;; @@sequence, regexp
(define split-string parse)
@@ -200,7 +229,9 @@
;; 大文字小文字の区別をしない文字列比較
(define (string-equal string1 string2)
- (if (regex (string "^" (regex-quote string1) "$") string2 1) true nil))
+ (let ((PCRE_CASELESS 1))
+ (if (regex (string "^" (regex-quote string1) "$") string2 PCRE_CASELESS)
+ true nil)))
(define (string-left-trim char-bag str)
(if (string? char-bag)
@@ -229,8 +260,10 @@
(define (trim-whitespace str)
(string-trim " \t\r\n" str))
+;; (char seq idx)
(define (elt seq idx)
- (char (seq idx)))
+ (cond ((string? seq) (char (seq idx)))
+ (true (seq idx))))
;;; @@error
(define error throw-error)
@@ -246,20 +279,74 @@
;; (error-number) の値も変わってしまう
(context 'unwind-protect)
(define-macro (unwind-protect:unwind-protect)
- (letex ((body (args 0))
+ (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)
+(define (pathname? str)
+ (or (file? str) (directory? str)))
+
+(define (curl--head url)
+ (silent
+ (print (get-url url "header"))))
+(define curl-I curl--head)
+;; (curl--head "http://www.newlisp.org/")
+
+(define (arglist fname)
+ (let ((def (eval fname)))
+ (cond ((primitive? def)
+ (setq fname (name fname))
+ (if (find fname "|+*-")
+ (push "\\" fname)) ; ex: "*" => "\\*"
+ ;; 置換の順番間違えると s/</< になるので注意 (`&' は最初に置換)
+ (replace "&" fname "&")
+ (replace "<" fname "&lt;")
+ (replace ">" fname "&gt;")
+ (letn ((manfile (real-path (string (env "NEWLISPDIR") "/newlisp_manual.html"))
+ ;; "http://www.newlisp.org/newlisp_manual.html"
+ )
+ ;; 複数行だと見つからないな(xml-type-tags)
+ (html (join (find-all (format "<b>(syntax: \\(%s[\\) ].*?)</b>" fname)
+ (read-file manfile))
+ "\n")))
+ (replace "<.*?>" html "" 0)
+ (replace "&lt;" html "<")
+ (replace "&gt;" html ">")
+ (replace "&amp;" html "&")
+ (println html)
+ ;; 見つかった?
+ (not (empty? html))))
+ ((or (lambda? def)
+ (macro? def))
+ ;; ユーザ定義の関数、マクロ
+ ;; (args)が使われていて、引数が少ない可能性もあるので注意
+ ;; 特にマクロ
+ (cons fname (first def))))))
+
(when (= ostype "Win32")
- (import "user32" "MessageBoxA")
+
(define (message-box text (title "newLISP"))
+ (import "user32" "MessageBoxA")
(let ((MB_OK 0))
(MessageBoxA 0 text title MB_OK 1)))
- )
+
+ (define (get-short-path-name pathname)
+ (unless (file-exist-p pathname)
+ (throw-error (format "Pathname not found: %s" pathname)))
+ (setq pathname (real-path pathname)) ; フルパスに正規化
+ (import "kernel32.dll" "GetShortPathNameA")
+ (letn ((len 512)
+ (strBuff (dup "\000" len)))
+ ;; 戻り値を有効活用するならこれ (ただし評価順序を間違えると落ちるので注意)
+ ;; (0 (GetShortPathNameA pathname strBuff len) strBuff)
+ (GetShortPathNameA pathname strBuff len)
+ (trim strBuff)
+ ))
+ ) ; end of (when (= ostype "Win32")
(define (one-line str) (replace "[\r|\n]" str " " 0))
View
215 newlisp.el
@@ -1,33 +1,63 @@
-;;; newlisp.el --- newLISP mode for Emacs
+;;; -*- mode:emacs-lisp; coding:utf-8 -*-
+;;;
+;;; newlisp.el --- newLISP editing mode for Emacs
+
+;;; Time-stamp: <2009-06- 9T07:17:51>
+
+;; Author: Shigeru Kobayashi <shigeru.kb@gmail.com>
+;; Version: 0.1a
+;; Keywords: language,lisp
;; This file is NOT part of GNU Emacs.
-;; Time-stamp: <2009-04-19T16:46:25>
+;;; Commentary:
+
+;; LISP風軽量スクリプト言語`newLISP'を編集するための簡単なメジャーモードです。
+;;
+;; newLISP Home - http://www.newlisp.org/
+;;
+;; 最新バージョンはこちらにあります:
+;; http://github.com/kosh04/newlisp-files/tree/master
-;; Usage:
+;;; Usage:
;; (require 'newlisp)
-;; (add-to-list 'auto-mode-alist '("\\.lsp$" . newlisp-mode))
-
-;; Todo:
-;; - newlisp-eval-buffer を独立プロセスで
-;; - newlisp-mode
-;; - 色付け (newlisp-mode.el, elisp-font-lock.el)
-;; - シンボル補完 -> etags, complete-symbol, dabbrev-expand
-;; - pop-to-buffer は縦分割を好む人もいるかも
-;; - elisp の書式チェック (checkdoc) -> 関数にはドキュメントを書けってさ
-;; - defcustomなど
-;; - 構文ステーブルを弄る (`|' はシンボル, `#' はコメント)
+;; (push '("\\.lsp$" . newlisp-mode) auto-mode-alist)
+;; (newlisp-mode-setup)
+
+;;; ChangeLog:
+;; 2009-06-05 version 0.1a
+;; - font-lock 若干修正
+;; - newlisp-mode-syntax-table 追加
+;; 2009-04-19 version 0.1
+;; - newlisp-mode, font-lock 追加
+;; 2008-12-15 version 0.01
+;; - 初版作成 (newlisp-mode)
+
+;;; Known bugs/problems:
+;; - 初回起動時の評価が表示されずに溜まることがある(ubuntu)
+
+;;; Todo:
+;; - シンボル補完 (etags, complete-symbol, [d]abbrev)
+;; - pop-to-buffer は縦分割を好む人もいるかもしれない
+;; - elisp の書式チェック (checkdoc)
+;; - defcustom
+;; - 出力だけでなく入力も*newlisp*バッファに送るべきかもしれない
;; - 全ては気の赴くままに
;;; Code:
(eval-when-compile (require 'cl))
-(require 'comint)
+(require 'comint) ; comint-send-string
;; (require 'inf-lisp)
-(defvar *newlisp-command* "newlisp")
+(defvar *newlisp-command* "newlisp"
+ "newLISP execute binary filename.")
+
;; (defvar *newlisp-command-option* "")
-(defvar *newlisp-process-coding-system* '(utf-8 . utf-8))
+(defvar *newlisp-process-coding-system* '(utf-8 . utf-8)
+ "Cons of coding systems used for process newLISP (input . output).
+If you use newLISP version UTF-8 support, Its value is '(utf-8 . utf-8).
+Otherwise maybe '(sjis . sjis).")
(defun newlisp-process ()
(let ((default-process-coding-system *newlisp-process-coding-system*))
@@ -46,8 +76,20 @@
(defalias 'run-newlisp 'newlisp-show-repl)
(defun newlisp-eval (str-sexp)
+ "Eval newlisp s-expression."
(interactive "snewLISP eval: ")
(let ((proc (newlisp-process)))
+ ;; (sit-for 0.2) ; 同期のやり方がわからないので適当に誤魔化す
+ '(with-current-buffer (process-buffer proc)
+ (goto-char (point-max))
+ (insert str-sexp ?\n)
+;; (set-marker comint-last-input-start (point))
+;; (set-marker comint-last-input-end (point))
+;; (set-marker comint-last-output-start (point))
+;; (set-marker comint-accum-marker nil)
+ (set-marker (process-mark proc) (point))
+ ;; (goto-char (point-max))
+ )
(labels ((sendln (str)
(comint-send-string proc (concat str "\n"))))
(sendln "[cmd]")
@@ -63,15 +105,14 @@
(interactive)
(let ((opoint (point)))
(unwind-protect
- (with-syntax-table lisp-mode-syntax-table
- (newlisp-eval-region (progn
- ;; 'hoge
- (unless (looking-at "\\_<")
- (backward-sexp))
- (point))
- (progn
- (forward-sexp)
- (point))))
+ (newlisp-eval-region (progn
+ ;; 'hoge
+ (unless (looking-at "\\_<")
+ (backward-sexp))
+ (point))
+ (progn
+ (forward-sexp)
+ (point)))
(goto-char (max (point) opoint)))))
(defun newlisp-eval-defun ()
@@ -119,19 +160,74 @@
(pop-to-buffer (process-buffer process))))))))
))
+;; lisp.el:571
(defun newlisp-complete-symbol (&optional predicate)
+ "Perform completion on newLISP symbol preceding point."
(interactive)
(error "Undefined"))
+(eval-when (compile load eval)
+ (defvar *newlisp-primitives*
+ ;; newLISP v.10.0.0 on Win32 IPv4 UTF-8
+ '("!" "!=" "$" "%" "&" "*" "+" "-" "/" ":" "<" "<<" "<=" "=" ">" ">=" ">>" "NaN?"
+ "^" "abort" "abs" "acos" "acosh" "add" "address" "amb" "and" "append" "append-file"
+ "apply" "args" "array" "array-list" "array?" "asin" "asinh" "assoc" "atan" "atan2"
+ "atanh" "atom?" "base64-dec" "base64-enc" "bayes-query" "bayes-train" "begin" "beta"
+ "betai" "bind" "binomial" "bits" "butlast" "callback" "car" "case" "cat" "catch"
+ "cd" "cdr" "ceil" "change-dir" "char" "char-code" "chop" "clean" "close" "code-char"
+ "command-event" "compile-regexp" "concat" "cond" "cons" "constant" "context" "context?"
+ "copy" "copy-file" "copy-seq" "cos" "cosh" "count" "cpymem" "crc32" "crit-chi2"
+ "crit-z" "current-line" "curry" "date" "date-value" "debug" "dec" "decf" "def-new"
+ "default" "delete" "delete-file" "delete-url" "destroy"
+ "det" "device" "difference" "directory" "directory?" "div" "do-until" "do-while"
+ "doargs" "dolist" "dostring" "dotimes" "dotree" "dump" "dup" "empty?" "encrypt"
+ "ends-with" "env" "equal" "erf" "error" "error-event" "error-number" "error-text"
+ "eval" "eval-string" "every" "exec" "exists" "exit" "exp" "expand" "explode" "export"
+ "expt" "factor" "fft" "file-info" "file?" "filter" "find" "find-all" "find-if" "first"
+ "flat" "float" "float?" "floor" "flt" "for" "for-all" "format" "fv" "gammai" "gammaln"
+ "gcd" "get-char" "get-float" "get-int" "get-long" "get-string" "get-url" "getenv"
+ "global" "global?" "if" "if-not" "ifft" "import" "inc" "incf" "index" "int" "integer"
+ "integer?" "intern" "intersect" "intersection" "invert" "irr" "join" "lambda?" "last"
+ "legal?" "length" "let" "let*" "letex" "letn" "lexical-let" "list" "list?" "load"
+ "local" "log" "logand" "logior" "lognot" "logxor" "lookup" "lower-case" "macro?"
+ "main-args" "make-dir" "map" "mat" "match" "max" "member" "min" "mod" "mul" "multiply"
+ "name" "net-accept" "net-close" "net-connect" "net-error" "net-eval" "net-interface"
+ "net-listen" "net-local" "net-lookup" "net-peek" "net-peer" "net-receive" "net-receive-from"
+ "net-receive-udp" "net-select" "net-send" "net-send-to" "net-send-udp" "net-service"
+ "net-sessions" "new" "nil?" "normal" "not" "now" "nper" "npv" "nth" "null?" "number?"
+ "open" "or" "pack" "parse" "pipe" "pmt" "pop" "pop-assoc" "position" "post-url"
+ "pow" "pretty-print" "primitive?" "print" "println" "prob-chi2" "prob-z" "process"
+ "progn" "prompt-event" "protected?" "push" "put-url" "pv" "quote" "quote?" "rand"
+ "random" "randomize" "read-buffer" "read-char" "read-expr" "read-file" "read-from-string"
+ "read-key" "read-line" "real-path" "ref" "ref-all" "regex" "regex-comp" "remove-dir"
+ "remove-duplicates" "remove-if-not" "rename-file" "replace" "reset" "rest" "reverse"
+ "rotate" "rotatef" "round" "save" "search" "seed" "seek" "select" "semaphore" "sequence"
+ "series" "set" "set-default-directory" "set-difference" "set-locale" "set-ref" "set-ref-all"
+ "setenv" "setf" "setq" "sgn" "share" "signal" "silent" "sin" "sinh" "sleep" "slice"
+ "sort" "source" "spawn" "split-string" "sqrt" "starts-with" "string" "string-capitalize"
+ "string-downcase" "string-upcase" "string?" "sub" "swap" "sym" "symbol-name" "symbol?"
+ "symbols" "sync" "sys-error" "sys-info" "tan" "tanh" "throw" "throw-error" "time"
+ "time-of-day" "timer" "title-case" "trace" "trace-highlight" "transpose" "trim"
+ "true?" "unicode" "unify" "unique" "unless" "unpack" "until" "upper-case" "utf8"
+ "utf8len" "uuid" "when" "while" "write-buffer" "write-char" "write-file" "write-line"
+ "xml-error" "xml-parse" "xml-type-tags" "zero?" "|" "~")
+ "newLISP primitive keyword list.")
+ ) ; eval-when
+
(defun newlisp-mode-setup ()
(setq *newlisp-process-coding-system*
(let ((res (shell-command-to-string
- (format "%s -n -e \"(primitive? MAIN:utf8)\"" *newlisp-command*))))
+ (format "%s -n -e \"%s\"" *newlisp-command* '(primitive? MAIN:utf8)))))
(if (string-match "true" res)
'(utf-8 . utf-8)
'(shift_jis . shift_jis)))) ; or 'sjis ?
- ;; $ newlisp -n -e "(builtin-symbols)"
- )
+ (setq *newlisp-primitives*
+ (car (read-from-string
+ (shell-command-to-string
+ (format "%s -n -e \"%s\"" *newlisp-command*
+ '(map name (filter (fn (s) (primitive? (eval s)))
+ (symbols MAIN))))))))
+ t)
(defmacro defindent (operator indentation)
`(put ',operator 'lisp-indent-function ',indentation))
@@ -161,34 +257,46 @@
(define-key newlisp-mode-map [f5] 'newlisp-execute-file)
(define-key newlisp-mode-map "\C-m" 'newline-and-indent)
+(defvar newlisp-mode-syntax-table
+ (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
+ ;; SYMBOL
+ (modify-syntax-entry ?` "_ " table)
+ (modify-syntax-entry ?, "_ " table)
+ (modify-syntax-entry ?@ "_ " table)
+ (modify-syntax-entry ?| "_ " table)
+ (modify-syntax-entry ?\[ "_ " table)
+ (modify-syntax-entry ?\] "_ " table)
+ ;; STRING (match)
+ (modify-syntax-entry ?\{ "(} " table)
+ (modify-syntax-entry ?\} "){ " table)
+ ;; COMMENT
+ (modify-syntax-entry ?# "< " table)
+ ;; ESCAPE
+ ;; ?\\ は通常はエスケープ文字だが、{}で囲まれた文字列内の場合はリテラルになる
+ table))
+
;;;###autoload
(defun newlisp-mode ()
"Major mode for editing newLISP code to run in Emacs."
(interactive)
(kill-all-local-variables)
- (use-local-map newlisp-mode-map)
(setq major-mode 'newlisp-mode
mode-name "newLISP")
- (lisp-mode-variables 'and-use-lisp-syntax)
- ;; `#'もコメント扱いにしたい
+ (use-local-map newlisp-mode-map)
+ (lisp-mode-variables)
+ (set-syntax-table newlisp-mode-syntax-table)
+ ;; (setq font-lock-defaults nil)
;; (set (make-local-variable 'font-lock-keywords-case-fold-search) nil)
(run-mode-hooks 'newlisp-mode-hook))
;; $ html2txt $NEWLISPDIR/newlisp_manual.html -o newlisp_manual.txt
-(defvar *newlisp-manual-text* "C:/home/lxuser/newlisp/newlisp_manual.txt")
-
-(defvar *newlisp-symbols*
- (eval-when-compile
- (car (read-from-string
- (shell-command-to-string
- (format "%s -n -e \"(map name (symbols MAIN))\"" *newlisp-command*))))))
+(defvar *newlisp-manual-text* "newlisp_manual.txt")
(defun newlisp-manual-from-text (str)
(interactive
(list (completing-read "newLISP manual: "
- *newlisp-symbols*
- nil t
- (car (member (current-word) *newlisp-symbols*)))))
+ #1=*newlisp-primitives* nil t
+ (car (member (thing-at-point 'symbol) #1#)))))
(let ((obuf (current-buffer)))
(pop-to-buffer (find-file-noselect *newlisp-manual-text*))
(toggle-read-only t)
@@ -199,13 +307,22 @@
(pop-to-buffer obuf)
(message "Function Not Found: %s" str)))))
-(put 'font-lock-add-keywords 'lisp-indent-function 1)
-;; see lisp-mode.el:91
+(define-key newlisp-mode-map "\C-ch" 'newlisp-manual-from-text)
+
+(defun newlisp-browse-manual ()
+ (interactive)
+ (browse-url (cond ((file-exists-p #1="/usr/share/doc/newlisp/manual_frame.html")
+ #1#)
+ (:else
+ "http://www.newlisp.org/downloads/manual_frame.html"))))
+
+;; (put 'font-lock-add-keywords 'lisp-indent-function 1)
+;; lisp-mode.el:91
(font-lock-add-keywords 'newlisp-mode
(list
;; (list "\\<\\(FIXME\\):" 1 font-lock-warning-face 'prepend)
(cons (eval-when-compile
- (regexp-opt *newlisp-symbols* 'words))
+ (regexp-opt *newlisp-primitives* 'words))
font-lock-keyword-face)
(cons (eval-when-compile
(regexp-opt '("define" "lambda" "fn" "define-macro" "lambda-macro") 'words))
@@ -218,11 +335,15 @@
font-lock-constant-face)
(cons (eval-when-compile
(regexp-opt '("Class" "MAIN" "Tree") 'words))
- font-lock-builtin-face)
+ font-lock-type-face)
+ (cons (eval-when-compile
+ (regexp-opt '("[text]" "[/text]" "[cmd]" "[/cmd]")))
+ font-lock-preprocessor-face)
(cons (eval-when-compile
(regexp-opt '("peek" "fork" "wait-pid" "net-ping" "parse-date") 'words))
font-lock-warning-face)
- ))
+ )
+ )
;; (defun newlisp-make-regexp-opt (&rest strings) (eval-when-compile (regexp-opt strings 'words)))

0 comments on commit 48be6f3

Please sign in to comment.