Permalink
Browse files

updates

  • Loading branch information...
1 parent 2944a5f commit 1f5e48a6832d9de7ffb86ff64e24b8e37f348834 @kosh04 committed Feb 3, 2011
Showing with 230 additions and 117 deletions.
  1. +13 −13 arglist.lsp
  2. +10 −6 argv.lsp
  3. +67 −21 cl.lsp
  4. +41 −5 files.lsp → filesys.lsp
  5. +28 −17 io.lsp
  6. +29 −30 net.lsp
  7. +27 −25 regex.lsp
  8. +15 −0 unicode.lsp
View
@@ -7,47 +7,38 @@
;;
;; - [] (&optional)
;; - ... (&rest, args)
-;;
;; - string, list, (array) -> seq, sequence
;; - int-file, str-device -> device
-;; - int, float -> num (integer-only -> int)
+;; - int, float -> num
+;; - integer-only -> int
;; - primitive, lambda, sym-function -> function
;; - test-function -> predicate
;; - exp -> obj, form
;; ChangeLog:
;; v10.2.9 [+] net-ipv
;; v10.2.8 [+] net-packet,
-;; [*] net-connect, get-url, post-url, put-url, delete-url
-;; net-service
+;; [*] net-connect, get-url, post-url, put-url, delete-url, net-service
;; v10.2.1 [+] term, prefix, self, extend, read, write, ++, --
;; [-] name
;; TODO:
;; * FIXMEの見直し
;; * http://www.newlisp.org/downloads/newlisp_manual.html#type_ids
;; -> array,body,bool,context,exp,func,int,list,num,matrix,place,str,sym,sym-context
+;; * Win32システムで利用できない関数の扱い
;;; Code:
(new Tree 'Arglist) ; make hash-table
-(define-macro (defargs fname lambda-list)
- (Arglist (string fname) lambda-list))
-
(define (subr-name f)
(and (primitive? f)
(let ((cell->aux
;; see newlisp.c:printCell
(lambda (x) (nth 3 (dump x)))))
(get-string (cell->aux f)))))
-;;;##interface
-(define-macro (arglist f)
- (let ((lst (arglist-1 (eval f))))
- (when lst
- (cons (sym f) lst))))
-
;(arglist cons) => (cons x y)
;(arglist-1 cons) => (x y)
(define (arglist-1 f)
@@ -59,6 +50,15 @@
((context? f) (arglist-1 (default f)))
("else" (Arglist (string f)))))
+;;;##interface
+(define-macro (arglist f)
+ (let ((lst (arglist-1 (or (eval f) f))))
+ (when lst
+ (cons (sym f) lst))))
+
+(define-macro (defargs fname lambda-list)
+ (Arglist (string fname) lambda-list))
+
(defargs ! (command))
(defargs $ (index))
(defargs + ([num ...]))
View
@@ -7,8 +7,10 @@
;; - 2010-01-21 初版作成
;; - 2010-10-04
;; なるべくnewlisp起動時の流れに沿うように修正
-;; (-startのような失敗する引数も許すようになった)
+;; ("-start" のような失敗する引数も許すようになった)
;; オプション-t,-6の追加
+;; - 2011-01-29
+;; オプション-vの追加
;;; TODO
;;
@@ -19,23 +21,24 @@
(define invocation-name (first $main-args)) ; "newlisp" or "newlisp.exe"
(define $argv (rest $main-args))
+;; @syntax (argv index)
(define (argv i)
(cond (i (if (< i (length $argv)) ($argv i) nil))
(true $argv)))
-;; @syntax: (pop-args str value?)
+;; @syntax (pop-args str value?)
(define (pop-args str (has-value nil))
(let ((n (find str $argv
(lambda (x y)
(starts-with y x)))))
(when n
(cond
((and has-value (= 2 (length (argv n)))) ; "-arg" "value"
- (if (empty? ((+ n 1) $argv))
- (throw-error (string "missing parameter for " (argv n))))
- (pop $argv (+ n 1))
+ (if (empty? ((+ n 1) $argv))
+ (write 2 (string "missing parameter for " (argv n) "\n")) ; XXX
+ (pop $argv (+ n 1)))
(pop $argv n))
- (true ; "-arg[value]"
+ (true ; "-arg[value]"
(pop $argv n))))
nil))
@@ -55,6 +58,7 @@
(pop-args "-p" true)
(pop-args "-d" true)
(pop-args "-t" true)
+(pop-args "-v")
(pop-args "-w" true)
(pop-args "-6")
View
88 cl.lsp
@@ -1,36 +1,65 @@
;;; cl.lsp --- Common Lisp like functions
+;;; NOTE:
+;;
+;; see "Differences to Other LISPs"
+;; - http://www.newlisp.org/index.cgi?page=Differences_to_Other_LISPs
+;; * Case-sensitive
+;; * 関数部分は事前に評価される
+;; * LISP-1
+;; * ダイナミックスコープ
+;; * ドット対が存在しない
+;; * 関数引数はデフォルトでオプショナル
+;; * 存在しないシンボルは生成時にnilに束縛される
+;; * GCの代わりにORO
+;; * Fexprマクロは引数を評価しない
+;; * パッケージの代わりにコンテキスト
+;; * Implicit Indexing
+
;; (constant (global 't) true)
+;; (define t true)
(define (null x) (not (true? x)))
-(define car first)
+;;(define car first)
+(define (car x)
+ (if (member x '(nil ())) nil (first x)))
(define cdr rest)
(define defconstant
(lambda-macro ()
(constant (args 0) (eval (args 1)))))
(define export global)
(define progn begin)
(define (funcall f) (apply f (args)))
+(define (atom obj)
+ (or (atom? obj)
+ (= obj '())))
+(define eq =)
+(define eql =)
+(define equal =)
(define let* letn)
(define intern sym) ; or make-symbol
-(define symbol-name name)
+(define symbol-name term)
+(define symbol-package prefix)
(define char-code char) ; (char "A") => 65
(define code-char char) ; (char 65) => "A"
(define rplaca ; (rplaca x y)
(lambda-macro ()
(setf (first (eval (args 0))) (eval (args 1)))
(eval (args 0))))
-(define rotatef swap)
+(define rotatef swap) ; swap accept only two variables
(define complement
(lambda-macro ()
(letex ((f (args 0)))
(lambda ()
(not (apply f (args)))))))
(define identity
- ;; なんでマクロにしたんだっけ?
- (lambda-macro ()
- (eval (args 0))))
+ ;; 引数のコピーを避けるためマクロを利用している
+ (lambda-macro () (eval (args 0))))
+
+;; FIXME: short `uuid' name is safe to use?
+(define (gensym) (sym (append "g-" (slice (uuid) 0 8))))
(define (find-symbol str (ctx (context)))
+ ;; or (context ctx str)
(sym str ctx nil))
(define read-from-string read-expr)
@@ -39,11 +68,12 @@
(constant 'most-positive-fixnum 0x7fffffffffffffff)
(constant 'most-negative-fixnum 0x8000000000000000)
(defconstant pi (mul (atan 1) 4)) ; 3.141592654 (mul (acos 0) 2)
-(define equal =)
-(define incf inc)
-(define decf dec)
+(define incf inc) ; or ++
+(define decf dec) ; or --
(define (plusp number) (< 0 number)) ; or (> number) , (sgn number nil nil true)
(define (minusp number) (< number 0)) ; or (< number) , (sgn number true nil nil)
+(define (evenp i) (= (& i 1) 0))
+(define (oddp i) (= (& i 1) 1))
(define (ash i cnt) (sgn cnt (>> i (abs cnt)) i (<< i cnt)))
(define logand &)
(define logxor ^)
@@ -65,7 +95,11 @@
((- n) lst))
(define every for-all)
(define (some f lst)
+ (if (symbol? f) (setq f (eval f)))
(dolist (obj lst (f obj))))
+(define (notany f lst)
+ (setq f (eval f))
+ (not (apply exists (list f lst $args))))
(define position find)
(define find-if exists)
(define remove-duplicates unique)
@@ -95,6 +129,13 @@
;; (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))
+(define (list* )
+ (cond ((empty? (rest (args)))
+ (first (args)))
+ (true
+ (cons (first (args))
+ (apply list* (rest (args)))))))
+
;;; @@sequence
;(define concat string)
(define (concat) (join (args)))
@@ -107,12 +148,8 @@
(cond (end (slice seq start (- end start)))
(true (slice seq start))))
-(define (string-equal string1 string2)
- "Compare two strings ignore case."
- (let ((PCRE_CASELESS 1))
- (list? (regex (string "^" (regex-quote string1) "$")
- string2
- PCRE_CASELESS))))
+(define (string-equal str1 str2)
+ (= (upper-case str1) (upper-case str2)))
(define (string-left-trim char-bag str)
(if (string? char-bag)
@@ -133,16 +170,12 @@
(define (string-trim char-bag str)
(string-right-trim char-bag (string-left-trim char-bag str)))
-;; (define (string-trim char-bag str) (trim str char-bag 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-macro (ignore-errors form)
(eval-string (prin1-to-string form) (context) nil))
;; @syntax (unwind-protect protected-form cleanup-form*) => result
;; (context 'unwind-protect)
-(letex ((result (sym (uuid))))
+(letex ((result (gensym)))
(define-macro (unwind-protect )
(local (result)
(if (catch (eval (args 0)) 'result)
@@ -151,8 +184,21 @@
)
(define (prin1-to-string obj)
- (cond ((string? obj) (format"\"%s\"" (replace "\\" obj "\\\\")))
+ (cond ((string? obj) (format {"%s"} (replace "\\" obj "\\\\")))
("else" (string obj))))
+;; parallel setq
+;; @syntax (psetq var form ...)
+(define psetq
+ (letex ((v (gensym))
+ (s (gensym)))
+ (lambda-macro ()
+ (unless (= (& (length $args) 1) 0)
+ (throw-error "missing argument"))
+ (dolist (v (map (lambda (s) (list (s 0) (eval (s 1))))
+ ;; ((var1 val1) (var2 val2) ...)
+ (explode $args 2)))
+ (set (v 0) (v 1))))))
+
(context MAIN)
;;; EOF
View
@@ -1,4 +1,4 @@
-;; files.lsp --- Fileystem Utilities
+;; filesys.lsp --- Fileystem Utilities
;; NOTE: Linuxでは存在しないファイルにrealpathを使えない
(define (merge-pathnames pathname (defaults "."))
@@ -24,11 +24,46 @@
(or (probe-file pathname)
(error "%s: No such file or directory" pathname)))
+;; FIXME: "/"
+;; (define (basename path (sfx ""))
+;; (if (= (path -1) "/")
+;; (setq path (chop path)))
+;; (catch
+;; (for (idx 1 (length path))
+;; (when (= (path (- idx)) "/")
+;; (setq path ((- 1 idx) path))
+;; (throw 'found))))
+;; (if (ends-with path sfx)
+;; (setq path (chop path (length sfx))))
+;; path)
+
(define (basename path (sfx ""))
- (if (= path "")
- path
- (string-right-trim sfx
- (last (parse path "[\\/]" 0)))))
+ (if (= (path -1) "/")
+ (setq path (chop path)))
+ (setq path (last (or (parse path "[\\/]" 0) '("/"))))
+ (if (ends-with path sfx)
+ (setq path (chop path (length sfx))))
+ path)
+
+;; "/usr/lib" => "/usr"
+;; "/usr/" => "/"
+;; "usr" => "."
+;; "/" => "/"
+;; "." => "."
+;; ".." => "."
+(define (dirname path)
+ (if (and (find (path -1) "/\\")
+ (!= "/" path))
+ (setq path (chop path)))
+ (catch
+ (begin
+ (for (idx 1 (length path))
+ (when (find (path (- idx)) "/\\")
+ (setq path (chop path idx))
+ (throw 'found)))
+ (setq path ".")))
+ (cond ((empty? path) "/")
+ (true path)))
(define (file-length pathname)
"Retun PATHNAMEs file size as byte."
@@ -66,5 +101,6 @@
;; FIXME: s/mktemp/mkstemp
(define mktemp make-temp-file-name)
+
(context MAIN)
;;; EOF
Oops, something went wrong.

0 comments on commit 1f5e48a

Please sign in to comment.