; 2010/ 8/ 2 identity is added.
; map0-n, map1-n and mapa-b are added.
; 2010/ 8/ 3 "newlisp-utility.lsp" is necessary.
; https://johu02.wordpress.com/newlisp-utility-lsp/
; include is defined in https://johu02.wordpress.com/init-lsp/
; functionp is added.
; lrec is added.
; 2010/ 8/ 4 lrec is improved. (cdr -> rest)
; MACRO? is added.
; trec is added.
; 2010/ 8/14 multiple-value-bind and multiple-value-list are improved.
; (avoided the multiple evaluation problem of _val)
;
; 2010/ 8/20 =lambda, =defun, =bind, =values, =funcall and =apply are added.
; 2010/ 8/24 defstruct and structurep are added.
;
(include "newlisp-utility.lsp")
(context 'MAIN:do)
(define (make-stepform bindform)
(remove nil (mappend (fn (b) (if (and (consp b) (third b))
(list (car b) (third b))
'()))
bindform)))
(define-macro (do:do)
(letex (_init (map (hayashi slice 0 2) (args 0))
_steps (cons 'psetq (make-stepform (args 0)))
_results (cons 'begin (rest (args 1)))
_end-test (first (args 1))
_body (cons 'begin (2 (args))))
(let _init
(until _end-test
_body
_steps)
_results)))
(context 'MAIN:do*)
(define (make-stepform bindform)
(remove nil (mappend (fn (b) (if (and (consp b) (third b))
(list (car b) (third b))
'()))
bindform)))
(define-macro (do*:do*)
(letex (_init (map (hayashi slice 0 2) (args 0))
_steps (cons 'setq (make-stepform (args 0)))
_results (cons 'begin (rest (args 1)))
_end-test (first (args 1))
_body (cons 'begin (2 (args))))
(letn _init
(until _end-test
_body
_steps)
_results)))
(context 'MAIN:multiple-value-bind)
(define (add-nil lst c)
(let (len (- c (length lst)))
(if (> c) (append lst (dup nil c)) lst)))
(define-macro (multiple-value-bind:multiple-value-bind)
(letex (_var (args 0)
_len (length (args 0))
_val (args 1)
_body (cons 'begin (2 (args))))
(local _var
(setq values:mv-set true)
(let (_res _val)
(map set '_var (add-nil (mklist _res) _len)))
(setq values:mv-set nil)
_body)))
(context 'MAIN:multiple-value-list)
(define-macro (multiple-value-list:multiple-value-list)
(letex (_val (args 0))
(let (_lst)
(setq values:mv-set true)
(let (_res _val) (setq _lst (mklist _res)))
(setq values:mv-set nil)
_lst)))
(context 'MAIN:values)
(define-macro (values:values)
(letex (_item (args 0)
_lst (cons 'list (args)))
(if mv-set _lst _item)))
(context MAIN)
(define (identity x) x)
(define (functionp x) (or (lambda? x) (primitive? x)))
(define (lrec rec-f base-f)
(letex (rec rec-f
base base-f)
(labels ((self-r (lst)
(if (null lst)
(if (functionp 'base) (base) 'base)
(rec (first lst)
(fn () (self-r (rest lst)))))))
self-r)))
(define (map0-n f n)
(map f (sequence 0 n)))
(define (map1-n f n)
(map f (sequence 1 n)))
(define (mapa-b f a b (step 1))
(map f (sequence a b step)))
(define (MACRO? f)
(and (list? f) (macro? f) (= 'expand (nth '(1 0) f))))
(define (trec rec-f (base-f identity))
(letex (rec rec-f
base base-f)
(labels
((self-r (tree)
(if (atom tree)
(if (functionp 'base) (base tree)
(MACRO? 'base) (eval (base tree))
'base)
(rec tree (fn () (self-r (first tree)))
(fn () (if (rest tree)
(self-r (rest tree))))))))
self-r)))
(global 'identity 'map0-n 'map1-n 'mapa-b)
(global 'functionp 'lrec 'trec 'MACRO?)
(setq *cont* values)
(define-macro (=lambda)
; (=lambda parms &body body)
(letex (_parms (cons '*cont* (args 0))
_body (cons 'begin (1 (args))))
(fn _parms _body)))
(define-macro (=defun)
; (= defun name parms &body body)
(let (_f (sym (string "=" (args 0))))
(letex (_mname (cons (args 0)
(map sym (map (curry string "_") (args 1))))
_fname (append (list _f '*cont*)
(map sym (map (curry string "_") (args 1))))
_vars (if (args 1)
(transpose (list (args 1)
(map sym
(map (curry string "_")
(args 1)))))
'())
_body (cons 'begin (2 (args))))
(begin
(define-macro _mname
_fname)
(define _fname
(letex _vars _body))))))
(define-macro (=bind)
; (=bind parms expr &body body)
(letex (_parms (args 0)
_expr (args 1)
_body (cons 'begin
(or (set-ref '=values (2 (args)) (eval *cont*))
(2 (args)))))
(let (*cont* (fn _parms _body)) _expr)))
(define-macro (=values)
; (=value &rest retvals)
(letex (_body (cons '*cont* (args)))
_body))
(define-macro (=funcall)
; (=fancall fn &rest args)
(letex (_body (append (list (args 0) '*cont*) (1 (args))))
_body))
(define-macro (=apply)
; (=apply fn &rest args)
(letex (_body (append (list 'apply (args 0) '*cont*) (1 (args))))
_body))
(global '=lambda '=defun '=values '=bind '=funcall '=apply)
(define (structurep s)
(letex (_s (sym (string s) s))
(and (context? s) _s (= (s 0) 'structure))))
(define-macro (structfunc funcname propname)
(letex (_funcname funcname
_propname propname)
(setq _funcname (lambda (symbol)
(letex (_sym (sym '_propname symbol))
(reference-inversion:set _sym))))))
(define-macro (structfuncs)
(letex (_pair (cons 'begin (map (curry cons 'structfunc) (args))))
_pair))
(define-macro (defstruct defname)
(let (_name defname
_var (map (fn (x) (first (mklist x))) (args))
_val (map (fn (x) (second (mklist x))) (args)))
(letex (_defctx _name
_strucp (sym (string _name "-p"))
_copy-n (sym (string "copy-" _name))
_make-n (sym (string "make-" _name))
_funcs (cons 'structfuncs (map (fn (x) (list (sym (string _name "-" x)) x)) _var))
_vari _var
_vali _val)
_funcs
(setq _copy-n (fn (s) (letex (_ctx (sym (gensym))) (new s '_ctx))))
(setq _strucp (fn (s) (and (structurep s) (= (s 1) '_defctx))))
(setq _make-n
(lambda-macro ()
(let (_gsym (sym (gensym))
_vars (append '_vari (map (fn (x) (first (mklist x))) (args)))
_vals (append '_vali (map (fn (x) (second (mklist x))) (args))))
(letex (_ctx _gsym
_default (sym _gsym _gsym)
_structurep (append (list 'structure '_defctx) '_vari)
_var (cons 'setq (apply append (transpose (list (map (hayashi sym _gsym) _vars) _vals)))))
(setq _default '_structurep)
_var
_ctx)))))))
(global 'defstruct 'structurep)
新リスプな日々 
コメントを残す