Permalink
Browse files

関数の若干追加と修正

  • Loading branch information...
1 parent 97b407f commit f06dc5a954a4139727aa526cd3a2588a9a4343f0 @kosh04 committed Oct 7, 2010
Showing with 193 additions and 75 deletions.
  1. +0 −17 README
  2. +22 −0 README.md
  3. +9 −9 arglist.lsp
  4. +38 −22 argv.lsp
  5. +87 −12 legacy.lsp
  6. +37 −15 net.lsp
View
17 README
@@ -1,17 +0,0 @@
-## See Other
-
-* [newlisp-files] - newlisp.el etc...
-
- <http://github.com/kosh04/newlisp-files>
-
-* libmagic.lsp - file(1) library
-
- <http://gist.github.com/272876>
-
-* iconv.lsp - iconv library
-
- <http://gist.github.com/242697>
-
-* brainfuck.lsp - Brainf*ck interpreter
-
- <http://gist.github.com/242690>
View
@@ -0,0 +1,22 @@
+## About
+
+ここではnewLISPからロードして使う小物なモジュール群を置いてます。
+個人用に書いたものばかりなので、あまり整理されていません。
+
+## Others
+
+* [newlisp-files] newlisp.el etc...
+
+ http://github.com/kosh04/newlisp-files
+
+* libmagic.lsp - file(1) library
+
+ http://gist.github.com/272876
+
+* iconv.lsp - iconv library
+
+ http://gist.github.com/242697
+
+* brainfuck.lsp - Brainf*ck interpreter
+
+ http://gist.github.com/242690
View
@@ -1,6 +1,6 @@
;; @module arglist.lsp
;; @description Find function argument list.
-;; @author KOBAYASHI Shigeru <shigeru.kb [at] gmail.com>
+;; @author KOBAYASHI Shigeru <shigeru.kb[at]gmail.com>
;; @version 0.1
;; ### Argument Format ###
@@ -60,11 +60,14 @@
("else" (Arglist (string f)))))
(defargs ! (command))
+(defargs $ (index))
(defargs + ([num ...]))
(defargs - (num ...))
(defargs * ([num ...]))
(defargs / (num ...))
(defargs % (num ...))
+(defargs ++ (place [num]))
+(defargs -- (place [num]))
(defargs < (obj ...))
(defargs > (obj ...))
(defargs = (obj ...))
@@ -78,9 +81,6 @@
(defargs ^ (int ...))
(defargs ~ (int))
(defargs : (function obj ...))
-(defargs $ (index))
-(defargs ++ (place [num]))
-(defargs -- (place [num]))
(defargs abort ([pid]))
(defargs abs (num))
(defargs acos (num))
@@ -239,7 +239,7 @@
(defargs load (pathname ... [context]))
(defargs local ((symbol ...) body))
(defargs log (num [base]))
-(defargs lookup (key list-assoc [index] [default]))
+(defargs lookup (key list-assoc [(index -1)] [default]))
(defargs lower-case (string))
(defargs macro? (obj))
(defargs main-args ([index]))
@@ -264,11 +264,11 @@
(defargs net-ipv ([version]))
(defargs net-listen (or (port [hostname] [mode]) (pathname)))
(defargs net-local (socket))
-(defargs net-lookup (hostname [bool]))
-(defargs net-packet (new-packet str-packet)) ; add v10.2.8
+(defargs net-lookup (hostname [force-host-by-name]))
+(defargs net-packet (str-packet)) ; add v10.2.8
(defargs net-peek (socket))
(defargs net-peer (socket))
-(defargs net-ping (hosts [timeout] [count]))
+(defargs net-ping (hosts [(timeout 1000)] [count]))
(defargs net-receive (socket buffer max-bytes [wait-string]))
(defargs net-receive-from (socket max-size))
(defargs net-receive-udp (port max-size [microsec] [addr-if]))
@@ -378,7 +378,7 @@
(defargs sym (string|num|symbol [context] [nil]))
(defargs symbol? (obj))
(defargs symbols ([context]))
-(defargs sys-error ([(or error-number 0)]))
+(defargs sys-error ([(error-number 0)]))
(defargs sys-info ([index]))
(defargs tan (radians))
(defargs tanh (radians))
View
@@ -2,50 +2,67 @@
;; newLISP の起動引数以外の引数を提供
+;;; ChangeLog:
+;;
+;; - 2010-01-21 初版作成
+;; - 2010-10-04
+;; なるべくnewlisp起動時の流れに沿うように修正
+;; (-startのような失敗する引数も許すようになった)
+;; オプション-t,-6の追加
+
+;;; TODO
+;;
+;; - ファイル名の扱いはどうする?
+
;(context 'argv)
(define invocation-name (first $main-args)) ; "newlisp" or "newlisp.exe"
(define $argv (rest $main-args))
(define (argv i)
- (cond (i (when (< i (length $argv))
- ($argv i)))
- ("else" $argv)))
+ (cond (i (if (< i (length $argv)) ($argv i) nil))
+ (true $argv)))
-(define-macro (pop-args)
- (let ((n (find (eval (args 0)) $argv
+;; @syntax: (pop-args str value?)
+(define (pop-args str (has-value nil))
+ (let ((n (find str $argv
(lambda (x y)
- (starts-with y x 0)))))
+ (starts-with y x)))))
(when n
(cond
- ((= $1 "") ; "--arg" "Value"
+ ((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))
(pop $argv n))
- (true ; "--arg[Value]"
- (pop $argv n)))
- true)))
+ (true ; "-arg[value]"
+ (pop $argv n))))
+ nil))
+;; "-n" option must be first.
+(if (= (argv 0) "-n")
+ (pop $argv))
;;
-(pop-args "-n")
(pop-args "-h")
(pop-args "-c")
(pop-args "-C")
(pop-args "-http")
-;;; FIXME: valid regex?
-(pop-args "-s(\\d*)")
-(pop-args "-m(\\d*)")
-(pop-args "-e(.*)")
-(pop-args "-l(.*)")
-(pop-args "-L(.*)")
-(pop-args "-p(\\d*)")
-(pop-args "-d(\\d*)")
-(pop-args "-w(.*)")
+(pop-args "-s" true)
+(pop-args "-m" true)
+(pop-args "-e" true)
+(pop-args "-l" true)
+(pop-args "-L" true)
+(pop-args "-p" true)
+(pop-args "-d" true)
+(pop-args "-t" true)
+(pop-args "-w" true)
+(pop-args "-6")
(define (getopt optstring (has-value nil))
"オプション引数の解析."
(let ((pos (find optstring $main-args
- (lambda (x y) (starts-with y x)))))
+ (lambda (x y) (starts-with y x 0)))))
(if (and pos has-value)
(if (!= (main-args pos) optstring)
(slice (main-args pos) (length optstring))
@@ -61,5 +78,4 @@
(context MAIN)
-
;;; EOF
View
@@ -1,25 +1,86 @@
-;; regacy.lsp --- legacy functions (newLISP v.10.1.7)
+;; regacy.lsp --- legacy functions (current newLISP v.10.2.4)
-(module "macro.lsp")
-
-(macro (replace-assoc Key Alist Rep)
- (setf (assoc Key Alist) Rep))
+;; (module "macro.lsp")
+;; @syntax (replace-assoc key alit)
;; @syntax (replace-assoc key alist replace)
-;; (define-macro (replace-assoc )
-;; (setf (assoc (eval (args 0))
-;; (eval (args 1)))
-;; (eval (args 2))))
+(define-macro (replace-assoc )
+ (case (length $args)
+ (2 (replace (assoc (eval (args 0))
+ (eval (args 1)))
+ (eval (args 1))))
+ (3 (setf (assoc (eval (args 0))
+ (eval (args 1)))
+ (eval (args 2))))
+ (true
+ (throw-error "missing argument")))
+ (eval (args 1)))
+
+;; (macro (replace-assoc Key Alist Rep)
+;; (setf (assoc Key Alist) Rep))
+
+;; set-assoc/assoc-set
+;; ref-set
+
+
+;; @syntax (set-nth int-nth-1 [int-nth-2 ...] list|array exp-replacement)
+;; @syntax (set-nth int-nth-1 str str-replacement)
+
+;; @syntax (set-nth (list|array int-nth-1 [int-nth-2 ...]) exp-replacement)
+;; @syntax (set-nth (str int-nth-1) str-replacement)
-(macro (set-nth Idx Seq Rep)
- (setf (Seq Idx) Rep))
+;; set-nth works like nth-set, except instead of returning the replaced
+;; element, it returns the entire changed expression. For this reason,
+;; set-nth is slower on larger data objects.
+(define-macro (set-nth )
+ (cond
+ ;; (set-nth (seq idx) rep) -> (setf (seq idx) rep)
+ ((and (list? (args 0))
+ (or (list? (eval (args 0 0)))
+ (array? (eval (args 0 0)))
+ (string? (eval (args 0 0)))
+ (and (context? (eval (args 0 0)))
+ (default (eval (args 0 0))))
+ ))
+ (setf (eval (args 0)) (eval (args 1))))
+ ;; (set-nth idx str rep) -> (setf (str idx) rep)
+ ((and (number? (eval (args 0)))
+ (string? (eval (args 1))))
+ (setf ((eval (args 1)) (eval (args 0)))
+ (eval (args 2))))
+ ;; (set-nth idx1 [idx2 ...] seq rep) -> (setf (seq '(idx1 idx2 ...)) rep)
+ ((number? (eval (args 0)))
+ (setf ((eval (args -2)) (map eval (0 -2 (args))))
+ (eval (args -1))))
+ (true
+ (throw-error (list "value or sequence expected" (args 0))))
+ ))
+
+;; Sets the int-nth element of a list or array with the evaluation of
+;; exp-replacement and returns the old element.
+(define nth-set set-nth)
+
+(define set! setq)
+
+;; NOTE: Old inc/dec function returns integer (now float)
+(define _inc inc)
+(constant 'inc
+ (lambda-macro (place (num 1))
+ (++ (eval (eval place)) (eval num))))
+(define _dec dec)
+(constant 'dec
+ (lambda-macro (place (num 1))
+ (-- (eval (eval place)) (eval num))))
(define (error-number err) (nth 0 (or err (sys-error))))
(define (error-text err) (nth 1 (or err (sys-error))))
(define (concat) (join (args)))
-(define (environ) (env))
+(define (environ)
+ (map (lambda (e)
+ (string (e 0) "=" (e 1)))
+ (env)))
(define (getenv var) (env var))
(define (putenv var value) (env var value))
@@ -32,5 +93,19 @@
(define (read-process str-process) (exec str-process))
(define (write-process str-process str-stdin) (exec str-process str-stdin))
+;; newlisp v.10.1.2
+(define (name sym-context (bool nil))
+ (cond (bool (prefix sym-context))
+ (true (term sym-context))))
+
+(unless (< (sys-info -2) 9909)
+ (define _write-line write-line)
+ (constant 'write-line
+ (lambda (buffer fdevice)
+ (_write-line fdevice buffer))))
+
+;; Swithces break mode on or off.
+;; (define break trace)
+
(context MAIN)
;; EOF
Oops, something went wrong.

0 comments on commit f06dc5a

Please sign in to comment.