Skip to content

Commit

Permalink
add `swank-newlisp.lsp'. and others few modified.
Browse files Browse the repository at this point in the history
  • Loading branch information
@kosh04
kosh04 committed Sep 12, 2009
1 parent ec9173b commit 5846a44
Show file tree
Hide file tree
Showing 6 changed files with 1,276 additions and 643 deletions.
216 changes: 129 additions & 87 deletions init.lsp
View file
@@ -1,59 +1,68 @@
;;; -*- encoding: utf-8 -*- ;;; -*- encoding: utf-8 -*-
;;; ;;;
;;; init.lsp --- newLISP initialization file ;;; init.lsp --- newLISP initialization file
;;; ;;;


(let ((e (env "NEWLISPDIR"))) (let ((e (env "NEWLISPDIR")))
(when (and e (not (directory? e))) (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))) (define (find-symbol str (cxt (context)))
(sym str cxt nil)) (sym str cxt nil))


;; (protected? 'define) => true ;; (protected? 'define) => true
;; (primitive? define) => true ;; (primitive? 'define) => nil
(define (builtin? symbol) (define (builtin? symbol)
(or (primitive? (eval symbol)) (or (primitive? (eval symbol))
(starts-with (string symbol) "$") ; $0 ... $15 (starts-with (string symbol) "$") ; $0 ... $15
;; or more symbols ;; or more symbols
(member symbol '(nil true ostype MAIN Tree Class @)) (member symbol '(nil true ostype MAIN Tree Class @))
)) ))
;; (define builtin? protected?)


(define (user-symbols) (define (user-symbols)
(filter (lambda (s) (not (builtin? s))) (filter (lambda (s) (not (builtin? s)))
(symbols))) (symbols)))


(define (apropos str (do-print? nil)) (define (apropos str (do-print nil))
"指定した正規表現STRに一致するシンボルを返します. " "Return symbols that matches the regexp."
(let (acc) (let (acc)
(dolist (symbol (symbols)) (dolist (symbol (symbols))
(if (find str (string symbol) 1) (if (find str (string symbol) 1)
(push symbol acc -1))) (push symbol acc -1)))
(if (and acc do-print?) (if (and acc do-print)
(silent (dolist (i acc) (silent (dolist (i acc)
(println i))) (println i)))
acc))) acc)))


(define top-level reset)
(define restart reset)

(define (utf8?) (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)) (primitive? MAIN:utf8))


(define (newlisp-version) (define (newlisp-version)
"Return newLISP version as integer."
(sys-info -2)) (sys-info -2))


;; v10.1.0 で若干使用変更 (define (getpid) (sys-info -3)) ; Return the Process ID of newLISP.
(define (newlisp-pid)
"Return the Process ID of newLISP."
(sys-info -3))
(define getpid newlisp-pid)
(define (getppid) (sys-info -4)) (define (getppid) (sys-info -4))

(define newlisp-pid getpid)
;; newlisp.h 参照 ;; (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) (define (type-of x)
(let (types '("bool" "bool" "integer" "float" "string" (Cell:types (& COMPARE_TYPE_MASK ((dump x) 1))))
"symbol" "context" "primitive" "cdecl" "stdcall"
"quote" "list" "lambda" "macro" "array"))
(types (& 0xf ((dump x) 1)))))


(define (load-guiserver) (define (load-guiserver)
(silent (silent
Expand All @@ -62,7 +71,7 @@
(gs:init) (gs:init)
(print "done."))) (print "done.")))


(define (load-init.lsp) (define (load-init)
(load (real-path (string (env "NEWLISPDIR") "/init.lsp")))) (load (real-path (string (env "NEWLISPDIR") "/init.lsp"))))


(define declare (lambda-macro () nil)) (define declare (lambda-macro () nil))
Expand All @@ -76,17 +85,24 @@
(begin (apply xml-type-tags tags) e) (begin (apply xml-type-tags tags) e)
(begin (apply xml-type-tags tags) (throw-error 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)) (setq default-xml-type-tags (xml-type-tags))
;; ファイルから読み込むと効かない？ ;; ファイルから読み込むと効かない？
;; (xml-type-tags nil 'cdata '!-- nil) ;; (xml-type-tags nil 'cdata '!-- nil)


; (global 'progn 't 'null)
; (constant (global 'cdr) rest) ; 全ての名前空間で使えるように ; (constant (global 'cdr) rest) ; 全ての名前空間で使えるように
(define-macro (define-cl-function) (define-macro (define-cl-function)
(constant (global (args 0)) (eval (args 1)))) (constant (global (args 0)) (eval (args 1))))
(define (null x) (not (true? x))) (define (null x) (not (true? x)))
(define t true) ; or (constant 't true) ;; (constant (global 't) true)
(define car first) ;; (define car first)
(define (car seq)
(if (member seq '(nil ())) nil (first seq)))
(define cdr rest) (define cdr rest)
(define defconstant (define defconstant
(lambda-macro () (lambda-macro ()
Expand All @@ -104,7 +120,6 @@
(lambda-macro () (lambda-macro ()
(setf (first (eval (args 0))) (eval (args 1))) (setf (first (eval (args 0))) (eval (args 1)))
(eval (args 0)))) (eval (args 0))))
;; (subseq nil 0) => nil [CL]
(define rotatef swap) (define rotatef swap)
(define complement (define complement
(lambda-macro () (lambda-macro ()
Expand All @@ -117,10 +132,13 @@


(define read-from-string read-expr) (define read-from-string read-expr)


;; simple-loop ;; Simple LOOP
(define-macro (loop) (define-macro (loop)
(let ((return throw)) (let ((return throw))
(catch (while true (map eval (args)))))) (catch (while true
(map eval (args))))))

(define printf format)


;;; @@filesystem, pathname ;;; @@filesystem, pathname
(define (merge-pathnames pathname (defaults ".")) (define (merge-pathnames pathname (defaults "."))
Expand All @@ -131,11 +149,11 @@
(true (append defaults "/" pathname))))) (true (append defaults "/" pathname)))))
(define (user-homedir-pathname) (real-path)) (define (user-homedir-pathname) (real-path))
(define (pwd) (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 set-default-directory change-dir)
;; (define cd change-dir) ;; (define cd change-dir)
(define (cd path) (define (cd path)
(change-dir (or path (env "HOME") "."))) (change-dir (or path (env "HOME") "/")))
(define cat read-file) (define cat read-file)
(define (file-exist-p pathname) (define (file-exist-p pathname)
(or (file? pathname) (or (file? pathname)
Expand All @@ -145,18 +163,18 @@
(real-path pathname))) (real-path pathname)))


(define (file-length pathname) (define (file-length pathname)
"Retun PATHNAMEs file size as byte."
(nth 0 (file-info pathname))) (nth 0 (file-info pathname)))


;; (define (getenv variable) (env variable)) (define (getenv variable) (env variable))
;; (define (setenv variable value) (env variable value)) (define (setenv variable value) (env variable value))
(define getenv env) ;; (define getenv env)
(define setenv env) ;; (define setenv env)


;;; @@number ;;; @@number
(constant 'most-positive-fixnum 0x7fffffffffffffff) (constant 'most-positive-fixnum 0x7fffffffffffffff)
(constant 'most-negative-fixnum 0x8000000000000000) (constant 'most-negative-fixnum 0x8000000000000000)
;; (mul (acos 0) 2) (defconstant pi (mul (atan 1) 4)) ; 3.141592654 (mul (acos 0) 2)
(defconstant pi (mul (atan 1) 4)) ; 3.141592654
(define equal =) (define equal =)
(define incf inc) (define incf inc)
(define decf dec) (define decf dec)
Expand All @@ -168,11 +186,15 @@
(define logior |) (define logior |)
(define lognot ~) (define lognot ~)
(define expt pow) (define expt pow)
;; 全ての数が異なればtrue.
(define (/= number) (define (/= number)
"全ての数が異なればtrue." "true if NUMBER and rest numbers are different all. otherwise nil."
(for-all (lambda (x) (not (= x number))) (args))) (for-all (lambda (x) (not (= x number))) (args)))
;; (/= 1 2 3 1) ; nil ;; (/= 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 ;;; @@list
(define intersection intersect) (define intersection intersect)
Expand All @@ -191,15 +213,16 @@
(if (string? seq) (if (string? seq)
(replace item seq "") (replace item seq "")
(replace item seq))) (replace item seq)))
(define (remove-if f seq) ;; (define (remove-if f seq) (filter (lambda (x) (not (f x))) seq))
(filter (lambda (x) (not (f x))) seq)) (define remove-if clean)
(define remove-if-not filter) (define remove-if-not filter)
(define common-lisp:delete ; 破壊的な意味で (define common-lisp:delete ; 破壊的な意味で
(lambda-macro () (lambda-macro ()
(if (string? (eval (args 1))) (if (string? (eval (args 1)))
(replace (eval (args 0)) (eval (args 1)) "") (replace (eval (args 0)) (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))) (letn ((lists (cons lst (args)))
(minlength (apply min (map length lists)))) (minlength (apply min (map length lists))))
(apply map (cons f (map (lambda (x) (apply map (cons f (map (lambda (x)
Expand All @@ -219,6 +242,7 @@
(define string-capitalize title-case) (define string-capitalize title-case)
(define compile-regexp regex-comp) (define compile-regexp regex-comp)


;; (subseq nil 0) => nil [CL]
(define (subseq seq start end) (define (subseq seq start end)
(cond (end (slice seq start (- end start))) (cond (end (slice seq start (- end start)))
(true (slice seq start)))) (true (slice seq start))))
Expand All @@ -229,20 +253,21 @@
(define (substitute-string str pattern replacement) (define (substitute-string str pattern replacement)
(replace pattern str replacement)) (replace pattern str replacement))


(define (regex-quote regexp (extended nil)) ; regexp-quote (define (regex-quote regexp (extended nil))
(let (acc) (let (acc)
(dolist (x (explode regexp)) (dolist (x (explode regexp))
(if (member x '("$" "^" "." "*" "[" "]" "\\" "+" "?")) (if (member x '("$" "^" "." "*" "[" "]" "\\" "+" "?"))
(push "\\" acc -1)) (push "\\" acc -1))
(push x acc -1)) (push x acc -1))
(apply string acc))) (apply string acc)))
(define regexp-quote regex-quote)


;; 大文字小文字の区別をしない文字列比較
(define (string-equal string1 string2) (define (string-equal string1 string2)
"Compare two strings ignore case."
(let ((PCRE_CASELESS 1)) (let ((PCRE_CASELESS 1))
(if (regex (string "^" (regex-quote string1) "$") (list? (regex (string "^" (regex-quote string1) "$")
string2 PCRE_CASELESS) string2
true nil))) PCRE_CASELESS))))


(define (string-left-trim char-bag str) (define (string-left-trim char-bag str)
(if (string? char-bag) (if (string? char-bag)
Expand All @@ -267,50 +292,52 @@
;; (define (string-left-trim char-bag str) (trim str char-bag "")) ;; (define (string-left-trim char-bag str) (trim str char-bag ""))
;; (define (string-right-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) (define (elt seq idx)
(cond ((string? seq) (char seq idx)) (cond ((string? seq) (char seq idx))
(true (seq idx)))) (true (seq idx))))


;;; @@error ;;; @@error
(define error throw-error) (define error throw-error)


(context 'ignore-errors) ;; (context 'ignore-errors)
(define-macro (ignore-errors:ignore-errors) ;; (define-macro (ignore-errors:ignore-errors)
(letex ((body (cons 'begin (args)))) ;; (letex ((body (cons 'begin (args))))
(let (result) ;; (local (result)
(if (catch body 'result) result nil)))) ;; (if (catch body 'result) result nil))))
(context MAIN) ;; (context MAIN)


;; 再度エラーを投げるとユーザ定義のエラーになってしまうな (define (prin1-to-string obj)
;; (error-number) の値も変わってしまう (cond ((string? obj) (format"\"%s\"" (replace "\\" obj "\\\\")))
(context 'unwind-protect) ("else" (string obj))))
(define-macro (unwind-protect:unwind-protect)
(letex ((body (first (args))) (define-macro (ignore-errors)
(cleanup-form* (cons 'begin (rest (args))))) (eval-string (prin1-to-string (args 0)) (context) nil))
(local (*result*) ; letと何が違う？
(if (catch body '*result*) ;; (context 'unwind-protect)
(begin cleanup-form* *result*) ;; (define-macro (unwind-protect:unwind-protect)
(begin cleanup-form* (throw-error *result*)))))) ;; "syntax: (unwind-protext protected-form cleanup-form*)"
(context MAIN) ;; (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) (define (pathname? str)
(or (file? str) (directory? str))) (or (file? str)
(directory? str)))


(define (curl--head url) (define (curl url) (silent) (print (get-url url)))
(silent (define (curl--head url) (print (get-url url "header")) (silent))
(print (get-url url "header"))))
(define curl-I curl--head) (define curl-I curl--head)
;; (curl--head "http://www.newlisp.org/") ;; (curl--head "http://www.newlisp.org/")


(define *html-manual* (define *html-manual*
(or (exists file? (or (exists file?
(list (list (string (env "NEWLISPDIR") "/newlisp_manual.html")
(string (env "NEWLISPDIR") "/newlisp_manual.html") "/usr/share/doc/newlisp/newlisp_manual.html"))
"/usr/share/doc/newlisp/newlisp_manual.html"))
"http://www.newlisp.org/newlisp_manual.html")) "http://www.newlisp.org/newlisp_manual.html"))


(define (arglist fname) (define (arglist fname)
Expand Down Expand Up @@ -340,21 +367,34 @@
;; (args)が使われていて、引数が少ない可能性もあるので注意。特にマクロ ;; (args)が使われていて、引数が少ない可能性もあるので注意。特にマクロ
(cons fname (first def)))))) (cons fname (first def))))))


(constant 'PCRE_CASELESS 1) ;; (setq
(constant 'PCRE_MULTILINE 2) ;; PCRE_CASELESS 1
(constant 'PCRE_DOTALL 4) ;; PCRE_MULTILINE 2
(constant 'PCRE_EXTENDED 8) ;; PCRE_DOTALL 4
(constant 'PCRE_ANCHORED 16) ;; PCRE_EXTENDED 8
(constant 'PCRE_DOLLAR_ENDONLY 32) ;; PCRE_ANCHORED 16
(constant 'PCRE_EXTRA 64) ;; PCRE_DOLLAR_ENDONLY 32
(constant 'PCRE_NOTBOL 128) ;; PCRE_EXTRA 64
(constant 'PCRE_NOTEOL 256) ;; PCRE_NOTBOL 128
(constant 'PCRE_UNGREEDY 512) ;; PCRE_NOTEOL 256
(constant 'PCRE_NOTEMPTY 1024) ;; PCRE_UNGREEDY 512
(constant 'PCRE_UTF8 2048) ;; PCRE_NOTEMPTY 1024
(constant 'REPLACE_ONCE 0x8000) ;; PCRE_UTF8 2048
(constant 'PRECOMPILED 0x10000) ;; 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") (when (= ostype "Win32")
Expand All @@ -379,5 +419,7 @@


;; (prompt-event (fn (ctx) (string ctx ":" (real-path) "> "))) ;; (prompt-event (fn (ctx) (string ctx ":" (real-path) "> ")))


(println "init.lsp loading...done")

(context MAIN) (context MAIN)
;;; init.lsp ends here ;;; init.lsp ends here

0 comments on commit 5846a44

Please sign in to comment.