newLISP Fan Club
Forum => newLISP in the real world => Topic started by: hartrock on August 26, 2013, 07:19:35 AM
Influenced by a C++ background I've tried to get some assert()-like functionality. Here are the
(context 'assert)
;;
(define (assert-expr expr caller-sym no-in-func)
(++ call_count)
(if (not (eval expr))
(throw-error
(append
"assert failed for expr: " (string expr)
(if caller-sym ; implies no-in-func
(let (caller-fun (eval caller-sym))
(if (not (or (lambda? caller-fun) (macro? caller-fun)))
(append
" (caller " (string caller-sym) " is not a lambda/macro)")
(append
"n-> " (string no-in-func) ". assert called from "
(string caller-sym))))
""))))
true)
;;
(define-macro (assert:assert expr caller-sym no-in-func)
(assert-expr expr caller-sym no-in-func))
(set 'pre assert:assert)
;;
(set 'assert_ctx_sym (sym 'assert MAIN))
(define (assertSyms-cmp ignored e)
(or
(= e assert_ctx_sym) ; 'assert would lead to 'assert:assert
(= e 'assert:assert)
(= e 'assert:pre)))
;;
;; inplace mod of a ref-all'ed list referenced by rsym
(define (sym-mod-ref-all rsym func-sym-mod-ref exp-key func-compare)
(assert (list? (eval rsym)))
(local (modFlag)
(dolist
(r (if func-compare ;; nil arg is different from no arg here ..
(ref-all exp-key (eval rsym) func-compare)
(ref-all exp-key (eval rsym)))) ; .. no nil arg!
(if (func-sym-mod-ref rsym r exp-key)
(setq modFlag true)))
modFlag))
;;
(define (assertCall-sym-mod-ref caller-sym assert-ref exp-key-ignored)
(local (modFlag)
(if (= (last assert-ref) 0) ; func call pos?
(letn ((aref (0 -1 assert-ref)) ; one level up of assert sym
(alist (nth aref (eval caller-sym)))) ; nth avoids func call
(if (<= (length alist) 2) ; (assert) or (assert expr)
(begin
(if (= (length alist) 1) ; check for naked assert
(push nil alist -1)) ; -> add missing nil expr.
(push caller-sym alist -1) ; add more ..
(push (++ no-in-func) alist -1) ; .. info.
(setq modFlag true)
;; replace (args) calls in assert by local-args ..
(let (argsRefs (ref-all 'args alist) argsFlag nil)
(if (not (null? argsRefs))
(begin
(dolist
(e argsRefs)
(if (length (alist (-1 e)) 1) ; just (args)
(begin
(setq argsFlag true)
(setq (alist (0 -1 e)) 'assert:local-args))))
;; .. inited before calling assert.
(if argsFlag
(setq alist
(list 'begin
'(setq assert:local-args (args))
alist))))))
(setq (nth aref (eval caller-sym)) alist)))))
modFlag))
;;
;; add missing args of assert calls
(define (tweak-arguments rsym)
(if (or (lambda? (eval rsym)) (macro? (eval rsym)))
(local (no-in-func)
(if (sym-mod-ref-all rsym assertCall-sym-mod-ref nil assertSyms-cmp)
(println (string no-in-func) " (assert) call"
(if (> no-in-func 1) "s" "") " modified in: " rsym)))))
;;
;; asserts in contexts
;;
(define (tweak-context ctx)
(dolist (s (symbols ctx))
(tweak-arguments s)))
(define (tweak-contexts contexts)
(dolist (ctx contexts)
(tweak-context ctx)))
(context MAIN)
Why this is so long is best explained by - a simplified - use-case:
;;; [insert assert code from above]
;;
;; { copy'n'paste
;;
;; simplified use-case for assert demo purposes
;;
(context 'db_proto)
;;
(define (init dataCtx metaCtx transCtx)
(setq data dataCtx)
(setq meta metaCtx)
(setq trans transCtx)
(context))
;;
(define (get-data-1 id) ; assert list arg
(assert:pre (and
(string? id)
(not (nil? (data id)))))
(data id))
;;
(define (get-data-2 id) ; assert non-list arg, assert call enumeration
(assert:pre (string? id))
(assert (not (nil? (data id))))
(data id))
;;
(context MAIN)
;;
(context 'db)
;;
(define (create)
(let (tmp (args))
(assert (null? tmp)))
(++ dbCount)
(context MAIN)
(let ((db_sym (sym (append "DB_" (string dbCount))))
(data_sym (sym (append "Data_" (string dbCount)))))
(let (db_ctx (new db_proto db_sym)) ; transfer syms from db_proto: to DB_*
(db_ctx:init ; call :init
(new Tree data_sym)))))
(define (create_alt)
(assert (null? (args)))
(++ dbCount)
(context MAIN)
(let ((db_sym (sym (append "DB_" (string dbCount))))
(data_sym (sym (append "Data_" (string dbCount)))))
(let (db_ctx (new db_proto db_sym)) ; transfer syms from db_proto: to DB_*
(db_ctx:init ; call :init
(new Tree data_sym)))))
;;
(context MAIN)
;;
;; } copy'n'paste
;; { copy'n'paste
;;
;; 1. test without assert call modifications
;; init
(set 'dbc (db:create))
(dbc:data "foo" "bar") ; put something into data
;;
;; } copy'n'paste
;;
;; try manually from here
;; a.
(db:create "forbidden arg")
;; -> this gives db:create info *without* tweaking asserts
(db:create_alt "forbidden arg")
;; -> this does not work without tweaking (should throw)
;; b.
(dbc:get-data-1) ; missing id
(dbc:get-data-2) ; missing id
;; c.
(dbc:get-data-1 "wrong id")
(dbc:get-data-2 "wrong id")
;; d.
(dbc:get-data-1 "foo") ; correct id
(dbc:get-data-2 "foo") ; correct id
;;
;; { copy'n'paste
;;
;; 2. test with assert call modifications
;; modify assert calls
(assert:tweak-contexts '(db db_proto))
;; short form for
;; (assert:tweak-context db) (assert:tweak-context db_proto)
;;
;; (assert:tweak-context db_proto)
;; short from for:
;; (assert:tweak-arguments 'db_proto:get-data-1)
;; (assert:tweak-arguments 'db_proto:get-data-2)
;;
;; just one func:
;; (assert:tweak-arguments 'db:create)
;;
;;
;; init of new db (old one contains unmodified calls)
(set 'dbc (db:create))
(dbc:data "foo" "bar") ; put something into data
;;
;; } copy'n'paste
;;
;; try manually from here
;; a.
(db:create "forbidden arg")
;; -> db:create info redundant after modifying asserts
(db:create_alt "forbidden arg")
;; -> this does work now after tweaking (throws)
;; b.
(dbc:get-data-1) ; missing id
(dbc:get-data-2) ; missing id
;; c.
(dbc:get-data-1 "wrong id")
(dbc:get-data-2 "wrong id")
;; d.
(dbc:get-data-1 "foo") ; correct id
(dbc:get-data-2 "foo") ; correct id
;;
Case a.
In the other cases added caller info would be missing without tweaking asserts: it won't be shown as part of output of throw callstacks (this has been a reason to start with these tweaks).
To avoid calling (args) in a wrong function context, a temp var will be inserted in this case; see
Any suggestions for improvements are welcome (I like to learn).
Possible extensions are tweaks for:
Versions: