This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.
Code Select
sr@freen:~/newLISP_Core/mirror$ ./newlisp
newLISP v.10.7.1 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
> (set 'v nil 'r (string "foo")) (sys-info 0)
"foo"
442
> (set 'v nil 'r (string "foo")) (sys-info 0)
"foo"
443
>
;; no mem leak:
(set 'r (string "foo")) (sys-info 0)
"foo"
443
>
Code Select
sr@freen:~$ newlisp
newLISP v.10.6.5 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
> (set 's (sym "Foo bar" MAIN))
Foo bar
> (context s)
ERR: invalid parameter in function context : "Foo bar"
> (context s)
Segmentation fault
Code Select
"/usr/lib/x86_64-linux-gnu/libcrypto.so.1.0.0" ; Debian jessie
Code Select
sr@freen:~/newLISP$ newlisp
newLISP v.10.6.5 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
>
(set 'sy nil)
(define (f) (println 'sy:bar))
(delete 'sy)
(f)
nil
(lambda () (println 'sy:bar))
true
�~�:bar
bar:bar
>
Code Select
>
(define (leave-string str pos)
(if (>= pos 0)
(0 pos str)
((- (min (- pos) (length str))) str)))
;;
(set 'str "foobar")
(leave-string str 3) ; first 3
(leave-string str -3) ; last 3
;;
(leave-string str 7) ; first 7 (all with pos one out of range)
(leave-string str -7) ; last 7 (all with pos one out of range)
(lambda (str pos)
(if (>= pos 0)
(0 pos str)
((- (min (- pos) (length str))) str)))
"foobar"
"foo"
"bar"
"foobar"
"foobar"
>
Code Select
>
(define (foo (a1 1) (a2 (+ a1 1)) (a3 (+ a2 1)))
(println "a1: " a1 ", a2: " a2 ", a3: " a3))
(foo)
(lambda ((a1 1) (a2 (+ a1 1)) (a3 (+ a2 1))) (println "a1: "
a1 ", a2: " a2 ", a3: " a3))
a1: 1, a2: 2, a3: 3
3
>
(set 'a1 1 'a2 (+ a1 1) 'a3 (+ a2 1))
(println "a1: " a1 ", a2: " a2 ", a3: " a3)
3
a1: 1, a2: 2, a3: 3
3
>
Code Select
;;
;; script properties
;; - could become part of getopts or an own module
;;
;; *** old basename (now scriptname) too limited ***
;;
;;;; works for both newLisp and #!/.../newlisp
;;(define (basename)
;; (setq execPath (or (main-args 1) (main-args 0)))
;; (last (parse execPath "/")))
;;
;; A (scriptpath), (scriptname), (scriptargs) solution for skipping newlisp opts
;; and their args: could be a helper for getopts.
;;
;; Should be correct for typical shebang (#!/...) cases, but of interest here
;; are newlisp calls like:
;; newlisp -s 4096 -m 10 someScript.lsp
;; .
;;
;; But it has limitations: it is only correkt, if *first* non-option arg of
;; newlisp is the script of interest.
;; E.g. calling
;; newlisp -m 10 nonExistentFile
;; results into
;; > (Logger:scriptname)
;; "nonExistentFile"
;; .
;; Therefrom it should be allowed and documented how to override; this can be
;; done by setting scriptpath_ix explicitely, in case of used heuristics fails.
;;
;; See file:///usr/share/doc/newlisp/newlisp_manual.html#options:
;;
;; -h this help -> OK (enters interpreter)
;; -n no init.lsp (must be first) -> OK
;; -x <source> <target> link -> error: should not been reached by script
;; -v version -> OK (enters interpreter)
;; -s <stacksize> -> OK
;; -m <max-mem-MB> cell memory -> OK
;; -e <quoted lisp expression> -> OK (enters interpreter)
;; -l <path-file> log connections -> OK
;; -L <path-file> log all -> OK
;; -w <working dir> -> OK
;; -c no prompts, HTTP -> OK
;; -C force prompts -> OK
;; -t <usec-server-timeout> -> OK
;; -p <port-no> -> OK
;; -d <port-no> demon mode -> OK
;; -http only -> OK
;; -6 IPv6 mode -> OK
;;
(set'opt_without_arg
'("-h" ; enters interpreter
"-n" ; -> skipped
"-v" ; enters interpreter
"-c" ; -> skipped
"-C" ; -> skipped
"-http" ; -> skipped
"-6" ; -> skipped
)
'opt_with_arg
'("-s" ; -> skipped
"-e" ; enters interpreter
"-m" ; -> skipped
"-l" ; -> skipped
"-L" ; -> skipped
"-w" ; -> skipped
"-t" ; -> skipped
"-p" ; -> skipped
"-d" ; -> skipped
)
'opt_with_2_args
'("-x" ; should not been reached by script
;;"-y" ; for testing errorcase...
))
(local (breakFlag skip_next ix execPath)
(set 'ix 0) ; without any args ix 0 refers to newlisp bin
(dolist
(o (1 (main-args)) breakFlag) ; without args, there is no loop here
(cond
(skip_next
(++ ix)
(set 'skip_next nil)) ; skip once
((find o opt_without_arg)
(++ ix))
((find o opt_with_arg)
(++ ix)
(set 'skip_next true))
((find o opt_with_2_args)
(throw-error "should not been reached"))
("default" ; end loop: first newlisp noopt should be script
(++ ix) ; needed: loop started with ix of previous element
(set 'breakFlag true))))
(set 'scriptpath_ix ix ; 0 or index of first element not being a newlisp option with its args
'scriptargs_ ((+ 1 scriptpath_ix) (main-args))
'scriptpath_ (main-args scriptpath_ix)
'scriptname_ (last (parse scriptpath_ "/"))))
;; iface
(define (scriptpath-ix)
scriptpath_ix)
(define (scriptargs) ; good as getopts arg
scriptargs_)
(define (scriptpath)
scriptpath_)
(define (scriptname) ; Linux (to be extended for other OSes)
scriptname_)
(define (shebang?) ; works for Linux; to be extended for other OSes
(and (= (main-args 0) "/usr/local/bin/newlisp")
(!= (scriptname) "newlisp")))
;;
;; .. script properties
;;
Code Select
sr@free:~/newLISP_Git/mirror$ git diff -p inprogress HEAD
diff --git a/mirror/newlisp.c b/mirror/newlisp.c
index 262339d..0190bc5 100644
--- a/mirror/newlisp.c
+++ b/mirror/newlisp.c
@@ -192,6 +192,8 @@ SYMBOL * atSymbol;
SYMBOL * currentFunc;
SYMBOL * argsSymbol;
SYMBOL * mainArgsSymbol;
+SYMBOL * mainArgsLoadIxSymbol;
+SYMBOL * loadListSymbol;
SYMBOL * listIdxSymbol;
SYMBOL * itSymbol;
SYMBOL * sysxSymbol;
@@ -894,6 +896,7 @@ for(idx = 1; idx < argc; idx++)
exit(0);
}
+ mainArgsLoadIxSymbol->contents = (UINT)stuffInteger(idx);
loadFile(argv[idx], 0, 0, mainContext);
}
@@ -1428,6 +1431,8 @@ questionSymbol = translateCreateSymbol("?", CELL_NIL, mainContext, TRUE);
atSymbol = translateCreateSymbol("@", CELL_NIL, mainContext, TRUE);
argsSymbol = translateCreateSymbol("$args", CELL_NIL, mainContext, TRUE);
mainArgsSymbol = translateCreateSymbol("$main-args", CELL_NIL, mainContext, TRUE);
+mainArgsLoadIxSymbol = translateCreateSymbol("$main-args-load-ix", CELL_NIL, mainContext, TRUE);
+loadListSymbol = translateCreateSymbol("$load-list", CELL_NIL, mainContext, TRUE);
listIdxSymbol = translateCreateSymbol("$idx", CELL_NIL, mainContext, TRUE);
itSymbol = translateCreateSymbol("$it", CELL_NIL, mainContext, TRUE);
countSymbol = translateCreateSymbol("$count", CELL_NIL, mainContext, TRUE);
@@ -1454,6 +1459,8 @@ questionSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
atSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
argsSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
mainArgsSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
+mainArgsLoadIxSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
+loadListSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
listIdxSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
itSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
countSymbol->flags |= SYMBOL_GLOBAL | SYMBOL_BUILTIN | SYMBOL_PROTECTED;
@@ -1465,6 +1472,8 @@ argsSymbol->contents = (UINT)getCell(CELL_EXPRESSION);
objSymbol.contents = (UINT)nilCell;
objSymbol.context = mainContext;
objCell = nilCell;
+mainArgsLoadIxSymbol->contents = (UINT)nilCell;
+loadListSymbol->contents = (UINT)getCell(CELL_EXPRESSION);
/* init signal handlers */
for(i = 0; i < 32; i++)
@@ -3291,6 +3300,7 @@ if(my_strnicmp(fileName, "http://", 7) == 0)
pushResult(result);
if(memcmp((char *)result->contents, "ERR:", 4) == 0)
return(errorProcExt2(ERR_ACCESSING_FILE, stuffString((char *)result->contents)));
+ addList((CELL*)loadListSymbol->contents, stuffString(fileName));
result = copyCell(sysEvalString((char *)result->contents, context, nilCell, EVAL_STRING));
currentContext = contextSave;
return(result);
@@ -3314,6 +3324,7 @@ for(i = 0; i<recursionCount; i++) printf(" ");
printf("load: %sn", fileName);
#endif
+addList((CELL*)loadListSymbol->contents, stuffString(fileName));
result = evaluateStream(&stream, 0, TRUE);
currentContext = contextSave;
Code Select
sr@free:~/newLISP/Examples$ newlisp
newLISP v.10.6.4 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
> $main-args $main-args-load-ix $load-list
("newlisp")
nil
()
>
sr@free:~/newLISP/Examples$ newlisp notExisting
newLISP v.10.6.4 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
> $main-args $main-args-load-ix $load-list
("newlisp" "notExisting")
1
()
>
sr@free:~/newLISP/Examples$ touch existing.lsp # empty
sr@free:~/newLISP/Examples$ newlisp -s 1000 existing.lsp --foo
newLISP v.10.6.4 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
> $main-args $main-args-load-ix $load-list
("newlisp" "-s" "1000" "existing.lsp" "--foo")
4
("existing.lsp")
>
sr@free:~/newLISP/Examples$ cat printThese.lsp
#!/usr/bin/env newlisp
(println "$main-args: " $main-args)
(println "$main-args-load-ix: " $main-args-load-ix)
(println "$load-list: " $load-list)
sr@free:~/newLISP/Examples$ newlisp -s 1000 printThese.lsp --foo
$main-args: ("newlisp" "-s" "1000" "printThese.lsp" "--foo")
$main-args-load-ix: 3
$load-list: ("printThese.lsp")
newLISP v.10.6.4 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
> $main-args $main-args-load-ix $load-list
("newlisp" "-s" "1000" "printThese.lsp" "--foo")
4
("printThese.lsp")
>
Code Select
sr@free:~/newLISP/Examples$ newlisp
newLISP v.10.6.4 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
> $main-args $main-args-load-ix $load-list
("newlisp")
nil
("/home/sr/.init.lsp" "/home/sr/newLISP/modules/Init.lsp"
"/home/sr/newLISP/modules/FOOPReference.lsp" "/home/sr/newLISP/modules/Util.lsp"
"/home/sr/newLISP/modules/Logger.lsp" "/home/sr/newLISP/modules/LoggerTweakable.lsp"
"/home/sr/newLISP/modules/Libs.lsp")
>
sr@free:~/newLISP/Examples$ newlisp -s 1000 printThese.lsp --foo
$main-args: ("newlisp" "-s" "1000" "printThese.lsp" "--foo")
$main-args-load-ix: 3
$load-list: ("/home/sr/.init.lsp" "/home/sr/newLISP/modules/Init.lsp"
"/home/sr/newLISP/modules/FOOPReference.lsp" "/home/sr/newLISP/modules/Util.lsp"
"/home/sr/newLISP/modules/Logger.lsp" "/home/sr/newLISP/modules/LoggerTweakable.lsp"
"/home/sr/newLISP/modules/Libs.lsp" "printThese.lsp")
newLISP v.10.6.4 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
> $main-args $main-args-load-ix $load-list
("newlisp" "-s" "1000" "printThese.lsp" "--foo")
4
("/home/sr/.init.lsp" "/home/sr/newLISP/modules/Init.lsp"
"/home/sr/newLISP/modules/FOOPReference.lsp" "/home/sr/newLISP/modules/Util.lsp"
"/home/sr/newLISP/modules/Logger.lsp" "/home/sr/newLISP/modules/LoggerTweakable.lsp"
"/home/sr/newLISP/modules/Libs.lsp" "printThese.lsp")
>
[code](Inspector]Code Select ;; script dir detection
(set 'Inspector:scriptname "startIt.lsp"
'Inspector:dir ; be robust against CLI args not containing scriptname
(0 (- (length Inspector:scriptname)) ; only leave dirpath
(first (filter (fn (a) (find Inspector:scriptname a))
(main-args)))))
(if (null? Inspector:dir)
(set 'Inspector:dir ".")) ; cwd
Code Select
#!/usr/bin/env newlisp
(load "modules/Util.lsp")
(load "modules/Introspection.lsp")
;; make snapshot
(set 'filepath "/tmp/snapshot.json")
(define (make-snapshot filepath)
(write-file filepath
(Introspection:symbols-to-JSON (Util:symbols-all))))
(make-snapshot filepath)
(println "You may look onto snapshot's symbols byn"
" http:localhost:8080/symbols.html?file="
filepath "n.")
Code Select
> (define (foo) (println "foo" (+ 1 2)))
(lambda () (println "foo" (+ 1 2)))
> (trace true) (foo)
true
-----
(define (foo )
#(println "foo" (+ 1 2))#)
[-> 2 ] s|tep n|ext c|ont q|uit >
Code Select
> (define (foo) (println "foo" (+ 1 2)))
(lambda () (println "foo" (+ 1 2)))
> (trace true) ((eval 'foo))
true
foo3
3
0 >
Code Select
> (define (foo) (println "foo" (+ 1 2)))
(lambda () (println "foo" (+ 1 2)))
> (define (w aSym) (trace true) (set 't (eval aSym)) (t))
(lambda (aSym) (trace true) (set 't (eval aSym)) (t))
> (w 'foo)
-----
(define (t )
#(println "foo" (+ 1 2))#)
[-> 3 ] s|tep n|ext c|ont q|uit >
Code Select
(context 'Util)
(define (sym? strOrSym ctx)
(sym strOrSym ctx nil))
(define (lambda-or-macro-symbol? expr)
(and (symbol? expr)
(or (lambda? (eval expr))
(macro? (eval expr)))))
(define (sym-string s , symStr)
(set 'symStr (string s))
(if (find ":" symStr)
(letn ((prefixCtx (prefix s))
(parsedStr (parse symStr ":"))
(prefixStr (first parsedStr))
(termStr (last parsedStr))
(prefixCtxStr (string prefixCtx)))
(if (!= prefixStr prefixCtxStr)
(append symStr " [" prefixStr ":] " prefixCtxStr ":" termStr)
symStr))
(string (prefix s) ":" (term s))))
(define (add-prefix-to-sym prefixStr symbol)
(sym (append prefixStr (term symbol))
(prefix symbol))) ; get correct ctx prefix
(define (add-postfix-to-sym postfixStr symbol)
(sym (append (term symbol) postfixStr)
(prefix symbol))) ; get correct ctx prefix
(define (add-prefix-to-syms prefixStr symList)
(map (curry add-prefix-to-sym prefixStr) symList))
(define (add-postfix-to-syms postfixStr symList)
(map (curry add-postfix-to-sym postfixStr) symList))
(define (swap-symbols symList_1 symList_2)
(map (fn (s_1 s_2) (swap (eval s_1) (eval s_2)))
symList_1 symList_2))
;; These functions are an intermediate between
;; - (new srcCtx dstCtx) : not overwriting the vals of existing syms in dstCtx;
;; and
;; - (new srcCtx dstCtx true) : overwriting the val of existing syms in dstCtx.
;; They overwrite the vals of existing syms in dstCtx, but only then, if they
;; are:
;; 1. Variant: *not* nil in srcCtx (overwrite in case of non-nil conflicts).
;; 2. Variant: nil in dstCtx (*no* overwrite in case of non-nil conflicts).
;; Motivation:
;; - There may be nil syms in srcCtx just by referencing syms expected to be in
;; dstCtx, which *should* *not* be overwritten in dstCtx.
;; - There may be nil syms in dstCtx by referencing syms expected to be in
;; srcCtx, which *should* be overwritten.
;; Notes:
;; - *non*-existent syms in dstCtx will be created even with nil vals from
;; srcCtx.
;; - in case of a conflict between not-nil values of a sym in both contexts,
;; srcCtx losses (1.) or wins (2.).
;;
;; 1. this variant does not overwrite non-nils by non-nils.
;; Note: to be preferred against 2. variant below, if overwritng not needed (for
;; the reason see note there).
(define (mixin-no-overwrite-of-non-nil srcCtx dstCtx)
(dolist
(s (symbols srcCtx))
(if (or (not (sym? s dstCtx))
(nil? (eval (sym s dstCtx))))
(def-new s (sym s dstCtx))
"skip (no overwrite of non-nil vals)")))
;; 2. this variant overwrites non-nils by non-nils.
;; Note: this may overwrite *** just created *** non-nils - by recursively
;; created deps during creation of former symbols.
(define (mixin-no-overwrite-with-nil srcCtx dstCtx)
(dolist
(s (symbols srcCtx))
(if (or (not (sym? s dstCtx))
(eval s)) ; not nil
(def-new s (sym s dstCtx))
"skip (no overwrite with nil vals)")))
(context MAIN)
Code Select
(context 'FOOPReference)
;; indices of elems in FOOP list
(constant 's_class 0 's_ref 1)
;; helpers
(define (ref-context-sym ix)
(sym (string (context) "_" ix) MAIN))
(define (new-ref-context-sym)
(ref-context-sym (++ foopCount))) ; foopCount for identifying FR instances
(define (new-ref-context)
(let (ref_contextSym (new-ref-context-sym))
(prefix (sym ref_contextSym ref_contextSym)))); without switching to new ctx
;; standard functor: each call increases foopCount
(define (FOOPReference:FOOPReference)
(letn ((ref_context (new-ref-context)) ; increments foopCount
(foop (cons (context) (cons ref_context (args)))))
(set (sym (string ref_context) ref_context) foop) ; set ref context default
ref_context))
;; accessors
(define (class) ; FOOP Class
(self s_class))
(define (reference) ; FOOP reference context
(self s_ref))
;; cleaners
(define (delete-ref ctxSym)
(delete ctxSym) ; syms in context including foop default
(delete ctxSym)) ; context in MAIN
(define (delete-ref-ix ix)
(delete-ref (ref-context-sym ix)))
(define (delete-all-refs) ; robust against missing refs/foops already deleted
(while (> foopCount 0)
(delete-ref-ix foopCount)
(-- foopCount)))
(context MAIN)
Code Select
(when (not (context? FOOPReference))
(write-line 2 "[FATAL] Logger needs module FOOPReference.lsp.")
(exit 1))
(when (not (context? Util))
(write-line 2 "[FATAL] Logger needs module Util.lsp.")
(exit 1))
(when (context? Logger)
(write-line 2 "[Warning] Context Logger already defined."))
(new FOOPReference 'Logger)
(context Logger)
;;
;; script properties
;; - should probably become part of getopts or an own module
;;
;; *** old basename (now scriptname) too limited ***
;;
;;;; works for both newLisp and #!/.../newlisp
;;(define (basename)
;; (setq execPath (or (main-args 1) (main-args 0)))
;; (last (parse execPath "/")))
;;
;; A (scriptpath), (scriptname), (scriptargs) solution for skipping newlisp opts
;; and their args: could be a helper for getopts.
;;
;; Should be correct for typical shebang (#!/...) cases, but of interest here
;; are newlisp calls like:
;; newlisp -s 4096 -m 10 someScript.lsp
;; .
;;
;; But it has limitations: it is only correkt, if *first* non-option arg of
;; newlisp is the script of interest.
;; E.g. calling
;; newlisp -m 10 nonExistentFile
;; results into
;; > (Logger:scriptname)
;; "nonExistentFile"
;; .
;; Therefrom it should be allowed and documented how to override; this can be
;; done by setting scriptpath_ix explicitely, in case of used heuristics fails.
;;
;; See file:///usr/share/doc/newlisp/newlisp_manual.html#options:
;;
;; -h this help -> OK (enters interpreter)
;; -n no init.lsp (must be first) -> OK
;; -x <source> <target> link -> error: should not been reached by script
;; -v version -> OK (enters interpreter)
;; -s <stacksize> -> OK
;; -m <max-mem-MB> cell memory -> OK
;; -e <quoted lisp expression> -> OK (enters interpreter)
;; -l <path-file> log connections -> OK
;; -L <path-file> log all -> OK
;; -w <working dir> -> OK
;; -c no prompts, HTTP -> OK
;; -C force prompts -> OK
;; -t <usec-server-timeout> -> OK
;; -p <port-no> -> OK
;; -d <port-no> demon mode -> OK
;; -http only -> OK
;; -6 IPv6 mode -> OK
;;
(set'opt_without_arg
'("-h" ; enters interpreter
"-n" ; -> skipped
"-v" ; enters interpreter
"-c" ; -> skipped
"-C" ; -> skipped
"-http" ; -> skipped
"-6" ; -> skipped
)
'opt_with_arg
'("-s" ; -> skipped
"-e" ; enters interpreter
"-m" ; -> skipped
"-l" ; -> skipped
"-L" ; -> skipped
"-w" ; -> skipped
"-t" ; -> skipped
"-p" ; -> skipped
"-d" ; -> skipped
)
'opt_with_2_args
'("-x" ; should not been reached by script
;;"-y" ; for testing errorcase...
))
(local (breakFlag skip_next ix execPath)
(set 'ix 0) ; without any args ix 0 refers to newlisp bin
(dolist
(o (1 (main-args)) breakFlag) ; without args, there is no loop here
(cond
(skip_next
(++ ix)
(set 'skip_next nil)) ; skip once
((find o opt_without_arg)
(++ ix))
((find o opt_with_arg)
(++ ix)
(set 'skip_next true))
((find o opt_with_2_args)
(throw-error "should not been reached"))
("default" ; end loop: first newlisp noopt should be script
(++ ix) ; needed: loop started with ix of previous element
(set 'breakFlag true))))
(set 'scriptpath_ix ix ; 0 or index of first element not being a newlisp option with its args
'scriptargs_ ((+ 1 scriptpath_ix) (main-args))
'scriptpath_ (main-args scriptpath_ix)
'scriptname_ (last (parse scriptpath_ "/"))))
;; iface
(define (scriptpath-ix)
scriptpath_ix)
(define (scriptargs) ; good as getopts arg
scriptargs_)
(define (scriptpath)
scriptpath_)
(define (scriptname) ; Linux (to be extended for other OSes)
scriptname_)
(define (shebang?) ; works for Linux; to be extended for other OSes
(and (= (main-args 0) "/usr/local/bin/newlisp")
(!= (scriptname) "newlisp")))
;;
;; .. script properties
;;
;; helper
;;
(define (write-string str)
(write-line (fd) str))
(define (prefix-loc-string (locStrOrSym "") (extraPrefix ""))
(format
(if (null? locStrOrSym)
"%s[%s%s]%s "
"%s[%s %s]%s ")
(preprefix-string) (scriptname) (string locStrOrSym) extraPrefix))
(define (prefix-string (extraPrefix ""))
(prefix-loc-string "" extraPrefix))
(define (to-string arguments)
;;(println "arguments: " arguments)
(if (null? arguments)
"? (no msg)"
(apply string arguments)))
(define (msg-format arguments)
(write-string (to-string arguments)))
(constant 'c_fatalStr "[FATAL]"
'c_errorStr "[ERROR]"
'c_warningStr "[Warning]"
'c_infoStr "[Info]")
;; iface
;;
;; (msg arg [arg [...]]) : like args for println
(define (msg)
(when (<= (level) level_debug)
(write-string (append (prefix-string)
(to-string (args))))))
(define (msg-loc locStrOrSym)
(when (<= (level) level_debug)
(write-string (append (prefix-loc-string locStrOrSym)
(to-string (args))))))
(define (info)
(when (<= (level) level_info)
(write-string (append (prefix-string c_infoStr)
(to-string (args))))))
(define (info-loc locStrOrSym)
(when (<= (level) level_info)
(write-string (append (prefix-loc-string locStrOrSym c_infoStr)
(to-string (args))))))
(define (warn)
(when (<= (level) level_warn)
(write-string (append (prefix-string c_warningStr)
(to-string (args))))))
(define (h_warn-loc-string locStrOrSym arguments)
(append (prefix-loc-string locStrOrSym c_warningStr)
(to-string arguments)))
(define (warn-loc locStrOrSym)
(when (<= (level) level_warn)
(write-string (h_warn-loc-string locStrOrSym (args)))))
(define (error)
(when (<= (level) level_error)
(write-string (append (prefix-string c_errorStr)
(to-string (args))))))
(define (error-loc locStrOrSym)
(when (<= (level) level_error)
(write-string (append (prefix-loc-string locStrOrSym c_errorStr)
(to-string (args))))))
(define (fatal)
(when (<= (level) level_fatal)
(write-string (append (prefix-string c_fatalStr)
(to-string (args))))))
(define (fatal-loc locStrOrSym)
(when (<= (level) level_fatal)
(write-string (append (prefix-loc-string locStrOrSym c_fatalStr)
(to-string (args))))))
;; helper
;;
(constant 'indentIncrement 2)
(define (indent-string)
(let (str "")
(dotimes (n (indent)) ; uses foop indent
(extend str " "))
str))
;;
;; iface
;;
;; overload global begin: this is *dangerous* for all contexts ..
(define (Logger:begin (what "")) ; .. getting syms from here!
(when (<= (level) level_debug)
(write-string (append
(prefix-string)
(indent-string)
"(" (string what) "..."))
(++ (self s_indent) indentIncrement)))
(define (end (what ""))
(when (<= (level) level_debug)
(-- (self s_indent) indentIncrement)
(write-string (append
(prefix-string)
(indent-string)
"..." (string what) ")"))))
;; macro to show expr unevaluated; returns evaluation
(define-macro (wrap expr (what (string expr)))
(begin what) ; Logger:begin
(let (res (eval expr))
(end what)
res))
(define (convenience-forward FunSym ctx)
(let (Ctx (sym (string ctx) MAIN)) ; alt (slower): use (context) ..
(set (sym FunSym ctx)
(expand '(lambda ()
(:FunSym Ctx ; .. instead of Ctx here. avoid ..
(apply string (args)))))))) ; .. forwarding as list
(define (convenience-forward-first-rest FunSym ctx)
(let (Ctx (sym (string ctx) MAIN))
(set (sym FunSym ctx)
(expand '(lambda ()
(:FunSym Ctx
(args 0) ; unchanged first (loc) and stringified ..
(apply string (rest (args))))))))) ; .. rest args
(when (not standard_constructor) ; be robust against module reload
(set 'standard_constructor Logger)) ; store ctor from FOOPReference for reuse
;; FOOP Logger ctor with check for int fd
(define (Logger (fd 2) ; stderr
(preprefix-string (fn () "")) ; optional
(log-level level_default)) ; optional
(if (not (integer? fd))
(MAIN:begin ; avoid Logger:begin
;; difficult to use a logger here...
(write-line 2 "[FATAL] fd arg has to be an int.")
(exit 1)))
(let (ref_ctx (standard_constructor fd
preprefix-string
log-level
0)) ; indent starting with 0
;; convenience func forwards from ref context to foop
[text] ;(convenience-forward 'info ref_ctx) results into (for first logger):
(lambda () (: Logger:info Logger_1 (apply string (args))))
[/text]
(convenience-forward 'msg ref_ctx)
(convenience-forward-first-rest 'msg-loc ref_ctx)
(convenience-forward 'info ref_ctx)
(convenience-forward-first-rest 'info-loc ref_ctx)
(convenience-forward 'warn ref_ctx)
(convenience-forward-first-rest 'warn-loc ref_ctx)
(convenience-forward 'error ref_ctx)
(convenience-forward-first-rest 'error-loc ref_ctx)
(convenience-forward 'fatal ref_ctx)
(convenience-forward-first-rest 'fatal-loc ref_ctx)
;; log level forwards
(set (sym 'level-debug ref_ctx) (lambda () (:level-debug (context))))
(set (sym 'level-all ref_ctx) (lambda () (:level-all (context))))
(set (sym 'level-info ref_ctx) (lambda () (:level-info (context))))
(set (sym 'level-warn ref_ctx) (lambda () (:level-warn (context))))
(set (sym 'level-error ref_ctx) (lambda () (:level-error (context))))
(set (sym 'level-fatal ref_ctx) (lambda () (:level-fatal (context))))
(set (sym 'level ref_ctx) (lambda () (:level (context))))
(set (sym 'begin ref_ctx) (lambda ((what ""))
(:begin (context) what)))
(set (sym 'end ref_ctx) (lambda ((what ""))
(:end (context) what)))
;; mixins
(setq ref_ctx:mixin-expr
(lambda ()
(Util:mixin-no-overwrite-of-non-nil MAIN:LoggerExpr (context))))
(setq ref_ctx:mixin-expr-debug
(lambda ()
((eval (sym "mixin-expr" (context)))) ; not elegant, but it works
(Util:mixin-no-overwrite-of-non-nil MAIN:LoggerDebug (context))))
;; default logger for being used by other modules
(if (not Logger:default) ; overload MAIN:default
(set 'Logger:default ref_ctx))
ref_ctx))
;; foop accessor indices (starting with 2)
(constant 's_fd 2 's_preprefixStr_func 3 's_logLevel 4 's_indent 5)
;; loglevels
(constant 'level_all 0
'level_debug 0
'level_info 1
'level_warn 2
'level_error 3
'level_fatal 4
'level_default level_info)
;; accessors
(define (fd) (self s_fd))
(define (set-fd fd) (setq (self s_fd) fd))
(define (preprefix-func) (self s_preprefixStr_func))
(define (set-preprefix-func fun) (setq (self s_preprefixStr_func) fun))
(define (log-level) (self s_logLevel))
(define (set-log-level l) (setq (self s_logLevel) l))
(define (indent) (self s_indent))
(define (set-indent indent) (setq (self s_indent) indent))
;; indirect getters
(define (preprefix-string)
((self s_preprefixStr_func))) ; call func
;; indirect setters
(define (use-timestamp-prefix)
(set-preprefix-func (fn () (date (date-value) 0 "[%Y-%m-%d %X]"))))
(define (use-debug-prefix)
(set-preprefix-func (fn () "[dbg]")))
(define (use-no-prefix)
(setq (set-preprefix_func (fn () ""))))
(define (use-prefix-fun prefixFun)
(set-preprefix-func prefixFun))
;; loglevel getters
(define (level)
(self s_logLevel))
(define (get-level-default) ; needed?
level_default)
;; loglevel setters
(define (level-default)
(setq (self s_logLevel) level_default))
(define (level-all)
(setq (self s_logLevel) level_all))
;;
(define (level-debug)
(setq (self s_logLevel) level_debug))
(define (level-info)
(setq (self s_logLevel) level_info))
(define (level-warn)
(setq (self s_logLevel) level_warn))
(define (level-error)
(setq (self s_logLevel) level_error))
(define (level-fatal)
(setq (self s_logLevel) level_fatal))
(context MAIN) ; ...Logger
;; Logger extended for expression info: shows expressions both unevaluated and
;; evaluated. Evaluation happens before forwarding to foop, which is not suited,
;; because it changes (self).
(context 'LoggerExpr)
(define (default? symbol)
(and (context? symbol)
(default symbol)))
;;
(define (rep a)
(if
(float? a) (format "%f" a)
(string? a) (append """ a """)
(array? a) (append "[]" (string a))
(quote? a) (append "'" (rep (eval a)))
(context? a) (append
"[ctx] " (string a)
(let (default_flag (Util:sym? (string a) a)) ; no new sym by check
(if default_flag
(append ", " (string a) ":" (string a)
" -> " (string (default a)))
"")))
(symbol? a) (Util:sym-string a)
(string a)))
(define (name-rep a sepFlag restFlag)
(local (sym_identical_flag)
(append
(if restFlag (if sepFlag "n, " "; ") "")
(if (number? a) (string a) ; source rep: 1 for 1.0 !
(symbol? a) (begin
(set 'sym_identical_flag (= a (eval a)))
(rep a))
(rep a))
(if sym_identical_flag " == " " -> ")
(if sepFlag ">>n" "")
(rep (setq lastExprEval (eval a)))
(if sepFlag "n<<" ""))))
(define (expr-info-string arguments sepFlag)
(local (nameReps)
(if (null? arguments)
(format "%s %s:expr: no argument" Logger:c_warningStr (string (context)))
(begin
(push (name-rep (first arguments) sepFlag) nameReps)
(dolist (a (rest arguments))
(push (name-rep a sepFlag true) nameReps -1))
(join nameReps)))))
(define (tloc2string loc) ; used by lib/assert.lsp
(format "%s %d"
(string (last loc))
(first loc)))
(define (expr-info-string-tloc tloc arguments sepFlag)
(append
(string "[" (tloc2string tloc) "] ")
(expr-info-string arguments sepFlag)))
;;
;; iface (to be moved to corresponding context (instead of using by FOOP)
;; to be fully functional)
;;
;; without output, just expr info string
(define-macro (expr-str)
(expr-info-string (args)))
;; new:
(define-macro (expr-str-sep)
(expr-info-string (args) true))
;;
;; with output into log channel
(define-macro (expr)
; after mixin into created Logger reference is (context) ..
(:msg (context) ; .. a FOOPReference with foop default getting :msg call
(expr-info-string (args)))
lastExprEval)
;; robustness against missing locStrOrSym
(define-macro (expr-loc (locStrOrSym ""))
(:msg-loc (context)
(string (eval locStrOrSym))
(expr-info-string (args)))
lastExprEval) ;)
;;
(define-macro (expr-sep)
(:msg (context)
(expr-info-string (args) true))
lastExprEval)
(define-macro (expr-loc-sep (locStrOrSym ""))
(:msg-loc (context)
(string (eval locStrOrSym))
(expr-info-string (args) true))
lastExprEval)
;; convenience forward to macro in foop; returns wrapped expr
(define-macro (wrap)
(eval (append '(:wrap (context)) (args))))
(context MAIN) ; ...LoggerExpr
(context 'LoggerDebug) ; specific dbg: functions
;; on/off switching of debug messages ...
(set 'symbols-to-be-switched
'(msg msg-loc LoggerDebug:begin end wrap ; not defined as tweakable below
;; expr-str[-sep][_tweaked] not to be switched
expr expr-loc
expr-sep expr-loc-sep
info info-loc) ; not defined as tweakable below
'symbols-to-be-switched-store (Util:add-prefix-to-syms
"_"
symbols-to-be-switched))
;; use empty non-evaluating macros for switched off versions
(dolist (s symbols-to-be-switched-store)
(set s (lambda-macro ())))
(setq LoggerDebug:debug true) ; default (overload MAIN:debug)
(define (switch)
(setq LoggerDebug:debug (not LoggerDebug:debug)) ; does not change nodebug flag!
;; to be swapped with their prefixed stored counterparts
(Util:swap-symbols symbols-to-be-switched
symbols-to-be-switched-store))
(define (on)
(if (not debug) ; LoggerDebug:debug
(MAIN:begin ; overloaded above
(switch)
"Now on.")
"Already on."))
(define (off)
(if debug ; LoggerDebug:debug
(MAIN:begin ; overloaded above
(switch)
"Off.")
"Already off."))
(context MAIN) ; ...LoggerDebug
Code Select
newLISP v.10.6.4 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
> ;; loading modules:
> (map load '("Util.lsp" "FOOPReference.lsp" "Logger.lsp"))
(MAIN MAIN MAIN)
> ;;
> (set 'l (Logger))
Logger_1
> (global 'l) ; for being visible in contexts loaded later
l
> ;;
> (l:info "an info") (l:warn "a warning") (l:error "an error") (l:fatal "a fatal condition")
[newlisp][Info] an info
24
[newlisp][Warning] a warning
29
[newlisp][ERROR] an error
26
[newlisp][FATAL] a fatal condition
35
> ;; but:
> (l:msg "a message needing level-debug")
nil
> (l:level-debug) ; (default is level-info)
0
> (l:msg "a message needing level-debug")
[newlisp] a message needing level-debug
40
> ;;
> ;;
> ;; There are more features by mixing-in some additional functionality:
> ;;
> (set 'le (Logger 2 (fn () "[le]") Logger:level_all)) ; stderr, preprefix fun
Logger_2
> (global 'le) ; for being visible in contexts loaded later
le
> (le:info "an info")
[le][newlisp][Info] an info
28
> ;; now let's mixin
> (le:mixin-expr)
Logger_2:wrap
> ;; now this works:
> (le:expr (+ 1 2))
[le][newlisp] (+ 1 2) -> 3
3
> ;; or showing itself
> (le:expr le)
[le][newlisp] MAIN:le -> [ctx] Logger_2, Logger_2:Logger_2 -> (Logger Logger_2 2 (lambda () "[le]") 0 0)
Logger_2
> ;; -> shows it being a context having a default Logger FOOP
> ;; (this is due to being a FOOPReference)
> ;;
> ;;
> ;; show properties of loggers l and le
> ;;
> (le:expr l) (le:expr le)
[le][newlisp] MAIN:l -> [ctx] Logger_1, Logger_1:Logger_1 -> (Logger Logger_1 2 (lambda () "") 0 0)
Logger_1
[le][newlisp] MAIN:le -> [ctx] Logger_2, Logger_2:Logger_2 -> (Logger Logger_2 2 (lambda () "[le]") 0 0)
Logger_2
> ;;
> ;;
> ;;
> ;; syms of minimal logger's FOOPReference
> ;;
> (symbols l)
(Logger_1:Logger_1 Logger_1:begin Logger_1:end Logger_1:error Logger_1:error-loc
Logger_1:fatal Logger_1:fatal-loc Logger_1:info Logger_1:info-loc Logger_1:level
Logger_1:level-all Logger_1:level-debug Logger_1:level-error Logger_1:level-fatal
Logger_1:level-info Logger_1:level-warn Logger_1:mixin-expr Logger_1:mixin-expr-debug
Logger_1:msg Logger_1:msg-loc Logger_1:warn Logger_1:warn-loc)
> ;;
> ;;
> ;; syms of extended logger's FOOPReference
> ;;
> (symbols le)
(Logger_2:Logger_2 Logger_2:a Logger_2:arguments Logger_2:begin Logger_2:default?
Logger_2:default_flag Logger_2:end Logger_2:error Logger_2:error-loc Logger_2:expr
Logger_2:expr-info-string Logger_2:expr-info-string-tloc Logger_2:expr-loc Logger_2:expr-loc-sep
Logger_2:expr-sep Logger_2:expr-str Logger_2:expr-str-sep Logger_2:fatal Logger_2:fatal-loc
Logger_2:info Logger_2:info-loc Logger_2:lastExprEval Logger_2:level Logger_2:level-all
Logger_2:level-debug Logger_2:level-error Logger_2:level-fatal Logger_2:level-info
Logger_2:level-warn Logger_2:loc Logger_2:locStrOrSym Logger_2:mixin-expr Logger_2:mixin-expr-debug
Logger_2:msg Logger_2:msg-loc Logger_2:name-rep Logger_2:nameReps Logger_2:rep Logger_2:restFlag
Logger_2:sepFlag Logger_2:sym_identical_flag Logger_2:symbol Logger_2:tloc Logger_2:tloc2string
Logger_2:warn Logger_2:warn-loc Logger_2:wrap)
> ;;
> ;;
> ;; *shared* FOOP part (used by *both* loggers)
> ;;
> (symbols Logger)
(Logger:Ctx Logger:FunSym Logger:Logger Logger:arguments Logger:begin Logger:breakFlag
Logger:c_errorStr Logger:c_fatalStr Logger:c_infoStr Logger:c_warningStr Logger:class
Logger:convenience-forward Logger:convenience-forward-first-rest Logger:ctx Logger:ctxSym
Logger:default Logger:delete-all-refs Logger:delete-ref Logger:delete-ref-ix Logger:end
Logger:error Logger:error-loc Logger:execPath Logger:expr Logger:extraPrefix Logger:fatal
Logger:fatal-loc Logger:fd Logger:foop Logger:foopCount Logger:fun Logger:get-level-default
Logger:h_warn-loc-string Logger:indent Logger:indent-string Logger:indentIncrement
Logger:info Logger:info-loc Logger:ix Logger:l Logger:level Logger:level-all Logger:level-debug
Logger:level-default Logger:level-error Logger:level-fatal Logger:level-info Logger:level-warn
Logger:level_all Logger:level_debug Logger:level_default Logger:level_error Logger:level_fatal
Logger:level_info Logger:level_warn Logger:locStrOrSym Logger:log-level Logger:msg
Logger:msg-format Logger:msg-loc Logger:n Logger:new-ref-context Logger:new-ref-context-sym
Logger:o Logger:opt_with_2_args Logger:opt_with_arg Logger:opt_without_arg Logger:prefix-loc-string
Logger:prefix-string Logger:prefixFun Logger:preprefix-func Logger:preprefix-string
Logger:ref-context-sym Logger:ref_context Logger:ref_contextSym Logger:ref_ctx Logger:reference
Logger:res Logger:s_class Logger:s_fd Logger:s_indent Logger:s_logLevel Logger:s_preprefixStr_func
Logger:s_ref Logger:scriptargs Logger:scriptargs_ Logger:scriptname Logger:scriptname_
Logger:scriptpath Logger:scriptpath-ix Logger:scriptpath_ Logger:scriptpath_ix Logger:set-fd
Logger:set-indent Logger:set-log-level Logger:set-preprefix-func Logger:set-preprefix_func
Logger:shebang? Logger:skip_next Logger:standard_constructor Logger:str Logger:to-string
Logger:use-debug-prefix Logger:use-no-prefix Logger:use-prefix-fun Logger:use-timestamp-prefix
Logger:warn Logger:warn-loc Logger:what Logger:wrap Logger:write-string)
> ;;
> ;;
> ;; mixin part (visible in syms of le)
> ;;
> (symbols LoggerExpr)
(LoggerExpr:a LoggerExpr:arguments LoggerExpr:default? LoggerExpr:default_flag LoggerExpr:expr
LoggerExpr:expr-info-string LoggerExpr:expr-info-string-tloc LoggerExpr:expr-loc
LoggerExpr:expr-loc-sep LoggerExpr:expr-sep LoggerExpr:expr-str LoggerExpr:expr-str-sep
LoggerExpr:lastExprEval LoggerExpr:loc LoggerExpr:locStrOrSym LoggerExpr:msg LoggerExpr:msg-loc
LoggerExpr:name-rep LoggerExpr:nameReps LoggerExpr:rep LoggerExpr:restFlag LoggerExpr:sepFlag
LoggerExpr:sym_identical_flag LoggerExpr:symbol LoggerExpr:tloc LoggerExpr:tloc2string
LoggerExpr:wrap)
>
Code Select
> ;;
> ;; *shared* FOOP part (used by *both* loggers)
> ;;
> (symbols Logger)
(Logger:Ctx Logger:FunSym Logger:Logger Logger:arguments Logger:begin Logger:breakFlag
Logger:c_errorStr Logger:c_fatalStr Logger:c_infoStr Logger:c_warningStr Logger:class
Logger:convenience-forward Logger:convenience-forward-first-rest Logger:ctx Logger:ctxSym
Logger:default Logger:delete-all-refs Logger:delete-ref Logger:delete-ref-ix Logger:end
Logger:error Logger:error-loc Logger:execPath Logger:expr Logger:extraPrefix Logger:fatal
Logger:fatal-loc Logger:fd Logger:foop Logger:foopCount Logger:fun Logger:get-level-default
Logger:h_warn-loc-string Logger:indent Logger:indent-string Logger:indentIncrement
Logger:info Logger:info-loc Logger:ix Logger:l Logger:level Logger:level-all Logger:level-debug
Logger:level-default Logger:level-error Logger:level-fatal Logger:level-info Logger:level-warn
Logger:level_all Logger:level_debug Logger:level_default Logger:level_error Logger:level_fatal
Logger:level_info Logger:level_warn Logger:locStrOrSym Logger:log-level Logger:msg
Logger:msg-format Logger:msg-loc Logger:n Logger:new-ref-context Logger:new-ref-context-sym
Logger:o Logger:opt_with_2_args Logger:opt_with_arg Logger:opt_without_arg Logger:prefix-loc-string
Logger:prefix-string Logger:prefixFun Logger:preprefix-func Logger:preprefix-string
Logger:ref-context-sym Logger:ref_context Logger:ref_contextSym Logger:ref_ctx Logger:reference
Logger:res Logger:s_class Logger:s_fd Logger:s_indent Logger:s_logLevel Logger:s_preprefixStr_func
Logger:s_ref Logger:scriptargs Logger:scriptargs_ Logger:scriptname Logger:scriptname_
Logger:scriptpath Logger:scriptpath-ix Logger:scriptpath_ Logger:scriptpath_ix Logger:set-fd
Logger:set-indent Logger:set-log-level Logger:set-preprefix-func Logger:set-preprefix_func
Logger:shebang? Logger:skip_next Logger:standard_constructor Logger:str Logger:to-string
Logger:use-debug-prefix Logger:use-no-prefix Logger:use-prefix-fun Logger:use-timestamp-prefix
Logger:warn Logger:warn-loc Logger:what Logger:wrap Logger:write-string)
> ;;
Code Select
> ;;
> ;; show properties of loggers l and le
> ;;
> (le:expr l) (le:expr le)
[le][newlisp] MAIN:l -> [ctx] Logger_1, Logger_1:Logger_1 -> (Logger Logger_1 2 (lambda () "") 0 0)
Logger_1
[le][newlisp] MAIN:le -> [ctx] Logger_2, Logger_2:Logger_2 -> (Logger Logger_2 2 (lambda () "[le]") 0 0)
Logger_2
> ;;
Code Select
;;
;; FOOPReference template
;;
(context 'FOOPReference)
;; indices of elems in FOOP list
(constant 's_class 0 's_ref 1)
;; helpers
(define (ref-context-sym ix)
(sym (string (context) "_" ix) MAIN))
(define (new-ref-context-sym)
(ref-context-sym (++ foopCount))) ; foopCount for identifying FR instances
(define (new-ref-context)
(let (ref_contextSym (new-ref-context-sym))
(prefix (sym ref_contextSym ref_contextSym)))); without switching to new ctx
;; standard functor: each call increases foopCount
(define (FOOPReference:FOOPReference)
(letn ((ref_context (new-ref-context)) ; increments foopCount
(foop (cons (context) (cons ref_context (args)))))
(set (sym (string ref_context) ref_context) foop) ; set ref context default
ref_context))
;; accessors
(define (class) ; FOOP Class
(self s_class))
(define (reference) ; FOOP reference context
(self s_ref))
;; cleaners
(define (delete-ref ctxSym)
(delete ctxSym) ; syms in context including foop default
(delete ctxSym)) ; context in MAIN
(define (delete-ref-ix ix)
(delete-ref (ref-context-sym ix)))
(define (delete-all-refs) ; robust against missing refs/foops already deleted
(while (> foopCount 0)
(delete-ref-ix foopCount)
(-- foopCount)))
(context MAIN)
;;
;; How to use FOOPReference template for own FOOP
;;
(new FOOPReference 'MyFoop)
(context MyFoop)
;; some getter/setter: indices for data starting with 2
(define (g1 a) (self 2)) (define (g2 a) (self 3))
(define (s1 a) (setq (self 2) a)) (define (s2 a) (setq (self 3) a))
(context MAIN)
;;
;; a func modifying aFoop call-by-ref argument; so in effect for caller, too
(define (mod-foop-arg aFoop)
(:s1 aFoop (append (:g1 aFoop) " -> modified by mod-foop-arg")))
Code Select
sr@free:~/newLISP/Examples$ newlisp FOOPReferences_code.lsp
newLISP v.10.6.4 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
> (set 'foop (MyFoop "one" "two"))
MyFoop_1
> (default foop)
(MyFoop MyFoop_1 "one" "two")
> (mod-foop-arg foop) ; change foop given as arg to func by func
"one -> modified by mod-foop-arg"
> (default foop)
(MyFoop MyFoop_1 "one -> modified by mod-foop-arg" "two")
> (set 'foop (MyFoop "first" "second"))
MyFoop_2
> (default foop)
(MyFoop MyFoop_2 "first" "second")
> (default MyFoop_1) (default MyFoop_2)
(MyFoop MyFoop_1 "one -> modified by mod-foop-arg" "two")
(MyFoop MyFoop_2 "first" "second")
> (MyFoop:delete-all-refs)
0
> foop MyFoop_1 MyFoop_2 ; check all references
nil
nil
nil
> ; -> all gone
Code Select
sr@free:~/newLISP/Examples$ newlisp FOOPRefs.lsp
F 1 functor
foop before modifying: (F "one" "two")
foop after modifying: (F "one -> modified by fun-mod-foop" "two")
F 2 functor
foop before modifying as arg: (F "one" "two")
aFoop arg (modified): (F "one -> modified by fun-mod-foop-arg" "two")
foop after modifying as arg: (F "one" "two")
-> does not work (call by value)
FR 1 functor
foop before modifying as ref arg: FR_1,
(default foop): (FR FR_1 "one" "two")
aFoop arg (modified): FR_1,
(default aFoop): (FR FR_1 "one -> modified by fun-mod-foop-arg" "two")
foop after modifying as ref arg: FR_1,
(default foop): (FR FR_1 "one -> modified by fun-mod-foop-arg" "two")
-> does work (call by ref)
(symbols F):
(F:F F:foopCount F:g1 F:g2 F:s1 F:s2)
(symbols FR):
(FR:FR FR:a FR:foop FR:g1 FR:g2 FR:id FR:ref_context FR:ref_contextStr
FR:ref_contextSym FR:ref_functorSym FR:s1 FR:s2)
(symbols FR_1):
(FR_1:FR_1)
newLISP v.10.6.4 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
>
I've made the mistake:
Newcomers to the state machine formalism often confusestate diagramswith flowcharts.
; taken from
https://en.wikipedia.org/wiki/State_diagram#State_diagrams_versus_flowcharts"> https://en.wikipedia.org/wiki/State_dia ... flowcharts">https://en.wikipedia.org/wiki/State_diagram#State_diagrams_versus_flowcharts
.
Therefrom I've come to the conclusion, that it's better to rename SM (state machine) to FM (flow(chart) machine): nodes in graph (b) from wikipedia link just given - including the decision, which node 'do Y' or 'do Z' will be entered after node 'do X' - are roughly the ones modeled in usecase below.
'Roughly', because a node in FM (wrongly named SM) below may advance-todifferentnodes dependent on its computation (like the decision in graph (b) extended to branch to more successors (and optionally to do some computation itself)).
After updating terminology (at first in software) a further update will follow as a newtopicpost.
To avoid confusion about State Machine terminology: I've looked into
https://en.wikipedia.org/wiki/Finite-state_machine#Concepts_and_terminology"> https://en.wikipedia.org/wiki/Finite-st ... erminology">https://en.wikipedia.org/wiki/Finite-state_machine#Concepts_and_terminology
: simple SM in usecase belowis not an SM in the strict sense of definition there.
In usecase below
[*]a state handler
[*]activelylooks for data and conditions in its environment - input or other things -,
[*]does some computation, and
[*]decidesitselfabout the transition to the next state; [/list] [*]the simple SM just maps the id of a state to a function to be evaluated;[*]both together will be combined in a loop - currently outside simple SM only (but this will be changed later).[/list]
Thisactivebehavior of states stems from transforming parts of an existing program into named states mapped to functions; and is non-standard.
Any ideas for a better naming? Program Flow State Machine? Or totally different with not using the term 'SM' at all'?
But it feels like being an SM in a more general sense...
Code Select
(:advance sm_1 "start")
;; and:
(:advance sm_2 "start")
Code Select
;; could be the same for both state machines:
(define (handle_START sm) ; ref arg to update state at caller, too
(:advance sm "check_preconditions"))
(define (handle_notImplemented sm)
(error "not implemented")
(exit 1))
;; sm_1 may map state "check_preconditions" to:
(define (handle_check_preconditions_1 sm)
... ; do some checking
(:advance sm "doSomeWork"))
;; the other one to handle_notImplemented above
Code Select
(define (eval-curr-func)
((eval (curr-func-sym)) (self 1)))
Code Select
(set (sym "advance" ref_context)
(lambda (next) (:advance (context) next)))
Code Select
(:advance sm "do_cond")
Code Select
(sm:advance "do_cond")
Code Select sr@free:~/newLISP$ newlisp
newLISP v.10.6.4 64-bit on Linux IPv4/6 UTF-8 libffi, options: newlisp -h
> (macro (double X) (+ X X))
(lambda-macro (X) (expand '(+ X X)))
> (define double (lambda-macro (X) (expand '(add X X))))
ERR: symbol is protected in function define : double
>