; 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))
(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

(context 'MAIN:do*)
(define (make-stepform bindform)
  (remove nil (mappend (fn (b) (if (and (consp b) (third b))
                               (list (car b) (third b))
(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

(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)

(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)

(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)))))))

(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)
      ((self-r (tree)
         (if (atom tree)
             (if (functionp 'base) (base tree)
                 (MACRO?    'base) (eval (base tree))
             (rec tree (fn () (self-r (first tree)))
                       (fn () (if (rest tree)
                                  (self-r (rest tree))))))))

(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))))
        (define-macro _mname
        (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)))

(define-macro (=funcall)
; (=fancall fn &rest args)
  (letex (_body (append (list (args 0) '*cont*) (1 (args))))

(define-macro (=apply)
; (=apply fn &rest args)
  (letex (_body (append (list 'apply (args 0) '*cont*) (1 (args))))

(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))))

(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)
      (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)

(global 'defstruct 'structurep)

No comments yet



WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中