Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

first commit

  • Loading branch information...
commit cf86b2a9326fc550f876f32d640034454c630c95 0 parents
@kosh04 authored
17 README
@@ -0,0 +1,17 @@
+## See other
+
+* [newlisp-files] - newlisp.el etc...
+
+ http://github.com/kosh04/newlisp-files
+
+* libmagic.lsp - file(1) library
+
+ http://gist.github.com/272876.txt
+
+* iconv.lsp - iconv library
+
+ http://gist.github.com/242697.txt
+
+* brainfuck.lsp - Brainf*ck interpreter
+
+ http://gist.github.com/242690.txt
404 arglist.lsp
@@ -0,0 +1,404 @@
+;; @module arglist.lsp
+;; @description Find function argument list.
+;; @author KOBAYASHI Shigeru <shigeru.kb@gmail.com>
+;; @version 0.1
+
+;; ### Argument Format ###
+;;
+;; - [] (&optional)
+;; - ... (&rest, args)
+;;
+;; - string, list, (array) -> seq, sequence
+;; - int-file, str-device -> device
+;; - int, float -> num (integer-only -> int)
+;; - primitive, lambda, sym-function -> function
+;; - test-function -> predicate
+;; - exp -> obj, form
+
+;; 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
+
+;;; 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)))))
+
+(define (function? x)
+ (or (lambda? f) (macro? 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)
+ (cond ((function? f) (first f))
+ ((string? f) (Arglist f))
+ ((primitive? f) (Arglist (subr-name f)))
+ ((= f MAIN) nil)
+ ((context? f) (arglist (default f)))
+ ("else" (Arglist (string f)))))
+
+(defargs ! (command))
+(defargs + ([num ...]))
+(defargs - (num ...))
+(defargs * ([num ...]))
+(defargs / (num ...))
+(defargs % (num ...))
+(defargs < (obj ...))
+(defargs > (obj ...))
+(defargs = (obj ...))
+(defargs <= (obj ...))
+(defargs >= (obj ...))
+(defargs != (obj ...))
+(defargs << (int (count 1) ...))
+(defargs >> (int (count 1) ...))
+(defargs & (int ...))
+(defargs | (int ...))
+(defargs ^ (int ...))
+(defargs ~ (int))
+(defargs : (function obj ...))
+(defargs abort ([pid]))
+(defargs abs (num))
+(defargs acos (num))
+(defargs acosh (z))
+(defargs add ([num ...]))
+(defargs address (obj))
+(defargs amb ([obj ...]))
+(defargs and ([form ...]))
+(defargs append ([seq ...]))
+(defargs append-file (pathname buffer))
+(defargs apply (function list [reduce]))
+(defargs args ([index ...]))
+(defargs array (int ... [(init nil)]))
+(defargs array-list (array))
+(defargs array? (obj))
+(defargs asin (z))
+(defargs asinh (z))
+(defargs assoc (key alist))
+(defargs atan (y))
+(defargs atan2 (y x)) ; (= (atan 1) (atan2 1 1))
+(defargs atanh (z))
+(defargs atom? (obj))
+(defargs base64-dec (string))
+(defargs base64-enc (string))
+(defargs bayes-query (list-L context-D [bool-chain [bool-probs]]))
+(defargs bayes-train (list-M1 [list-M2 ...] sym-context-D))
+(defargs begin ([form ...]))
+(defargs beta (a b))
+(defargs betai (x a b))
+(defargs bind (alist [eval?]))
+(defargs binomial (n k p))
+(defargs bits (int [bool]))
+(defargs callback (index function))
+(defargs case (keyform forms))
+(defargs catch (form [symbol]))
+(defargs ceil (num))
+(defargs change-dir (directory))
+(defargs char (int-or-string [index]))
+(defargs chop (seq index))
+(defargs clean (predicate list))
+(defargs close (int-file))
+(defargs command-event (function))
+(defargs cond (clauses ...))
+(defargs cons (x y))
+(defargs constant (symbol value ...))
+(defargs context (context [string-or-symbol] [value]))
+(defargs context? (obj [string]))
+(defargs copy (obj))
+(defargs copy-file (from-file to-file))
+(defargs cos (radians))
+(defargs cosh (radians))
+(defargs count (list-A list-B))
+(defargs cpymem (from-address to-address bytes))
+(defargs crc32 (string))
+(defargs crit-chi2 (num-probability num-df))
+(defargs crit-z (num-probability))
+(defargs current-line ())
+(defargs curry (function form))
+(defargs date ([utc-time] [offset] [format]))
+(defargs date-value ([year month day [hour min sec]]))
+(defargs debug (form))
+(defargs dec (place [num]))
+(defargs def-new (source [target]))
+(defargs default (context))
+(defargs define ((name [arguments]) body))
+(defargs define-macro ((name [arguments]) body))
+(defargs delete (symbol-or-context [bool]))
+(defargs delete-file (pathname))
+(defargs delete-url (url [timeout]))
+(defargs destroy (pid [signal-number]))
+(defargs det (matrix))
+(defargs device ([int]))
+(defargs difference (list-A list-B [bool]))
+(defargs directory ([pathname] [pattern] [option]))
+(defargs directory? (pathname))
+(defargs div (num ...))
+(defargs do-until (test body))
+(defargs do-while (test body))
+(defargs doargs ((var [test]) body))
+(defargs dolist ((var list [test]) body))
+(defargs dostring ((var string [test]) body))
+(defargs dotimes ((var count [test]) body))
+(defargs dotree ((var context [bool]) body))
+(defargs dump ([obj]))
+(defargs dup (obj [int] [bool]))
+(defargs empty? (seq))
+(defargs encrypt (source pad))
+(defargs ends-with (seq key [option]))
+(defargs env ([var] [value]))
+(defargs erf (num))
+(defargs error-event (function))
+(defargs eval (form))
+(defargs eval-string (source [context] [eval-if-error] [offset]))
+(defargs exec (command [str-stdin]))
+(defargs exists (predicate list))
+(defargs exit ([int-code]))
+(defargs exp (num))
+(defargs expand (form [list-assoc [bool]] | [symbols ...])) ; FIXME
+(defargs explode (seq [chunk] [bool]))
+(defargs factor (int))
+(defargs fft (nums))
+(defargs file-info (pathname [index] [bool]))
+(defargs file? (pathname))
+(defargs filter (predicate list))
+(defargs find (key seq [predicate-or-int]))
+(defargs find-all (key seq [form] [predicate-or-int])) ; FIXME
+(defargs first (seq))
+(defargs flat (list))
+(defargs float (obj [default]))
+(defargs float? (obj))
+(defargs floor (num))
+(defargs flt (num))
+(defargs "lambda" ((arguments) body))
+(defargs "fn" ((arguments) body)) ; fn == lambda
+(defargs for ((var from to [step] [test]) body))
+(defargs for-all (predicate list))
+(defargs fork (form))
+(defargs format (control-string [data-or-list ...]))
+(defargs fv (num-rate num-nper num-pmt num-pv [int-type]))
+(defargs gammai (a b))
+(defargs gammaln (x))
+(defargs gcd ([int ...]))
+(defargs get-char (address))
+(defargs get-float (address))
+(defargs get-int (address))
+(defargs get-long (address))
+(defargs get-string (address))
+(defargs get-url (url [option] [timeout] [header]))
+(defargs global (symbol ...))
+(defargs global? (symbol))
+(defargs if (test then [else (if ...)]))
+(defargs if-not (test then [else]))
+(defargs ifft (nums))
+(defargs import (lib-name func-name ["cdecl"]))
+(defargs inc (place [num]))
+(defargs index (predicate list))
+(defargs inf? (num))
+(defargs int (obj [default] [base]))
+(defargs integer (obj [default] [base])) ; int == integer
+(defargs integer? (obj))
+(defargs intersect (list-A list-B [allow-dup?]))
+(defargs invert (matrix))
+(defargs irr (amounts [times] [guess]))
+(defargs join (strings [separator] [trail-joint?]))
+(defargs lambda? (obj))
+(defargs last (seq))
+(defargs last-error ([error-num]))
+(defargs legal? (string))
+(defargs length (obj))
+(defargs let ((var [value] ...) body))
+(defargs letex ((var [value] ...) body))
+(defargs letn ((var [value] ...) body))
+(defargs list ([obj ...]))
+(defargs list? (obj))
+(defargs load (pathname ... [context]))
+(defargs local ((symbol ...) body))
+(defargs log (num [base]))
+(defargs lookup (key list-assoc [index] [default]))
+(defargs lower-case (string))
+(defargs macro? (obj))
+(defargs main-args ([index]))
+(defargs make-dir (pathname [int-mode]))
+(defargs map (function list ...))
+(defargs mat (op matrix-A matrix-B-or-num))
+(defargs match (pattern match [bool]))
+(defargs max (num ...))
+(defargs member (key seq [regex-option]))
+(defargs min (num ...))
+(defargs mod (num divisor ...))
+(defargs mul ([num ...]))
+(defargs multiply (matrix-A matrix-B))
+(defargs name (symbol-or-context [bool]))
+(defargs NaN? (num))
+(defargs net-accept (socket))
+(defargs net-close (socket [true]))
+(defargs net-connect (pathname-or-hostname port [mode] [ttl]))
+(defargs net-error ([error-number]))
+(defargs net-eval (hostnames port form [timeout] [handler]))
+(defargs net-interface ([hostname]))
+(defargs net-listen (or (port [hostname] [mode]) (pathname)))
+(defargs net-local (socket))
+(defargs net-lookup (hostname [bool]))
+(defargs net-peek (socket))
+(defargs net-peer (socket))
+(defargs net-ping (hosts [timeout] [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]))
+(defargs net-select (sockets mode microsec))
+(defargs net-send (socket buffer [bytes]))
+(defargs net-send-to (host port buffer socket))
+(defargs net-send-udp (host port buffer [bool]))
+(defargs net-service (service protocol))
+(defargs net-sessions ())
+(defargs new (source target [bool]))
+(defargs nil? (obj))
+(defargs normal (mean stdev [length]))
+(defargs not (form))
+(defargs now ([offset]))
+(defargs nper (interest pmt pv [fv type]))
+(defargs npv (interest values))
+(defargs nth (indices seq))
+(defargs null? (obj))
+(defargs number? (obj))
+(defargs open (pathname access-mode [option]))
+(defargs or ([form ...]))
+(defargs pack (format [data-or-list ...]))
+(defargs parse (string [separator] [regex-option]))
+(defargs parse-date (string format))
+(defargs peek (int-file))
+(defargs pipe ())
+(defargs pmt (interest periods principal [future-value type]))
+(defargs pop (seq [indices ...] [length]))
+(defargs pop-assoc (keys list-assoc))
+(defargs post-url (url contents [content-type] [option] [timeout] [header]))
+(defargs pow (base [num ...]))
+(defargs pretty-print ([length] [tab]))
+(defargs primitive? (obj))
+(defargs print ([args ...]))
+(defargs println ([args ...]))
+(defargs prob-chi2 (chi2 df))
+(defargs prob-z (z))
+(defargs process (command [pipe-in pipe-out] [pipe-error-or-win32-option]))
+(defargs prompt-event (function))
+(defargs protected? (symbol))
+(defargs push (obj seq [indies]))
+(defargs put-url (url contents [option] [timeout] [header]))
+(defargs pv (int nper pmt [fv type]))
+(defargs quote (obj))
+(defargs quote? (obj))
+(defargs rand (range [length]))
+(defargs random (offset scale [length]))
+(defargs randomize (list [bool]))
+(defargs read-buffer (int-file buffer size [wait-string]))
+(defargs read-char (int-file))
+(defargs read-expr (source [context] [eval-if-error] [offset]))
+(defargs read-file (pathname))
+(defargs read-key ())
+(defargs read-line ([int-file]))
+(defargs read-utf8 (int-file))
+(defargs real-path ([pathname]))
+(defargs receive (pid message))
+(defargs ref (key list [predicate]))
+(defargs ref-all (key list [predicate]))
+(defargs regex (pattern text [regex-option] [offset]))
+(defargs regex-comp (pattern [regex-option]))
+(defargs remove-dir (pathname))
+(defargs rename-file (pathname-old pathname-new))
+(defargs replace (exp-from seq [exp-to] [func-or-option]))
+(defargs reset ([restart?]))
+(defargs rest (seq))
+(defargs reverse (seq))
+(defargs rotate (seq [count]))
+(defargs round (num [digits]))
+(defargs save (pathname [symbol ...]))
+(defargs search (int-file pattern [no-dup?] [regex-option]))
+(defargs seed (int))
+(defargs seek (int-file [position]))
+(defargs select (seq [indices]))
+(defargs semaphore ([id] (or wait signal 0))) ; FIXME
+(defargs send (pid obj))
+(defargs sequence (start end [step]))
+(defargs series (start factor count))
+(defargs set (symbol value ...))
+(defargs set-locale ([locale] [category]))
+(defargs set-ref (exp-from list exp-to [predicate]))
+(defargs set-ref-all (exp-from list exp-to [predicate]))
+(defargs setf (place value ...))
+(defargs setq (var value ...))
+(defargs sgn (num [minus zero plus]))
+(defargs share ([address] [value])) ; FIXME: +(nil address)
+(defargs signal (signal-number [function-or-bool]))
+(defargs silent ([form ...]))
+(defargs sin (radians))
+(defargs sinh (radians))
+(defargs sleep (milliseconds))
+(defargs slice (seq index [length]))
+(defargs sort (list [predicate]))
+(defargs source ([symbol ...]))
+(defargs spawn (symbol form))
+(defargs sqrt (num))
+(defargs starts-with (seq key [regex-option]))
+(defargs string ([args ...]))
+(defargs string? (obj))
+(defargs sub (num ...))
+(defargs swap (place-1 place-2))
+(defargs sync ([timeout] [function]))
+(defargs sym (string|num|symbol [context] [nil]))
+(defargs symbol? (obj))
+(defargs symbols ([context]))
+(defargs sys-error ([(or error-number 0)]))
+(defargs sys-info ([index]))
+(defargs tan (radians))
+(defargs tanh (radians))
+(defargs throw (form))
+(defargs throw-error (form))
+(defargs time (form [count]))
+(defargs time-of-day ())
+(defargs timer ([function] [seconds] [option]))
+(defargs title-case (string [lowercase-rest?]))
+(defargs trace ([bool-switch]))
+(defargs trace-highlight (start end [header footer]))
+(defargs transpose (matrix))
+(defargs trim (string [trim-char-left] [char-right]))
+(defargs true? (obj))
+(defargs unicode (string))
+(defargs unify (A B [env]))
+(defargs unique (list))
+(defargs unless (test body))
+(defargs unpack (format data))
+(defargs until (test body))
+(defargs upper-case (string))
+(defargs utf8 (unicode))
+(defargs utf8len (string))
+(defargs uuid ([node]))
+(defargs wait-pid (pid (or option 0)))
+(defargs when (test body))
+(defargs while (test body))
+(defargs write-buffer (device buffer [size]))
+(defargs write-char (int-file char ...))
+(defargs write-file (pathname buffer))
+(defargs write-line ([(device stdout)] [buffer]))
+(defargs xfer-event (function))
+(defargs xml-error ())
+(defargs xml-parse (xml [xml-option] [context] [callback]))
+(defargs xml-type-tags ([TEXT CDATA COMMENT ELEMENT]))
+(defargs zero? (obj))
+
+(context MAIN)
+;;; EOF
65 argv.lsp
@@ -0,0 +1,65 @@
+;; argv.lsp --- provide cleanup arguments
+
+;; newLISP の起動引数以外の引数を提供
+
+;(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)))
+
+(define-macro (pop-args)
+ (let ((n (find (eval (args 0)) $argv
+ (lambda (x y)
+ (starts-with y x 0)))))
+ (when n
+ (cond
+ ((= $1 "") ; "--arg" "Value"
+ (pop $argv (+ n 1))
+ (pop $argv n))
+ (true ; "--arg[Value]"
+ (pop $argv n)))
+ true)))
+
+;;
+(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(.*)")
+
+
+(define (getopt optstring (has-value nil))
+ "オプション引数の解析."
+ (let ((pos (find optstring $main-args
+ (lambda (x y) (starts-with y x)))))
+ (if (and pos has-value)
+ (if (!= (main-args pos) optstring)
+ (slice (main-args pos) (length optstring))
+ (main-args (+ pos 1)))
+ (integer? pos))))
+
+;;; Example:
+;; (main-args) ;=> ("newlisp" "-C" "-w" "/home" "-s10000")
+;; (getopt "-w") ;=> true
+;; (getopt "-w" true) ;=> "/home"
+;; (getopt "-s" true) ;=> "10000"
+;; (getopt "-n") ;=> nil
+
+
+(context MAIN)
+
+;;; EOF
158 cl.lsp
@@ -0,0 +1,158 @@
+;;; cl.lsp --- Common Lisp like functions
+
+;; (constant (global 't) true)
+(define (null x) (not (true? x)))
+(define car first)
+(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 let* letn)
+(define intern sym) ; or make-symbol
+(define symbol-name name)
+(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 complement
+ (lambda-macro ()
+ (letex ((f (args 0)))
+ (lambda ()
+ (not (apply f (args)))))))
+(define identity
+ ;; なんでマクロにしたんだっけ?
+ (lambda-macro ()
+ (eval (args 0))))
+
+(define (find-symbol str (ctx (context)))
+ (sym str ctx nil))
+
+(define read-from-string read-expr)
+
+;;; @@number
+(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 (plusp number) (< 0 number)) ; or (> number) , (sgn number nil nil true)
+(define (minusp number) (< number 0)) ; or (< number) , (sgn number true nil nil)
+(define (ash i cnt) (sgn cnt (>> i (abs cnt)) i (<< i cnt)))
+(define logand &)
+(define logxor ^)
+(define logior |)
+(define lognot ~)
+(define expt pow)
+(define (/= number)
+ "true if NUMBER and rest numbers are different all. otherwise nil."
+ (for-all (lambda (x) (not (= x number))) (args)))
+;; (/= 1 2 3 1) ; nil
+;; (!= 1 2 3 1) ; true ?
+
+;;; @@list
+(define intersection intersect)
+(define set-difference difference)
+(define butlast chop)
+(define (nthcdr n lst) (slice lst n))
+(define (common-lisp:last lst (n 1))
+ ((- n) lst))
+(define every for-all)
+(define (some f lst)
+ (dolist (obj lst (f obj))))
+(define position find)
+(define find-if exists)
+(define remove-duplicates unique)
+;(define (remove item seq) (clean (fn (x) (= x item)) seq))
+(define (remove item seq)
+ (if (string? seq)
+ (replace item seq "")
+ (replace item seq)))
+(define remove-if clean)
+(define remove-if-not filter)
+(define common-lisp:delete ; 破壊的 (destructive)
+ (lambda-macro ()
+ (if (string? (eval (args 1)))
+ (replace (eval (args 0)) (eval (args 1)) "")
+ (replace (eval (args 0)) (eval (args 1))))))
+(define (count-if f seq)
+ (length (filter f seq)))
+(define (mapcar f lst)
+ "syntax: (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))
+;; (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
+;(define concat string)
+(define (concat) (join (args)))
+(define copy-seq copy)
+(define string-upcase upper-case)
+(define string-downcase lower-case)
+(define string-capitalize title-case)
+
+(define (subseq seq start end)
+ (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-left-trim char-bag str)
+ (if (string? char-bag)
+ (setq char-bag (map char (explode char-bag))))
+ (catch
+ (dostring (c str)
+ (unless (member c char-bag)
+ (throw (slice str $idx))))))
+
+(define (string-right-trim char-bag str)
+ (if (string? char-bag)
+ (setq char-bag (map char (explode char-bag))))
+ (catch
+ (dostring (c (reverse (copy str)))
+ (unless (member c char-bag)
+ (throw (slice str 0 (- (length str) $idx)))))))
+
+(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))))
+(define-macro (unwind-protect )
+ (local (result)
+ (if (catch (eval (args 0)) 'result)
+ (begin (map eval (1 (args))) result)
+ (begin (map eval (1 (args))) (throw-error (5 result))))))
+)
+
+(define (prin1-to-string obj)
+ (cond ((string? obj) (format"\"%s\"" (replace "\\" obj "\\\\")))
+ ("else" (string obj))))
+
+(context MAIN)
+;;; EOF
61 files.lsp
@@ -0,0 +1,61 @@
+;; files.lsp --- Fileystem Utilities
+
+;;; @@filesystem, pathname
+;; NOTE: Linuxでは存在しないファイルにrealpathを使えない
+(define (merge-pathnames pathname (defaults "."))
+ (real-path (cond ((file? pathname) pathname)
+ ((starts-with pathname "~/")
+ (append (env "HOME") (1 pathname)))
+ ((regex "^[\\|/]" pathname) pathname)
+ (true (append defaults "/" pathname)))))
+(define (user-homedir-pathname) (real-path))
+(define (pwd) (real-path))
+(define (namestring pathname) (merge-pathnames pathname))
+(define set-default-directory change-dir)
+(define (cd path) (change-dir (or path (env "HOME") "/")))
+(define (file-exist-p pathname)
+ (or (file? pathname)
+ (directory? pathname)))
+(define (probe-file pathname)
+ (and (file-exist-p pathname)
+ (real-path pathname)))
+(define (truename pathname)
+ (or (probe-file pathname)
+ (error "%s: No such file or directory" pathname)))
+
+(define (file-length pathname)
+ "Retun PATHNAMEs file size as byte."
+ (file-info pathname 0))
+
+;; same as `concatenate'
+;; `string' を使うと文字列以外も変換するので注意
+(define (pathname) (join (args)))
+
+(define (pathname? str)
+ (or (file? str)
+ (directory? str)))
+
+(define (find-file file)
+ (or (read-file file)
+ (throw-error (cons file (sys-error)))))
+
+(define (make-temp-file-name (prefix "nl") (suffix "tmp") dir dir?)
+ (unless dir
+ (setq dir (or (env "TEMP") (env "TMP") (real-path "/tmp") (real-path "."))))
+ (let ((accessfn (if dir? directory? file?))
+ (pid (getpid))
+ (tbl "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"))
+ (loop
+ (let ((filename (format "%s/%s%d%s.%s" dir prefix pid
+ (perm tbl 3) suffix)))
+ (unless (accessfn filename)
+ (return filename))))))
+
+;; FIXME: mkstemp
+;; (mktemp) => "C:\\tmp\\nl-180059w.tmp"
+(define mktemp make-temp-file-name)
+
+
+(context MAIN)
+
+;;; EOF
49 io.lsp
@@ -0,0 +1,49 @@
+;; io.lsp --- Input/Output functions for newLISP
+
+;; http://en.wikipedia.org/wiki/Standard_streams
+(setq stdin 0 stdout 1 stderr 2)
+
+;; call-with-{input,output}-file @scheme
+(define (with-file-handler filename proc (mode "r"))
+ (let ((fd (or (open filename mode)
+ (throw-error (list filename (sys-error))))))
+ (unwind-protect
+ (proc fd)
+ (close fd))))
+
+(define (with-output-file filename proc) (with-file-handler filename proc "w"))
+(define (with-input-file filename proc) (with-file-handler filename proc "r"))
+
+;; 出力を文字列に切り替えることも出来る
+;; (echo stdin "HELLO ") => "HELLO newLISP!\n"
+(define (echo in (out stdout))
+ (cond ((socket? in)
+ (let ((len (net-peek in)) buf)
+ (when (!= len 0)
+ (net-receive in buf len)
+ (write-line out buf))))
+ ("else"
+ (while (read-line in)
+ (write-line out))))
+ (if (string? out) out))
+
+;== (define cat read-file)
+(define (cat filename)
+ (with-input-file filename echo))
+
+;; ファイルと標準出力へ書き出し
+(define (tee filename buffer)
+ (append-file filename buffer)
+ (print buffer))
+
+(unless peek
+;; for Win32
+(define (peek fd)
+ (or (net-peek fd)
+ (let ((ptr (seek fd)))
+ (when ptr
+ (- (seek fd -1) (seek fd ptr))))))
+)
+
+(context MAIN)
+;;; EOF
36 legacy.lsp
@@ -0,0 +1,36 @@
+;; regacy.lsp --- legacy functions (newLISP v.10.1.7)
+
+(module "macro.lsp")
+
+(macro (replace-assoc Key Alist Rep)
+ (setf (assoc Key Alist) Rep))
+
+;; @syntax (replace-assoc key alist replace)
+;; (define-macro (replace-assoc )
+;; (setf (assoc (eval (args 0))
+;; (eval (args 1)))
+;; (eval (args 2))))
+
+(macro (set-nth Idx Seq Rep)
+ (setf (Seq Idx) Rep))
+
+(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 (getenv var) (env var))
+(define (putenv var value) (env var value))
+
+(define read-url get-url)
+(define (net-cleanup)
+ "Closes all open sockets."
+ (map net-close (net-sessions))
+ true)
+
+(define (read-process str-process) (exec str-process))
+(define (write-process str-process str-stdin) (exec str-process str-stdin))
+
+(context MAIN)
+;; EOF
26 net.lsp
@@ -0,0 +1,26 @@
+;;; net.lsp - newLISP network utility
+
+(define (url-encode url)
+ (join (map (lambda (c)
+ (if (regex "[^-A-Za-z0-9$_.+!*'(|),]" (char c))
+ (format "%%%2X" c)
+ (char c)))
+ (unpack (dup "b" (length url)) url))))
+
+;; URL translation of hex codes with dynamic replacement
+(define (url-decode url)
+ ;; (PCRE_CASELESS 1)
+ (replace "%([0-9A-F][0-9A-F])" url (char (int $1 0 16)) 1))
+
+;; FIXME: (sys-error) が更新されるのはまずいかもしれない
+(define (socket? x)
+ (and (or (net-local x)
+ (net-peer x))
+ true))
+
+(define (net-wait socket (mode "read") (ms 1000))
+ (until (net-select socket mode ms)
+ (if (net-error) (println (net-error)))))
+
+(context MAIN)
+;;; EOF
38 regex.lsp
@@ -0,0 +1,38 @@
+;;; regex.lsp --- Regular Expression (pcre) functions for newLISP
+
+(define split-string parse)
+(define compile-regexp regex-comp)
+
+(define (string-match regexp str (start 0) end)
+ (regex regexp (subseq str start end)))
+
+(define (substitute-string str pattern replacement)
+ (replace pattern str replacement))
+
+;; CLISP: clisp/regexp/regexp.lisp
+;; ($ ^ . * [ ] \ + ?) :extended
+;; ($ ^ . * [ ] \ )
+;; PHP: preg_quote (. \ + * ? [ ^ ] $ ( ) { } = ! < > | : -) -> "[]!$(-+.:<-?[\\{|}^-]"
+;; Ruby: Regexp.quote
+(define (regex-quote str)
+ (replace "[][$*+.?\\^]" str (string "\\" $0) 0))
+
+(setq
+ PCRE_CASELESS 1
+ PCRE_MULTILINE 2
+ PCRE_DOTALL 4
+ PCRE_EXTENDED 8
+ PCRE_ANCHORED 16
+ PCRE_DOLLAR_ENDONLY 32
+ PCRE_EXTRA 64
+ PCRE_NOTBOL 128
+ PCRE_NOTEOL 256
+ PCRE_UNGREEDY 512
+ PCRE_NOTEMPTY 1024
+ PCRE_UTF8 2048
+ REPLACE_ONCE 0x8000
+ PRECOMPILED 0x10000
+ )
+
+(context MAIN)
+;;; EOF
49 winapi.lsp
@@ -0,0 +1,49 @@
+;;; winapi.lsp --- use Win32API
+
+(context 'Win32API)
+
+(import "user32.dll" "MessageBoxA")
+(import "kernel32.dll" "GetShortPathNameA")
+(import "kernel32.dll" "GetLongPathNameA")
+(import "shell32.dll" "ShellExecuteA")
+
+(define PATH_MAX 512)
+
+
+(context MAIN)
+
+;(define NULL 0)
+
+(define (message-box text (title "newLISP"))
+ (let ((MB_OK 0))
+ (Win32API:MessageBoxA 0 text title MB_OK)))
+
+(define (get-short-path-name pathname)
+ (unless (file? pathname)
+ (throw-error (list "No such file or directory" pathname)))
+ (setq pathname (real-path pathname)) ; to fullpath
+ (letn ((len Win32API:PATH_MAX)
+ (buf (dup (char 0) (+ len 1)))
+ (ret (Win32API:GetShortPathNameA pathname buf len)))
+ (slice buf 0 ret)
+ ;; (GetShortPathNameA pathname buf len) (get-string buf)
+ ))
+
+(define (get-longpathname pathname)
+ (letn ((len Win32API:PATH_MAX)
+ (buffer (dup (char 0) (+ len 1)))
+ (r (Win32API:GetLongPathNameA pathname buffer len)))
+ (if (= r 0) (throw-error '("GetLongPathNameA" "failure")))
+ (slice buffer 0 r)))
+
+(define (shell-execute app)
+ (let ((SW_SHOWNORMAL 1) e)
+ (setf e (Win32API:ShellExecuteA 0 "open" app 0 0 SW_SHOWNORMAL))
+ ;(if (< e 32) )
+ ))
+;(shell-execute "C:\\PROGRA~1\\newlisp\\newlisp.exe")
+;(shell-execute "C:/")
+;(shell-execute "http://www.newlisp.org/")
+
+(context MAIN)
+;;; EOF
Please sign in to comment.
Something went wrong with that request. Please try again.