updates

Author: kosh04

Diff for: arglist.lsp

@@ -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 ...]))

Diff for: argv.lsp

@@ -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")
 

Diff for: 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

Diff for: files.lsp renamed to filesys.lsp

@@ -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