Menu

Show posts

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.

Show posts Menu

Messages - hartrock

Pages 1 2 3 4 5 6 ... 10
#46
Anything else we might add? / FOOP references: advantages and disadvantages
August 27, 2015, 08:32:41 PM


[*] FOOP related:
 

     
[*] reuse of FOOP funcs, instead of using bloated mixed-in contexts;
 
  • [*] polymorphism;

    •   [/list]
  • [*] context related: state change transfer of FOOP from callee to caller by call parameter, without the need to share a var located somewhere outside callees func definition;

  • [*] both together: selected API funcs for direct access as part of FOOP's reference context, to have a separation of API and other code.
    • [/list]


    [*] FOOP references are polluting MAIN namespace;
  • [*] no automated garbage collection of FOOP reference contexts (but it's no problem to provide a delete method - e.g. as part of FOOPReference class, which has created them - iterating over all ref context instances easing this);

  • [*] call-by-ref has problems, which call-by-value does not have.
    • [/list]

    Convenience funcs for calling FOOPs like contexts - this is related to the previous point - can be helpful (e.g. for transparently having the same API after switching from a single context to FOOPReferences).[/list]
    #47
    Anything else we might add? / FOOPReference usecase: multiple loggers
    August 27, 2015, 08:55:22 AM

  • [*] Introduction to multiple loggers usecase

  • [*] Modules needed

  • [*] Session

  • [*] Explanation and interpretation of some session results

  • [*] What do you think?
    • [/list]
    If you want to skip the details, you may directly jump to 'Interpretation of some session results'.



    publishing for reuse[/i] by others (this is not intended here).



    Util.lsp :
    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)

    FOOPReference.lsp :
    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)

    Logger.lsp :
    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



    ;; loading modules:
    (map load '("Util.lsp" "FOOPReference.lsp" "Logger.lsp"))
    ;;
    (set 'l (Logger))
    (global 'l) ; for being visible in contexts loaded later
    ;;
    (l:info "an info") (l:warn "a warning") (l:error "an error") (l:fatal "a fatal condition")
    ;; but:
    (l:msg "a message needing level-debug")
    (l:level-debug)  ; (default is level-info)
    (l:msg "a message needing level-debug")
    ;;
    ;;
    ;; There are more features by mixing-in some additional functionality:
    ;;
    (set 'le (Logger 2 (fn () "[le]") Logger:level_all)) ; stderr, preprefix fun
    (global 'le) ; for being visible in contexts loaded later
    (le:info "an info")
    ;; now let's mixin
    (le:mixin-expr)
    ;; now this works:
    (le:expr (+ 1 2))
    ;; or showing itself
    (le:expr le)
    ;; -> 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)
    ;;
    ;;
    ;;
    ;; syms of minimal logger's FOOPReference
    ;;
    (symbols l)
    ;;
    ;;
    ;; syms of extended logger's FOOPReference
    ;;
    (symbols le)
    ;;
    ;;
    ;; *shared* FOOP part (used by *both* loggers)
    ;;
    (symbols Logger)
    ;;
    ;;
    ;; mixin part (visible in syms of le)
    ;;
    (symbols LoggerExpr)
    [/code]
    Session as a whole (by copy/paste session commands):
    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)
    >



    > ;; 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)
    > ;;
    [/code]
    Note: many of these functions are convenience forwards from FOOPReference to FOOP; e.g. from (l:warn "a warning") to (:warn l "a warning").



    Symbols of shared FOOP part (code used by both loggers):
    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)
    > ;;


    Here the difference in amount of minimal logger's FOOPReference symbols and its shared (with other loggers like le in the example) FOOP symbols is obvious.



    If there are multiple loggers - e.g. by logging to different file descriptors or with different functionality -, sharing the FOOP code becomes effective.



    This shared FOOP code will be applied to the FOOPs of loggers l and le:
    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
    > ;;
    ; whose FOOPs are shown after last '->' in output line as '(Logger Logger_...'.



    [size=150]What do you think?[/size]
    #48
    Anything else we might add? / FOOPReference template
    August 20, 2015, 05:45:33 PM
    After loading this code:
    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")))
    ; there has been the following session:
    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

    This technique can be used for multiple FOOPReference classes like MyFoop in the example; each getting its own FOOP reference namespace (e.g. FirstFOOP_1, FirstFOOP_2, ...; SecondFOOP_1, SecondFOOP_2, ...) and its own delete-* funcs (only deleting its own references).
    #49
    Anything else we might add? / Re: FOOP references
    August 18, 2015, 04:35:49 PM
    Hello Ralph,

    thanks for your feedback.
    Quote from: "ralph.ronnquist"Except, maybe, the random thought that with some huffing and puffing becomes the question of: why keep the state(s) of state machine(s) together with their process models? Or: who needs recursion?

    cond[/b] just switching according current state (further using these states in an informational manner (good to log transitions)), and so to reduce the amount and depth of nested conditions. Here it has started to put these states together in an informational-only SM, to bundle states (good for modeling), check and track transitions (with statistics, how often some state has been reached).



    Now I'm refactoring another part of the code with a fuller featured SM really having mappings of states to functions doing corresponding stuff. This is the second one, and compatible with the former. Because I've seen, that more than one SMs makes sense here, I've come to FOOP references: references to a few SMs, sharing their code as FOOPs.



    From all above there is the important design goal, to support such refactoring of code from non-SM to SM code: simple things should stay simple, with more and more capabilities added as needed. During refactoring a mixture of SM and no-SM code should remain possible (and it is, as it is running now), to support an evolutionary path to more and more better structured SM code.



    Current SM is a simple one compared with ones having enter/exit or more functions per state: currently it's just one (or none, if just informational) function per state, triggering its transition to the next one (which may also be triggered outside this mechanism like in above cond loop outside SM, where each part of the cond sets its next state). It grows with my usecase and during refactoring its code (have just started to introduce a SM_StateState Class, which bundles information belonging to a state during inside it (result of its func evaluation, reached by a func evalution from a previous state or triggered from the outside, etc.).

    You see this is work in progress, and I'm going a pragmatical way with strong influence from praxis (the webservice provides a service used for testing other stuff, which is a very good test case while changing its code (and transforming it into SMs)).



    I don't really understand your question:
    Quote from: "ralph.ronnquist"why keep the state(s) of state machine(s) together with their process models?
     (probably therefore I had to read something more about SMs); but hopefully my explanations help to understand, what I'm trying to reach (and what not).



    PS: Please note [Update 2] above, describing how used simple SM differs from standard SMs.

    PPS: Please also note [Update 3], describing that simple SM above just is not an SM, but an FM (to give it a better name)... Thanks to your question, which finally has led to this error correction!
    #50
    Anything else we might add? / FOOP references [update 4]
    August 16, 2015, 10:24:54 AM
    After some experimenting with interesting and helpful error messages - about 'protected container of (self)' - I've come to the following technique of using FOOP references; combining features of FOOPs with (additional) contexts used as shared references to them.



    Note: this is advanced and new (at least for me) stuff, so you have been warned ;-)




    (define (F:F) ; same as (new Class 'F), but with informational output
      (++ F:foopCount)
      (println "nF " F:foopCount " functor")
      (cons (context) (args)))
    ;; some getter/setter
    (define (F:g1 a) (self 1))          (define (F:g2 a) (self 2))
    (define (F:s1 a) (setq (self 1) a)) (define (F:s2 a) (setq (self 2) a))
    ;;
    (define (fun-mod-foop)
      (:s1 foop (append (:g1 foop) " -> modified by fun-mod-foop")))
    ;;
    ;; work with a foop
    (set 'foop (F "one" "two"))
    (println "foop before modifying: "foop)
    (fun-mod-foop)
    (println "foop after modifying: "foop)
    ;;
    ;;
    (define (fun-mod-foop-arg aFoop)
      (:s1 aFoop (append (:g1 aFoop) " -> modified by fun-mod-foop-arg"))
      (if (context? aFoop)
          (println "aFoop arg (modified): " aFoop
                   ",n  (default aFoop): " (default aFoop))
          (println "aFoop arg (modified): " aFoop)))
    ;;
    ;; work with a foop
    (set 'foop (F "one" "two"))
    (println "foop before modifying as arg: " foop)
    (fun-mod-foop-arg foop)
    (println "foop after modifying as arg: " foop
             "n-> does not work (call by value)")
    ;;
    ;;
    ;; FOOP references
    ;;
    (context 'FR)
    (define (FR:FR)
      (++ id)
      (println "nFR " id " functor")
      (letn ((ref_contextStr (string "FR_" id))
             (ref_contextSym (sym ref_contextStr MAIN))
             (ref_context (context ref_contextSym))
             (ref_functorSym (sym ref_contextStr ref_context)))
        (set 'foop (append (list MAIN:FR ref_context) (args)))
        (set ref_functorSym foop)
        ref_context))
    ;; some getter/setter (ix incremented by one, because of storing ref at 1)
    (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)
    ;; work with a foop reference
    (set 'foop (FR "one" "two"))
    (println "foop before modifying as ref arg: " foop
             ",n  (default foop): " (default foop))
    (fun-mod-foop-arg foop)
    (println "foop after modifying as ref arg: " foop
             ",n  (default foop): " (default foop))
    (println "-> does work (call by ref)")
    (println "n(symbols F):n  " (symbols F) "n(symbols FR):n  " (symbols FR) "n(symbols FR_1):n  " (symbols FR_1))
    [/code]
    , results into:
    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

    >


    multiple[/i] state machines modeled as FOOPs, which are given as argument to functions changing their state.





    There is a switch to a better usecase - easier to understand and more to the point of illustrating the usefulness of FOOPReferences -, see
    [*] http://www.newlispfanclub.alh.net/forum/viewtopic.php?f=5&t=4746">//http://www.newlispfanclub.alh.net/forum/viewtopic.php?f=5&t=4746[/list]
    PS: Sometime there may be some code regarding FM (flow machine) mentioned below (but this would be another topic).



    [Update 3]:
    Quote from: "[Update 3"]
    I've made the mistake:
    Quote
    Newcomers to the state machine formalism often confuse state diagrams with 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-to different nodes 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 new topic post.

    [Update 2]:
    Quote from: "[Update 2"]
    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 below is not an SM in the strict sense of definition there.



    In usecase below

    [*] a state handler

       
    [*] actively looks for data and conditions in its environment - input or other things -,
     
  • [*] does some computation, and

    •  
  • [*] decides itself about 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]
    This active behavior 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...


    A simple (please note [Update 2]) state machine (pseudo code)]
    (set 'sm_1 (SM))
    (:add-states sm_1 '(
      ("start"               handle_START ...)
      ("check_preconditions" handle_check_preconditions_1 ...)
      ...))
    (set 'sm_2 (SM))
    (:add-states sm_2 '(
      ("start"               handle_START ...)
      ("check_preconditions" handle_notImplemented ...)
      ...))
    [/code]
    Somewhere there is:
    Code Select

    (:advance sm_1 "start")
    ;; and:
    (:advance sm_2 "start")
    setting state to "start" for getting it started.



    Current state like "start" or "check_preconditions" is stored as element in SM's FOOP; then there may be:
    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

    For actively changing current state of state machine these handler_* funcs need access to the SM calling them: besides of advancing to the next state, this may be manipulating some data - e.g. for sharing it between states - stored inside SM, or changing SM's behavior.

    Note: passively changing state of SM may also be modeled by returning some value containing at least next state (and potentially more data).



    For sharing a handler between multiple SMs, it is helpful to have calling SM as a call parameter.

    [Update 1] Valid for active handlers: for passive ones there is no need for referencing the caller.



    Caller of handle_* funcs is state machine FOOP: to give a reference to it as call parameter, it is needed to keep FOOP reference as part of FOOP itself; e.g. part of FOOP Class code is:
    Code Select

    (define (eval-curr-func)
      ((eval (curr-func-sym)) (self 1)))

    ; where (curr-func-sym) is something like handle_start, and (self 1) refers to FOOP's reference context (besides of (self 0) referring to its well known Class context).



    As an addition it's possible to use FOOP's reference context directly by forwarding referenced FOOP calls:
    Code Select

    (set (sym "advance" ref_context)
         (lambda (next) (:advance (context) next)))
    ; which allows to replace:
    Code Select

    (:advance sm "do_cond")
    by:
    Code Select

    (sm:advance "do_cond")

    This makes sense for both

    [*] to have a selection of API funcs without direct access to non-API ones, or
  • [*] forwarding all funcs, with having the working part of the code at FOOP's Class (for sharing).
    • [/list]
    Contexts with mixed-in working funcs doing all the work are no alternative to referenced FOOPs here.





    [*] context related]     FOOP related:

       
    [*] reuse of FOOP Class funcs, instead of using bloated mixed-in contexts;
     
  • [*] polymorphism;
    • [/list]
  • [*] both together: selected API funcs for direct access as part of FOOP's reference context, to have a separation of API and other code.
    • [/list]


    [*] FOOP references are polluting MAIN namespace;
  • [*] no automated garbage collection of FOOP reference contexts (but there may be a delete method - e.g. as part of FOOP Class, which has created them - iterating over all ref context instances easing this);

  • [*] call-by-ref has problems, which call-by-value does not have.
    • [/list]



    This post may be updated, because things may be seen in a different light later (still during writing this post usecase SM code has been improved...).
    #51
    Anything else we might add? / Re: add function defined?
    August 14, 2015, 01:41:09 AM
    Just started with using emacros (expansion macros) here a simple solution (with limitations):
    Code Select
    > (macro (defined? V) (sym V (context) nil))
    (lambda-macro (V) (expand '(sym V (context) nil)))
    > (defined? "var")
    nil
    > var
    nil
    > (defined? "var")
    var
    > ; but:
    > (defined? "V")
    V
    > ; -> because it is used as symbol by the macro
    > (defined? 'v2)
    v2
    > ; -> because it is defined *before* calling defined?
    A more general variant would allow to choose another as the current and/or all contexts to search for the sym (using at least one more emacro parameter variable then).

    A naming convention for such general-purpose emacros could be, to only use one-letter parameter names for such emacros:

    [*] this avoids confusion with contexts, which may be named starting uppercase, too (but are usually multi-letter); and
  • [*] reduces sym pollution of MAIN context to a minimum.
    • [/list]
    Note: starting parameter names with uppercase is needed for emacros.
    #52
    Anything else we might add? / Re: add function defined?
    August 13, 2015, 03:45:26 PM
    Quote from: "ssqq"
    Code Select


    > (defined? 'var) ; --> nil
    > (set 'var nil)
    > (defined? 'var) ; --> true
    > (delete 'var)
    > (defined? 'var) ; --> nil


    This would not work, because using the symbol 'var defines it before calling the function defined?.



    But there is:
    Code Select

    > ;; check for var 'var
    > (sym "var" (context) nil)
    nil
    > ;; -> not there
    > ;; now define it:
    > var
    nil
    > ;; check
    > (sym "var" (context) nil)
    var
    > ;; -> now it exists
    >

    The flag nil in (sym "var" (context) nil) is important, since it suppresses creating the 'var symbol.
    #53
    newLISP in the real world / Re: [bug][10.6.4] expansion macro rewrite does not work
    August 13, 2015, 02:32:39 AM
    But it works with:
    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)))
    >  (constant 'double (lambda-macro (X) (expand '(add X X))))
    (lambda-macro (X) (expand '(add X X)))
    > double
    (lambda-macro (X) (expand '(add X X)))
    >

    So this seems to be a minor issue.



    PS: Is this the best place for such reports? Is it OK, to delete this post after a fix?
    #54
    newLISP in the real world / [bug][10.6.4] expansion macro rewrite fails -> workaround
    August 12, 2015, 06:47:29 PM
    Tried after User Manual and Reference v.10.6.4:
    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
    >
    #55
    newLISP in the real world / [fr] access to (main-args) ix of script just being executed
    August 11, 2015, 09:19:50 AM
    Currently there is the following for guessing, which could be the script currently being executed:
    Code Select

    (context sys)
    ;;
    ;; 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
    ;;   > (sys: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
    ;; iface
    (define (scriptpath-ix) ; needed for getopts below
      scriptpath_ix)
    (define (scriptargs) ; good as getopts arg
      ((++ (scriptpath-ix)) (main-args)))
    (define (scriptpath)
      (main-args scriptpath_ix))
    (define (scriptname) ; Linux (to be extended for other OSes)
      (last (parse (scriptpath) "/")))

    This approach replicates interpreter code and has serious limitations, because it is unknown, which given script is currently being executed after its interpreter load, if there are multiple args, which all could be scripts: e.g.

    - newlisp arg_1.lsp arg_2.lsp arg_3.lsp [options][/list]

    could mean

    - newlisp lib_1.lsp lib_2.lsp scriptOfInterest.lsp [options]

    or

    - newlisp lib_1.lsp scriptOfInterest.lsp scriptArg.lsp [options]

    .

    What about having a way to get the (main-args) index of last interpreter loaded and currently executed script?

    This would allow to get the best possible scriptname for more complicate cases than just having only one script directly after newlisp opts, which is helpful for a most general getopts module.

    It would also allow to do

    - newlisp scriptOfInterest_1.lsp scriptOfInterest_2.lsp

    and give different (scriptname)s - for e.g. err messages - then (without setting them explicitely by the scripts themselves).
    #56
    newLISP in the real world / Re: case different from cond; doesn't allow "default"
    August 09, 2015, 08:52:23 PM
    This works (from the manual):
    Code Select
    (define (translate n)
      (case n
        (1 "one")
        (2 "two")          
        (3 "three")
        (4 "four")
        (true "Can't translate this")))

    or this (good to use for error messages, if an unexpected condition occurs):
    Code Select

    (define (translate n)
      (cond
       ((= n 1) "one")
       ((= n 2) "two")          
       ((= n 3) "three")
       ((= n 4) "four")
       ("default" "Can't translate this")))
    #57
    newLISP in the real world / Re: 'choice pop' for choosing FIFO semantics after standard
    August 09, 2015, 08:21:54 PM
    Here is another patch against newlisp-10.6.4.tgz  2015-08-09 16:32 :
    Code Select

    diff --git a/newlisp.c b/newlisp.c
    index 55ff89b..117d27d 100644
    --- a/newlisp.c
    +++ b/newlisp.c
    @@ -2151,6 +2151,35 @@ if(offset < 0)
     return(offset);
     }
     
    +void listPrelastLast(CELL * list, CELL ** pPrelast, CELL ** pLast)
    +{
    +CELL * prelast = nilCell;
    +CELL * last = nilCell;
    +
    +while(list != nilCell)
    +    {
    +    prelast = last;
    +    last = list;
    +    list = list->next;
    +    }
    +
    +if (pPrelast) *pPrelast = prelast;
    +if (pLast) *pLast = last;
    +}
    +
    +void listLast(CELL * list, CELL ** pLast)
    +{
    +CELL * last = nilCell;
    +
    +while(list != nilCell)
    +    {
    +    last = list;
    +    list = list->next;
    +    }
    +
    +if (pLast) *pLast = last;
    +}
    +
     /* ------------------------ creating and freeing cells ------------------- */
     
     CELL * getCell(int type)
    diff --git a/nl-list.c b/nl-list.c
    index 9ce174e..43880a9 100644
    --- a/nl-list.c
    +++ b/nl-list.c
    @@ -1047,11 +1047,23 @@ while(isList(list->type))
         else
             {
             list = (CELL *)list->contents;
    +#if 0
             if(index < 0)
                 index = convertNegativeOffset(index, list);
     
             while(index--)  list = list->next;
    -
    +#else
    +        if(index == -1)
    +            {
    +            listLast(list, &list);
    +            }
    +        else
    +            {
    +            if(index < 0)
    +                index = convertNegativeOffset(index, list);
    +            while(index--)  list = list->next;
    +            }
    +#endif
             if(list == nilCell)
                 errorProc(ERR_LIST_INDEX_INVALID);
             }
    diff --git a/nl-liststr.c b/nl-liststr.c
    index 2253402..ada32cb 100644
    --- a/nl-liststr.c
    +++ b/nl-liststr.c
    @@ -618,9 +618,14 @@ else
     /* pop with index */
     while(isList(list->type))
         {
    +#if 0
         cell = envelope = list;
    +#else
    +    envelope = list;
    +#endif
         list = (CELL *)list->contents;
     
    +#if 0
         if(index < 0) index = convertNegativeOffset(index, list);
     
         while(index--)
    @@ -628,6 +633,19 @@ while(isList(list->type))
             cell = list;
             list = list->next;
             }
    +#else
    +    if(index == -1)
    +        listPrelastLast(list, &cell, &list);
    +    else
    +        {
    +        if(index < 0) index = convertNegativeOffset(index, list);
    +        while(index--)
    +            {
    +            cell = list;
    +            list = list->next;
    +            }
    +        }
    +#endif
         if(list == nilCell)
             errorProc(ERR_LIST_INDEX_INVALID);
     
    @@ -637,14 +655,23 @@ while(isList(list->type))
     
     if(list->next == nilCell) /* last cell is popped */
         {
    +#if 0
         if(list == (CELL*)cell->contents) /* last is also first cell */
    +#else
    +    if(list == (CELL*)envelope->contents) /* also first cell */
    +#endif
             envelope->aux = (UINT)nilCell;        
         else
             envelope->aux = (UINT)cell; /* cell is previous to last popped */
         }
     
    +#if 0
     if(list == (CELL*)cell->contents)
         cell->contents = (UINT)list->next;
    +#else
    +if(list == (CELL*)envelope->contents)
    +    envelope->contents = (UINT)list->next;
    +#endif
     else
         cell->next = list->next;
     
    diff --git a/protos.h b/protos.h
    index 5fd06d8..b835e46 100644
    --- a/protos.h
    +++ b/protos.h
    @@ -598,6 +598,8 @@ int win_fprintf(FILE * fPtr, char * dummy, char * buffer);
     int writeFile(char * fileName, char * buffer, size_t size, char * type);
     size_t listlen(CELL * listHead);
     ssize_t convertNegativeOffset(ssize_t offset, CELL * list);
    +void listPrelastLast(CELL * list, CELL ** pPrelast, CELL ** pLast);
    +void listLast(CELL * list, CELL ** pLast);
     ssize_t readFile(char * fileName, char * * buffer);
     unsigned int asciiIPtoLong(char *ptr);
     unsigned int update_crc(unsigned int crc, unsigned char *buf, int len);

    It gives some performance improvements for poping back from long lists.



    Before:
    Code Select

    > ;; from longer to shorter lists
    > ;;
    > (set 'lt (sequence 1 10000) 'num 100000)
    100000
    > ;; LIFO non-standard
    > (begin (set 'l lt) (time (begin (push 22 l -1) (em-cpop l -1) ) num))
    6723.186
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 22 l -1) ) num))
    6835.562
    > ;; FIFO by em-cpop
    > (begin (set 'l lt) (time (begin (push 0  l)    (em-cpop l -1) ) num))
    6759.411
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 0  l)    ) num))
    6756.627
    > ;;
    > (set 'lt (sequence 1 1000) 'num 1000000)
    1000000
    > ;; LIFO non-standard
    > (begin (set 'l lt) (time (begin (push 22 l -1) (em-cpop l -1) ) num))
    4759.021
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 22 l -1) ) num))
    5162.605
    > ;; FIFO by em-cpop
    > (begin (set 'l lt) (time (begin (push 0  l)    (em-cpop l -1) ) num))
    4787.38
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 0  l)    ) num))
    5207.72
    > ;;
    > (set 'lt (sequence 1 10) 'num 10000000)
    10000000
    > ;; LIFO non-standard
    > (begin (set 'l lt) (time (begin (push 22 l -1) (em-cpop l -1) ) num))
    2219.848
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 22 l -1) ) num))
    2177.663
    > ;; FIFO by em-cpop
    > (begin (set 'l lt) (time (begin (push 0  l)    (em-cpop l -1) ) num))
    2233.914
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 0  l)    ) num))
    2137.999
    > ;;
    > (set 'lt (sequence 1 2) 'num 10000000)
    10000000
    > ;; LIFO non-standard
    > (begin (set 'l lt) (time (begin (push 22 l -1) (em-cpop l -1) ) num))
    2074.409
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 22 l -1) ) num))
    1998.884
    > ;; FIFO by em-cpop
    > (begin (set 'l lt) (time (begin (push 0  l)    (em-cpop l -1) ) num))
    1921.308
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 0  l)    ) num))
    1945.571
    >

    After:
    Code Select

    > ;; from longer to shorter lists
    > ;;
    > (set 'lt (sequence 1 10000) 'num 100000)
    100000
    > ;; LIFO non-standard
    > (begin (set 'l lt) (time (begin (push 22 l -1) (em-cpop l -1) ) num))
    3766.13
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 22 l -1) ) num))
    3746.027
    > ;; FIFO by em-cpop
    > (begin (set 'l lt) (time (begin (push 0  l)    (em-cpop l -1) ) num))
    3759.977
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 0  l)    ) num))
    3650.811
    > ;;
    > (set 'lt (sequence 1 1000) 'num 1000000)
    1000000
    > ;; LIFO non-standard
    > (begin (set 'l lt) (time (begin (push 22 l -1) (em-cpop l -1) ) num))
    3349.033
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 22 l -1) ) num))
    3411.04
    > ;; FIFO by em-cpop
    > (begin (set 'l lt) (time (begin (push 0  l)    (em-cpop l -1) ) num))
    3360.739
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 0  l)    ) num))
    3455.855
    > ;;
    > (set 'lt (sequence 1 10) 'num 10000000)
    10000000
    > ;; LIFO non-standard
    > (begin (set 'l lt) (time (begin (push 22 l -1) (em-cpop l -1) ) num))
    2046.184
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 22 l -1) ) num))
    1976.498
    > ;; FIFO by em-cpop
    > (begin (set 'l lt) (time (begin (push 0  l)    (em-cpop l -1) ) num))
    1958.404
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 0  l)    ) num))
    1975.241
    > ;;
    > (set 'lt (sequence 1 2) 'num 10000000)
    10000000
    > ;; LIFO non-standard
    > (begin (set 'l lt) (time (begin (push 22 l -1) (em-cpop l -1) ) num))
    1853.397
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 22 l -1) ) num))
    1995.456
    > ;; FIFO by em-cpop
    > (begin (set 'l lt) (time (begin (push 0  l)    (em-cpop l -1) ) num))
    1747.217
    > (begin (set 'l lt) (time (begin (em-cpop l -1) (push 0  l)    ) num))
    1871.158
    >


    Quote from: "Lutz"... although the change is small, it still needs a lot of testing.

    This is true indeed: I've made some errors during creating this patch, and detected them at interesting places by running some tests (yours and mines).
    #58
    newLISP in the real world / Re: 'choice pop' for choosing FIFO semantics after standard
    August 07, 2015, 03:17:53 PM
    Quote from: "Lutz"pop with index undoes last element optimization

    Here is a patch, which undoes last element optimization only if needed (against newlisp-10.6.4.tgz  2015-08-05 16:18):
    Code Select

    diff --git a/mirror/nl-liststr.c b/mirror/nl-liststr.c
    index a601cdd..427f7d7 100644
    --- a/mirror/nl-liststr.c
    +++ b/mirror/nl-liststr.c
    @@ -574,6 +574,7 @@ CELL * list;
     CELL * cell = NULL;
     ssize_t index;
     int evalFlag = FALSE;
    +CELL * outerCell;
     
     params = getEvalDefault(params, &list);
     if(symbolCheck && isProtected(symbolCheck->flags))
    @@ -616,7 +617,9 @@ else
     
     while(isList(list->type))
         {
    -    list->aux = (UINT)nilCell; /* undo last element optimization */
    +    outerCell = list; /* store it for setting aux below */
    +    /* replaced by code below */
    +    /* list->aux = (UINT)nilCell; */ /* undo last element optimization */
         cell = list;
         list = (CELL *)list->contents;
     
    @@ -634,6 +637,9 @@ while(isList(list->type))
         params = getIntegerExt(params, (UINT*)&index, evalFlag);
         }
     
    +/* only clear ->aux, if last cell will be pop'ed */
    +if(list->next == nilCell) outerCell->aux = (UINT)nilCell;
    +
     if(list == (CELL*)cell->contents)
         cell->contents = (UINT)list->next;
     else

    It shouldn't change semantics, but solves above issue:
    Code Select

    > ;; Wired removed...
    > ;
    > (set 'lt (sequence 1 1000) 'num 1000000)
    1000000
    > ;; LIFO standard
    > (begin (set 'l lt) (time (begin (push 0  l)    (pop l)        ) num))
    139.095
    > ;; LIFO standard (with explicit pop ix)
    > (begin (set 'l lt) (time (begin (push 0  l)    (pop l 0)      ) num))
    147.966
    > ;
    > ;; FIFO by push
    > (begin (set 'l lt) (time (begin (push 22 l -1) (pop l)        ) num))
    144.976
    > ;; FIFO by push (with explicit pop ix)
    > (begin (set 'l lt) (time (begin (push 22 l -1) (pop l 0)      ) num))
    155.653
    >

    Note: no guarantees!

    'make testall' gives no failure; but I don't know, if my mental model about the inner workings of the interpreter is correct.



    With the patch (if it's correct) all push-backs after ix poping any, but not the last element, should be faster.



    PS (update): I've been somewhat irritated by about doubling all fast times against earlier tests. Reason is another host used for the patch. Switching back to the inprogress version without patch, they are doubled, too (against tests in earlier posts with the other host):
    Code Select
    > ;; Wired...
    > ;
    > (set 'lt (sequence 1 1000) 'num 1000000)
    1000000
    > ;; LIFO standard
    > (begin (set 'l lt) (time (begin (push 0  l)    (pop l)        ) num))
    136.833
    > ;; LIFO standard (with explicit pop ix)
    > (begin (set 'l lt) (time (begin (push 0  l)    (pop l 0)      ) num))
    144.943
    > ;
    > ;; FIFO by push
    > (begin (set 'l lt) (time (begin (push 22 l -1) (pop l)        ) num))
    145.575
    > ;; FIFO by push (with explicit pop ix)
    > (begin (set 'l lt) (time (begin (push 22 l -1) (pop l 0)      ) num))
    3112.816
    >
    #59
    newLISP in the real world / Re: 'choice pop' for choosing FIFO semantics after standard
    August 07, 2015, 07:04:42 AM
    Thanks for the hints.




    ;; best in functionality
    (context 'cpop)
    (define-macro (cpop:cpop l (ix 0))
      (if (eval l)
          (pop (eval l) (eval ix)))) ; returns empty list, if empty list
    (context MAIN)

    ;; this has limitations, but should be faster
    (macro (em-cpop L (Ix 0)) ; emacro: expansion macro
      (if L
          (pop L Ix))) ; returns empty list, if empty list
    [/code]


    > (set 'lt (sequence 1 10) 'num 1000000)
    1000000
    > ;;
    > ;; Note: (pop l -1) would fail for an empty list (l always contains elemennts here).
    > ;; LIFO standard
    > (begin (set 'l lt) (time (begin (push 0  l)    (pop l)        ) num))
    61.152
    > (begin (set 'l lt) (time (begin (pop l)        (push 0  l)    ) num))
    58.211
    > ;; LIFO non-standard
    > (begin (set 'l lt) (time (begin (push 22 l -1) (pop l -1)     ) num))
    87.94
    > (begin (set 'l lt) (time (begin (pop l -1)     (push 22 l -1) ) num))
    87.211
    > ;; FIFO by push
    > (begin (set 'l lt) (time (begin (push 22 l -1) (pop l)        ) num))
    60.188
    > (begin (set 'l lt) (time (begin (pop l)        (push 22 l -1) ) num))
    60.357
    > ;; FIFO by pop
    > (begin (set 'l lt) (time (begin (push 0  l)    (pop l -1)     ) num))
    80.66
    > (begin (set 'l lt) (time (begin (pop l -1)     (push 0  l)    ) num))
    78.233
    > ;;
    [/code]
    Long queue:
    Code Select

    > ;;
    > (set 'lt (sequence 1 1000) 'num 1000000)
    1000000
    > ;;
    > ;; Note: (pop l -1) would fail for an empty list (l always contains elemennts here).
    > ;; LIFO standard
    > (begin (set 'l lt) (time (begin (push 0  l)    (pop l)        ) num))
    56.846
    > (begin (set 'l lt) (time (begin (pop l)        (push 0  l)    ) num))
    59.729
    > ;; LIFO non-standard
    > (begin (set 'l lt) (time (begin (push 22 l -1) (pop l -1)     ) num))
    3855.777
    > (begin (set 'l lt) (time (begin (pop l -1)     (push 22 l -1) ) num))
    3892.905
    > ;; FIFO by push
    > (begin (set 'l lt) (time (begin (push 22 l -1) (pop l)        ) num))
    60.436
    > (begin (set 'l lt) (time (begin (pop l)        (push 22 l -1) ) num))
    60.664
    > ;; FIFO by pop
    > (begin (set 'l lt) (time (begin (push 0  l)    (pop l -1)     ) num))
    2533.831
    > (begin (set 'l lt) (time (begin (pop l -1)     (push 0  l)    ) num))
    2538.82
    >

    Result of comparison between LIFO standard versus non-standard, and comparison between FIFO by push versus pop (optimized versus unoptimized cases):

    [*]short queue (about 10 elements): small difference,
  • [*]long queue (about 1000 elements): huge difference!
    • [/list]

    Let's stay with the long list, since it is the more critical case, and continue with em-cpop:
    Code Select

    > (set 'lt (sequence 1 1000) 'num 1000000)
    1000000
    > ;;
    > ;; Note: (em-cpop l -1) would also work for an empty list.
    > ;; LIFO standard
    > (begin (set 'l lt) (time (begin (push 0  l)    (em-cpop l)        ) num))
    93.721
    > (begin (set 'l lt) (time (begin (em-cpop l)        (push 0  l)    ) num))
    82.858
    > ;; LIFO non-standard
    > (begin (set 'l lt) (time (begin (push 22 l -1) (em-cpop l -1)     ) num))
    4329.809
    > (begin (set 'l lt) (time (begin (em-cpop l -1)     (push 22 l -1) ) num))
    3945.459
    > ;; FIFO by push
    > (begin (set 'l lt) (time (begin (push 22 l -1) (em-cpop l)        ) num))
    1616.678
    > (begin (set 'l lt) (time (begin (em-cpop l)        (push 22 l -1) ) num))
    1471.864
    > ;; FIFO by em-cpop
    > (begin (set 'l lt) (time (begin (push 0  l)    (em-cpop l -1)     ) num))
    2854.785
    > (begin (set 'l lt) (time (begin (em-cpop l -1)     (push 0  l)    ) num))
    2578.798
    >



    > ;; LIFO standard
    > (begin (set 'l lt) (time (begin (push 0  l)    (em-cpop l)        ) num))
    93.721
    [/code]

    Digging deeper back to push'n'pop; compare cases with or without explicitely given (unneeded and failing for empty lists) pop ix 0 (which will be used by em-cpop):
    Code Select

    > ;; FIFO by push
    > (begin (set 'l lt) (time (begin (push 22 l -1) (pop l)        ) num))
    73.90600000000001
    > ;; FIFO by push (with explicit pop ix)
    > (begin (set 'l lt) (time (begin (push 22 l -1) (pop l 0)        ) num))
    1463.805
    >
    -> here the explicit ix makes it slow,

    but:
    Code Select

    > ;; LIFO standard
    > (begin (set 'l lt) (time (begin (push 0  l)    (pop l)        ) num))
    71.03100000000001
    > ;; LIFO standard (with explicit pop ix)
    > (begin (set 'l lt) (time (begin (push 0  l)    (pop l 0)      ) num))
    66.854
    >
    -> here it doesn't hurt!



    Why this difference?
    #60
    newLISP in the real world / 'choice pop' for choosing FIFO semantics after standard push
    August 05, 2015, 04:09:21 PM
    cpop stands for 'choice' pop, where the cpop is able to choose, if a standard push without ix leads to FIFO semantics on cpops side.



    Currently only the push has this choice of switching from standard LIFO to FIFO semantics, by pushing back using -1 ix, which is working for an empty list: on the other side pop fails, if poping from an empty list with -1 ix.



    Here are two macros implementing cpop semantics:
    Code Select

    ;; best in functionality
    (context 'cpop)
    (define-macro (cpop:cpop l (ix 0))
      (if (not (empty? (eval l)))
          (pop (eval l) (eval ix)))) ; returns nil, if empty list
    (context MAIN)

    ;; this has limitations, but should be faster
    (macro (emacro-cpop L (Ix 0)) ; emacro: expansion macro
      (if (not (empty? L))
          (pop L Ix))) ; returns nil, if empty list

    After loading former code, there has been the following session to show its functionality:
    Code Select

    > ;;
    > ;; choices by push for standard pop
    > ;;
    > ; LIFO
    > (push 3 (push 2 (push 1 l)))    ; standard push leading to LIFO
    (3 2 1)
    > (pop l) (pop l) (pop l) (pop l) ; standard pop
    3
    2
    1
    nil
    > ;
    > ; FIFO:
    > (push 3 (push 2 (push 1 l -1) -1) -1) ; FIFO push
    (1 2 3)
    > (pop l) (pop l) (pop l) (pop l)       ; standard pop
    1
    2
    3
    nil
    > ;;
    > ;;
    > ;; choices by pop for standard push
    > ;;
    > ;; LIFO choice by pop here is the same as LIFO choice by push for standard pop above:
    > ;; both with standard push'n'pop.
    > ;
    > ; FIFO fails, if the list has become empty:
    > (push 3 (push 2 (push 1 l)))                ; standard push
    (3 2 1)
    > (pop l -1) (pop l -1) (pop l -1) (pop l -1) ; FIFO pop (failing)
    1
    2
    3

    ERR: invalid list index in function pop
    > ; -> this is the problem
    > ;
    > ; FIFO choice by cpop works:
    > (push 3 (push 2 (push 1 l)))                    ; standard push
    (3 2 1)
    > (cpop l -1) (cpop l -1) (cpop l -1) (cpop l -1) ; FIFO cpop (working)
    1
    2
    3
    nil
    >


    A difference between expansion and run-time macro:
    Code Select

    > ;; this shows a difference between the different macro types: expansion macro works in many cases:
    > (push 3 (push 2 (push 1 l)))
    (3 2 1)
    > (em-cpop l -1) (em-cpop l -1) (em-cpop l -1) (em-cpop l -1) ; (working)
    1
    2
    3
    nil
    > ;;
    > ; but not in all:
    > (push 3 (push 2 (push 1 l)))
    (3 2 1)
    > ((if true cpop "dummy") l -1)    ; -> run-time macro works
    1
    > ((if true em-cpop "dummy") l -1) ; -> expansion macro fails
    (if (not (empty? l))
     (pop l -1))
    >


    Extending pop by building in cpops FIFO semantics would only be a minor change in interpreter code: it only needs the addition of an empty? list check (so performance should be no problem).
    Pages 1 2 3 4 5 6 ... 10