diff --git a/README.md b/README.md index 320cff1..c154f82 100644 --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ -> **_NOTE:_** +> [!NOTE] > > _"files from provided paths"_ refers to `{.il, .ils, .scm}` files found using `find` on all paths provided as arguments (files or directories). > @@ -86,7 +96,7 @@ To enable the full SKILL# API inside Virtuoso, load the following command or pla (load (simplifyFilename "$SKILL_SHARP_ROOT/skill/loader.scm")) ``` -> **_NOTE:_** +> [!NOTE] > > Replace $SKILL_SHARP_ROOT with the path to this repository's root directory. @@ -120,7 +130,7 @@ SKILL# provides two ways to waive lint rules: (@no_lint (car (setof elt (list 1 2 3) (evenp elt)))) ``` -> **_NOTE:_** +> [!NOTE] > > It is often better to waive warnings instead of degrading valid code to make it compliant. diff --git a/bin/tcp_client b/bin/tcp_client index 295c8c2..3c254e5 100755 --- a/bin/tcp_client +++ b/bin/tcp_client @@ -66,6 +66,13 @@ fi ## Check if CSV file exists [[ -f "$CSV_FILE" ]] || error "Error: CSV file '$CSV_FILE' not found." +## Support Mac & Unix versions of ncat +if ncat --version 1>/dev/null 2>/dev/null; then + NCAT="ncat" +else + NCAT="nc" +fi + ## ======================================================= ## Clean server file ## ======================================================= @@ -75,7 +82,7 @@ clean_file() { head -n1 "$CSV_FILE" while IFS=, read -r TIMESTAMP HOST PORT PASSWORD LANGUAGE PROJECT CONFIG; do ## Make sure output from a dummy request is valid - response=$(echo '"Is server alive?"' | gpg --symmetric --cipher-algo AES256 --passphrase "$PASSWORD" --batch --yes 2>/dev/null | nc -w5 "$HOST" "$PORT" 2>/dev/null) + response=$(echo '"Is server alive?"' | gpg --symmetric --cipher-algo AES256 --passphrase "$PASSWORD" --batch --yes 2>/dev/null | "$NCAT" -w5 "$HOST" "$PORT" 2>/dev/null) # Check if response contains 'alive' if echo "$response" | grep -q "alive"; then echo "$TIMESTAMP,$HOST,$PORT,$PASSWORD,$LANGUAGE,$PROJECT,$CONFIG" @@ -133,7 +140,7 @@ PASSWORD=$(echo "$PASSWORD" | xargs) ## ======================================================= ## Encrypt stdin with GPG and forward to server via netcat -gpg --symmetric --cipher-algo AES256 --passphrase "$PASSWORD" --batch --yes | nc "$HOST" "$PORT" +gpg --symmetric --cipher-algo AES256 --passphrase "$PASSWORD" --batch --yes | "$NCAT" "$HOST" "$PORT" exit 0 diff --git a/doc/markdown/presentation.md b/doc/markdown/presentation.md new file mode 100644 index 0000000..b0ad8a3 --- /dev/null +++ b/doc/markdown/presentation.md @@ -0,0 +1,406 @@ +--- +marp: true +theme: gaia +class: invert two-columns +auto-scaling: true +--- + + + + +# SKILL# + +## Cadence SKILL++ Enhanced Framework + +
+
+ +**Targeted Audience :** Anyone who writes SKILL + +
+
+ +###### Created by [Aurélien Buchet](https://github.com/Da-Buche) + +###### Open Source Repository on [GitHub](https://github.com/Da-Buche/skill-sharp) + +--- + + +## Introduction + + +--- + + +### Out-of-the-Box Tools + +- Advanced Linter +- Code formatter [unfinished] +- Enhanced Finder + +
+ +### Advanced SKILL++ Features + +- Unit-Testing Framework +- Documentation Generation +- On-Demand Type-Checking +- Fully Tested API + + +--- +## Requirements + +### To Use + +Virtuoso with `$CDS_INST_DIR` defined + +### To Develop + +- [GNU Make](https://github.com/mirror/make) +- [scc](https://github.com/boyter/scc) +- [shellcheck](https://github.com/koalaman/shellcheck) ≥ 0.10.0 +- [fd](https://github.com/sharkdp/fd) +- [shellspec](https://github.com/shellspec/shellspec) ≥ 0.28.1 + +--- +## Standalone Usage + +`$SKILL_SHARP_ROOT/bin/sharp` commands: + +| Command | Documentation | +|-----------------|-------------------------------------------------| +| `sharp help` | Display available commands and arguments. | +| `sharp lint` | Run advanced Linter on provided files. | +| `sharp test` | Load files and print test report. | +| `sharp globals` | Load files and report global definitions. | +| `sharp docgen` | Load files and print associated `.fnd` content. | + + +--- +## Usage Inside Virtuoso + +
+ +In the CIW or in `.cdsinit` to enable all SKILL# features: + +`(load (simplifyFilename "$SKILL_SHARP_ROOT/skill/loader.scm"))` + +
+
+
+ +*`$SKILL_SHARP_ROOT` should point to the installation root* + + +--- + + +## Features + +--- +### Rules for native Linter + +- Waiver + ```lisp + (progn "NO_LINT" ...) + {"NO_LINT" ...} + ``` + +- Hints + ```lisp + (car (setof ...)) -> (car (exists ...)) + ``` + + +- Missing docstrings + +--- +### Custom SKILL++ Linter + +#### Detect unused & superseded local functions + +```lisp +(let () + (defun custom_fun0 ( @rest _ ) "dummy" nil) + (defun custom_fun0 ( @rest _ ) "dummy" nil) + ) +``` + +```lisp +WARNING DEFUN_SUPERSEDE at line 3 - `defun` variable custom_fun0 is superseded +WARNING LET_UNUSED at line 1 - `let` variable custom_fun0 is unused +``` + +Line numbers are reported inside all forms except macros +(only in Lisp syntax for now) + +--- +### Custom SKILL++ Linter + +#### Syntax forms support + +```lisp +;; This is valid SKILL but reported by Lint +(defun print_and_return args (println args) args) +(lambda _ t) +``` + + +--- +### Unit-Testing Framework + +```scheme + +(defun print_hello_world_and_return_12 (name "t") + "Print 'Hello World!' said by NAME and return 12." + (info "%s says 'Hello World! to poport'\n" name) + (warn "%s says 'Hello World! to woport'\n" name) + 12) + +(@test + ?fun 'print_hello_world_and_return_12 + (@assertion + ?doc "Works with John" + (print_hello_world_and_return_12 "John") + ?out 12 + ?info "John says 'Hello World!' to poport" + ?warn "John says 'Hello World!' to woport" + ) + (@assertion + ?doc "Fails with a symbol" + (print_hello_world_and_return_12 'John_as_a_symbol) + ?error "print_hello_world_and_return_12: argument #1 should be a string" + ) + ) +``` + +--- +```lisp +;; ./failing_assertion.ils +(@test + ?fun 'plus + ?doc "Test with failing assertion" + (@assertion 12+27 ?out 42) + ) + +> (@test_run_all ?files '("./failing_assertion.ils")) +Failed @test("primop plus")[stdobj@0x2703d080] from *ciwInPort* + +Failures when running @assertion(0)[stdobj@0x2703d098]: + (plus 12 27) + +Different output: +Expected: █42█ +Got : █39█ + +Total tests: 2 + - skipped tests: 0 + - passed tests: 0 + - failed tests: 1 + +Total assertions: 2 + - skipped assertions: 0 + - passed assertions: 0 + - failed assertions: 1 + +FAIL +``` + + + + + +--- +### Type-Checking +#### On-Demand + +```scheme +(@fun join + ( ( char ?type symbol|string ) ; char is a symbol or a string + @rest + ( strings ?type ( symbol|string ... ) ) ; strings is a list of symbols or strings + ) + ?doc "Join STRINGS using CHAR as junction character." + ?out string ; output is a string + (buildString strings char) + ) +``` + +To enable strict type-checking: +Set `$SKILL_SHARP_STRICT_TYPE_CHECKING` to TRUE + + +--- +### Type-Checking +#### Always Disabled + +```scheme +;; Type-checking always disabled +;; (Still useful for documentation) + +(@fun convert_to_string + ( ( name ?type symbol ) + ) + ?doc "Convert NAME to a string and return it." + ?out string + ?strict nil ; Type-checking is disabled here + (strcat name) + ) +``` + +--- +### Type-Checking +#### Always Enabled + +```scheme +;; Type-checking always enabled +;; (Useful for top functions) + +(@fun double + ( ( num ?type float|integer ) + ) + ?doc "Return the double of NUM as a float." + ?out float + ?strict t ; Type-checking is forced here + ( num * 2.0 ) + ) +``` + +--- + + +### Documentation Generation +### Enhanced Finder + +- Search in name, description, ... +- Match PCREs +- Case-sensitive when upper case +- Restrict to name, description, ... + + +![bg right fit](https://github.com/Da-Buche/skill-sharp/blob/dev/pictures/README/SKILL_Finder.png?raw=true) + + +--- + + +## Design Patterns / Macros + +--- +### F-Strings + +```scheme +;; Values are placed where they should be evaluated: +(@str "The result of 12 plus 27 is {12+27}.") + +(@str " +The current shell is {(getShellEnvVar \"SHELL\")}. +The current time is {(getCurrentTime)}. +") + +;; `printf` formatting is supported +pi = (acos -1) +(@str " +This is pi with four decimals: {pi%0.4f}. \n\ +The default is {pi}. \n\ +") +``` + +--- +### Letf + +```scheme +;; `simplifyFilename` breaks if `(rexMagic)` is nil. +(progn (rexMagic nil) (simplifyFilename "$SHELL")) + +;; `@letf` uses `setf` to set anything temporarily. +(@letf ( ( (rexMagic) t ) ) (simplifyFilename "$SHELL")) +(rexMagic) ; `(rexMagic)` value is still nil. + +;; `@letf` works with any `setf` helper +(@letf ( ( (rexMagic) nil ) + ( (getShellEnvVar "CUSTOM_VARIABLE") "TRUE" ) + ( (status optimizeTailCall) t ) + ) + (list (rexMagic) (getShellEnvVar "CUSTOM_VARIABLE") (status optimizeTailCall)) + ) +``` + +--- +### With + + +```scheme +;; Filter INFO lines from log file (Ports are properly closed afterwards) +(@with ( ( in_port (infile "~/sandbox/log.txt" ) ) + ( out_port (outfile "~/sandbox/filtered_log.txt") ) + ) + (let ( line ) + (while (gets line in_port) + (unless (pcreMatchp "^INFO" line) (fprintf out_port "%s" line)) + ))) +``` + + +```lisp +(defmethod _\@in ( ( obj dbobject ) @rest _ ) "Nothing to do here" nil) + +(defmethod _\@out ( ( obj dbobject ) @rest _ ) + "Context manager when releasing a dbobject." + (if (equal "cellView" obj->objType) (dbClose obj) + (error "_\@out - %N is not a supported type."))) +``` + +--- +### Case + +```lisp +(@case (css)->objType ; An ellipse is selected + ( "polygon" (css)->points ) + ( "rect" (destructuringBind ( ( x0 y0 ) ( x1 y1 ) ) (css)->bBox) + (list x0:y0 x1:y0 x1:y1 x0:y1) ) + ) +*Error* Value is not amongst valid cases ("polygon" "rect"): "ellipse" +``` + +```lisp +(@caseq 'd + ( a 12 ) + ( b 27 ) + ( c 42 ) + ) +*Error* Value is not amongst valid cases (a b c): 'd +``` + diff --git a/examples/lint.ils b/examples/lint.ils new file mode 100755 index 0000000..bcd309f --- /dev/null +++ b/examples/lint.ils @@ -0,0 +1,118 @@ +#!/bin/tcsh -f +;; ## Assert Virtuoso path is set +; test 1 -eq $?CDS_INST_DIR || echo '$CDS_INST_DIR' is not defined! >/dev/stderr && exit 1 +; $CDS_INST_DIR/tools.lnx86/bin/cdsmps `realpath $0` -- $* +; exit $status ; + +;; Fetch provided arguments +(setf script.args (argv)) +(assert (equal "--" (car script.args)) "First argument should be '--'") +(popf script.args) + +;; ======================================================= +;; Ignore Lint messages +;; ======================================================= + +(let ( ignores ) + + (defun add_ignore ( name doc "st" ) + "Ignore Lint messages named NAME while providing DOC as a reason." + (assert (not (blankstrp doc)) "add_ignore - ?doc should not be empty") + (push name ignores) + ) + + (defglobalfun _lint_get_ignores ( @rest _ ) + "Return the list of ignored Lint messages" + ignores + ) + + (add_ignore 'REP110 "No one cares about number of total definitions, only the score matters!" ) + (add_ignore 'PREFIXES "Remove extra message about prefixes" ) + (add_ignore 'STRICT "Remove extra message about strict checking" ) + (add_ignore 'VAR13 "Variable starting with underscore are ignored on purpose!" ) + (add_ignore 'DEFMET4 "Variable starting with underscore are ignored on purpose!" ) + + ) + +;; ======================================================= +;; Run Lint +;; ======================================================= + +;; Defining the following function in SKILL prevents "calling NLambda from Scheme code" message +(inSkill + (defun _lint ( @key files "l" ) + "`sklint` wrapper to message" + (let ( ( tmp_port poport ) + ( out_port (outstring) ) + ( magic (rexMagic) ) + ( score -1 ) + ( errors -1 ) + ( warnings -1 ) + ( status 'UNDEFINED ) + ) + (unwindProtect + ;; Run Lint with output redirected to string port + (progn + (set 'poport out_port) + (rexMagic t) + (sklint + ?file files + ?ignores (_lint_get_ignores) + ) + ;; Retrieve important information + (foreach line (parseString (getOutstring out_port) "\n") + (when (eq 'I (getchar line 1)) + (cond + ( (pcreMatchp "^INFO \\(IQ\\): IQ score is ([0-9]+)" line) + (setq score (atoi (pcreSubstitute "\\1"))) + ) + ( (pcreMatchp "^INFO \\(IQ1\\): IQ score is based on ([0-9]+) error messages, \ +([0-9]+) general warning messages" line) + (setq errors (atoi (pcreSubstitute "\\1"))) + (setq warnings (atoi (pcreSubstitute "\\2"))) + ) + ( (pcreMatchp "^INFO \\(REP009\\): Program SKILL Lint finished on .* with status ([A-Z]+)" line) + (setq status (pcreSubstitute "\\1")) + ) + ));cond ;unless + ));foreach ;progn + ;; Cleanup + (progn + (set 'poport tmp_port) + (close out_port) + (rexMagic magic) + ));unwindProtect + ;; Return extracted data + (list status score errors warnings) + ));let ;def + );SKILL + +;; Run Lint once to remove all the pesky loading messages +(_lint) + +(let ( ( max_len 0 ) + ) + + ; (defun lpadd ( str len ) + ; "Left padd STR with spaces so its minimum length is LEN." + ; (lsprintf (lsprintf "%%%ds" len) str) + ; ) + + (defun rpadd ( str len ) + "Right padd STR with spaces so its minimum length is LEN." + (lsprintf (lsprintf "%%-%ds" len) str) + ) + + ;; Fetch maximum path length + (foreach file script.args + (setq max_len (max max_len (length file))) + ) + + ;; Parse input files + (info "%s STATUS SCORE ERRORS WARNINGS\n" (rpadd "FILE" max_len)) + (foreach file script.args + (destructuringBind (status score errors warnings) (_lint ?files (list file)) + (info "%s %-6s %5d %6d %8d\n" (rpadd file max_len) status score errors warnings) + )) + ) + diff --git a/examples/tcp_communication.scm b/examples/tcp_communication.scm index 8166458..66f4392 100644 --- a/examples/tcp_communication.scm +++ b/examples/tcp_communication.scm @@ -38,11 +38,11 @@ (let ( ( msg field->value ) ) (tconc messages msg) - (setf form->html (messages_to_html messages)) + (setf form->html->value (messages_to_html messages)) (@queue (lambda () (tconc messages (car (@bash (@str "echo '{msg}' | $SKILL_SHARP_ROOT/bin/tcp_client -l PYTHON")))) - (setf form->html (messages_to_html messages)) + (setf form->html->value (messages_to_html messages)) )) )) ) diff --git a/examples/test_tail_call_opt.ils b/examples/test_tail_call_opt.ils new file mode 100644 index 0000000..0a859bd --- /dev/null +++ b/examples/test_tail_call_opt.ils @@ -0,0 +1,50 @@ + +(inScheme +(let () + + (defun rec ( function init l ) + "Apply FUNCTION to INIT and the head of L. +The result of this call is used as init and applied recursively to the tail of L" + (if l + (rec function (funcall function init (car l)) (cdr l)) + init + )) + + (defglobalfun foldl1_unwind ( function l ) + "Left Fold: Apply combination FUNCTION to all elments of L starting from the left." + ;; Make sure tail-call optimization is enabled while calling recursive helper. + (let ( ( tail_call_opt (status optimizeTailCall) ) + ) + (unwindProtect + (progn (sstatus optimizeTailCall t) (rec function (car l) (cdr l))) + (sstatus optimizeTailCall tail_call_opt) + ) + )) + + (defglobalfun foldl1_errset ( function l ) + "Left Fold: Apply combination FUNCTION to all elments of L starting from the left." + (let ( ( tail_call_opt (status optimizeTailCall) ) + res ) + (sstatus optimizeTailCall t) + (setq res (errset (rec function (car l) (cdr l)))) + (sstatus optimizeTailCall tail_call_opt) + (if res (car res) (error "foldl1_errset - error occured: %N" errset.errset)) + )) + + (defglobalfun foldl1_let ( function l ) + "Left Fold: Apply combination FUNCTION to all elments of L starting from the left." + (let ( ( tail_call_opt (status optimizeTailCall) ) + res ) + (sstatus optimizeTailCall t) + (setq res (rec function (car l) (cdr l))) + (sstatus optimizeTailCall tail_call_opt) + res)) + + ));scheme closure + +(tracef rec) + +(foldl1_unwind 'times (list 1 2 3 4)) +(foldl1_errset 'times (list 1 2 3 4)) +(foldl1_let 'times (list 1 2 3 4)) + diff --git a/metatest/docgen/quote.fnd b/metatest/docgen/quote.fnd index 068a39c..2a2d784 100644 --- a/metatest/docgen/quote.fnd +++ b/metatest/docgen/quote.fnd @@ -1,13 +1,13 @@ -( "\\!" - "\\!()" +( "!" + "!()" "\\! is a weird function name!" ) -( "\\\"" - "\\\"()" +( "\"" + "\"()" "\\\" is a weird function name!" ) -( "\\'" - "\\'()" +( "'" + "'()" "\\' is a weird function name!" ) diff --git a/metatest/hello_world.scm b/metatest/hello_world.scm new file mode 100644 index 0000000..07c3a37 --- /dev/null +++ b/metatest/hello_world.scm @@ -0,0 +1,2 @@ +(info "Hello World!\n") + diff --git a/pictures/README/SKILL_Finder.png b/pictures/README/SKILL_Finder.png index 46fab4a..f59371c 100644 Binary files a/pictures/README/SKILL_Finder.png and b/pictures/README/SKILL_Finder.png differ diff --git a/skill/autoloaded/arglist.scm b/skill/autoloaded/arglist.scm new file mode 100644 index 0000000..5ba6b95 --- /dev/null +++ b/skill/autoloaded/arglist.scm @@ -0,0 +1,180 @@ +;; =============================================================================================================== +;; Legacy fixes for `@arglist` and `@output` +;; +;; A. Buchet - September 2025 +;; =============================================================================================================== + +;; ======================================================= +;; Fixes arguments and output checks for macros, +;; syntax forms and all missing functions +;; ======================================================= + +;; TODO - Contact Cadence support about (arglist '...) for all the wrongly defined functions + +(setf (@arglist 'if) + '( ( g_general ?type general ) + ( g_general ?type general ) + ;; @rest here to support 'then & 'else + @rest + ( g_general ?type general ?def nil ) + )) + +(setf (@output 'lambda) 'callable) + +;; No idea why but (arglist 'defun) does not mention body +(setf (@arglist 'defun) + '( ( s_symbol ?type symbol ) + ( g_general ?type general ) + ( g_general ?type general ) + @rest + ( body ?type ( general ... ) ) + )) + +(setf (@arglist 'defglobalfun) (@arglist 'defun )) +(setf (@arglist 'globalProc ) (@arglist 'procedure)) + +(setf (@arglist '@macro) + '( ( name ?type symbol ) + ( args ?type list ) + ( doc ?type string ) + @rest + ( body ?type ( general ...) ) + )) + +(setf (@arglist 'defmacro) + '( ( name ?type symbol ) + ( args ?type list ) + @rest + ( body ?type ( general ...) ) + )) + +(setf (@arglist 'defclass) + '( ( s_className ?type symbol ) + ( s_superClassNames ?type ( symbol ... ) ?def nil ) + ( slots ?type ( symbol general ... ) ?def nil ) + )) + +(setf (@arglist 'defmethod) (@arglist 'defun)) + +(setf (@arglist 'prog) + '( ( l_list ?type list ) + @rest + ( g_general ?type general ) + )) + +(setf (@arglist 'destructuringBind) + '( ( args ?type list ) + ( list ?type list ) + @rest + ( body ?type general) + )) + +(setf (@arglist '_destructuringBind) (@arglist 'destructuringBind)) + +(setf (@arglist 'unwindProtect) + '( ( body ?type general ) + ( cleanup ?type general ) + )) + +(setf (@arglist 'cfiUnwindProtect) (@arglist 'unwindProtect)) + + +(setf (@arglist 'setf) + '( ( g_general ?type general ) + ( g_general ?type general ) + )) + +;; `setf` helpers +(foreach fun_name '( arrayref car cdr cdar cadr get getd getq getqq getShellEnvVar nth status ) + (setf (@arglist (concat 'setf_ fun_name)) (cons '( obj ?type general ) (@arglist fun_name))) + ) + +(setf (@arglist 'push) + '( ( obj ?type general ) + ( target ?type list ) + )) + +(setf (@arglist 'pushf) (@arglist 'push)) + +(setf (@arglist 'funcall) + '( ( u_function ?type function ) + @rest + ( g_general ?def nil ?type ( general ... ) ) + )) + +(setf (@arglist 'apply) + '( ( u_function ?type function ) + @rest + ( g_general ?def nil ?type ( general ... ) ) + )) + +;; Printing functions +(foreach function '( info warn error printf lsprintf ) + (setf (@arglist function) + '( ( string ?type string ?def "" ) + @rest + ( values ?type ( general ... ) ) + ) + )) + +(setf (@arglist 'assert) (cons '( predicate ?type general) (@arglist 'error))) + +(setf (@arglist 'for) + '( ( var ?type symbol ) + ( beg ?type integer ) + ( end ?type integer ) + @rest + ( body ?type ( general ...) ) + )) + +(setf (@arglist '@while) + '( ( bool ?type general ) + @key + ( var ?type symbol|nil ) + @rest + ( body ?type ( general ...) ) + )) + +(setf (@arglist '_backquote) '( ( obj ?type general ) )) + +(setf (@arglist 'let) + '( ( bindings ?type list ) + ( body ?type general ) + @rest + ( body ?type ( general ... )) + )) + +(setf (@arglist 'letseq) (@arglist 'let)) + +(setf (@arglist 'fprintf) + '( ( p_port ?type port ) + ( t_string ?type string ) + @rest + ( g_general ?def nil ?type general) + )) + +(setf (@arglist 'strcat) + '( ( S_stringSymbol ?type stringSymbol ) + @rest + ( S_stringSymbol ?type stringSymbol ) + )) + +(setf (@arglist 'makeInstance) + '( ( class ?type class|symbol ) + @rest + ( args ?type ( general ... ) ) + )) + +(setf (@arglist 'nconc) + '( ( l0 ?type list ) + ( l1 ?type list ) + @rest + ( ln ?type ( list ... ) ) + )) + +(setf (@arglist 'dynamic) '( ( name ?type symbol ) )) + +(setf (@arglist 'popf) '( ( place ?type symbol|list ) )) + +;*/ + diff --git a/skill/autoloaded/debug.scm b/skill/autoloaded/debug.scm index 61579f7..a3e38f9 100644 --- a/skill/autoloaded/debug.scm +++ b/skill/autoloaded/debug.scm @@ -4,11 +4,10 @@ ;; A. Buchet - April 2025 ;; =============================================================================================================== -(@no_lint - (@fun @print_args ( @rest (args) ) - ?doc "Print all provided arguments." - (@show args) - ) +(@fun @print_args ( @rest ( args ) ) + ?doc "Print all provided arguments." + (@no_lint (@show args)) + args ) ;; TODO - Profile macro, but this requires skillDev license @@ -17,11 +16,11 @@ ; (profileSummary) ; ,@sexps));wrap ;macro -(defun @print_table (lists @key headers "lg") +(defun @print_table (lists @key has_headers "lg") "Pretty print LISTS as a table. LISTS is a list of lists, all lists should have the same length. -When HEADERS is non nil, print a separator line aster the first list." +When HAS_HEADERS is non nil, print a separator line aster the first list." ;; Convert elements in LISTS to strings (setq lists (foreach mapcar l lists @@ -42,10 +41,10 @@ When HEADERS is non nil, print a separator line aster the first list." ) (newline) ;; Print headers when required - (when headers + (when has_headers (foreach len lengths (printf (lsprintf "%%-%ds" len+2) " ")) - (setq headers nil) + (setq has_headers nil) (newline) ) ) @@ -68,7 +67,7 @@ When HEADERS is non nil, print a separator line aster the first list." (list sexp (to_us user_cpu) (to_us system_cpu) (to_us clock) page_faults) ));dbind ;foreach mapcar ) - ?headers t + ?has_headers t ));def );closure diff --git a/skill/autoloaded/docgen.scm b/skill/autoloaded/docgen.scm index 6b23dd3..4830eac 100644 --- a/skill/autoloaded/docgen.scm +++ b/skill/autoloaded/docgen.scm @@ -8,22 +8,100 @@ ;; Fetch global definitions ;; ======================================================= -(@fun @globals - ( @key ( files ?type ( string ... ) ) - ( init ?type string ?def (or (getShellEnvVar "SKILL_SHARP_INIT_COMMAND" ) "") ) - ( before ?type string ?def (or (getShellEnvVar "SKILL_SHARP_BEFORE_COMMAND") "") ) - @rest _ +(let () + + (@fun @globals + ( @key + ( files + ?type ( string ... ) + ?doc "List of files from which the global definitions are reported." + ) + ( show_props + ?type t|nil + ?def (equal "TRUE" (getShellEnvVar "SKILL_SHARP_GLOBALS_SHOW_PROPS")) + ?doc "If non-nil modified symbol properties are also reported." + ) + ( load_files + ?type t|nil + ?def (equal "TRUE" (getShellEnvVar "SKILL_SHARP_GLOBALS_LOAD")) + ?doc "If non-nil, files are loaded in an independent SKILL process : + BEFORE command is run. + The whole SKILL environment is cached. + FILES are loaded. + INIT command is run. + All discrepancies betwwen cached and current environments are reported." + ) + ( before + ?type string + ?def (or (getShellEnvVar "SKILL_SHARP_BEFORE_COMMAND") "") + ?doc "When LOAD is non-nil, this command is executed before loading FILES." + ) + ( init + ?type string + ?def (or (getShellEnvVar "SKILL_SHARP_INIT_COMMAND" ) "") + ?doc "When LOAD is non-nil, this command is executed after loading FILES." + ) + @rest _ + ) + ?doc "Return all global definitions from FILES." + ?out ( ( symbol ... )|nil ... )|nil + ?global t + (assert files "@globals - ?files is nil") + (if load_files + ;; Load files and report definitions using `globals` + (destructuringBind ( stdout stderr _status ) + (@bash (@str " + export SKILL_SHARP_BEFORE_COMMAND=\"{(escape_quotes before)}\"; + export SKILL_SHARP_INIT_COMMAND=\"{(escape_quotes init)}\"; + export SKILL_SHARP_GLOBALS_SHOW_PROPS=\"{(if show_props 'TRUE 'FALSE)}\"; + $SKILL_SHARP_ROOT/bin/globals {(buildString files)}")) + (unless (blankstrp stderr) (warn "Warning/Error when running `globals`: %s" stderr)) + (foreach mapcar str (parseString stdout "\n") (car (linereadstring str))) + );dbind + ;; No load, use Lint to parse the files and report global definitions + (@with ( ( port (outstring) ) + ( nullport (outfile "/dev/null") ) + ) + (@lint + ?files files + ?filters '(GLOBAL) + ?info_port port + ?warn_port port + ?err_port nullport + ?no_header t + ) + (@letf ( ( (rexMagic) t ) + ) + ;; Parse Lint results + (let ( functions variables scheme classes symbols name ) + (foreach line (parseString (getOutstring port) "\n") + (assert (pcreMatchp "`([a-zA-Z0-9_@\\\\]+)` global (scheme |function )?definition: ([^ \t\n.]+)" line) "Global message has the wrong format: %N" line) + (setq name (concat (pcreSubstitute "\\3"))) + (@caseq (concat (pcreSubstitute "\\1")) + ( (define setq ) + (case (pcreSubstitute "\\2") + ( "scheme " (push name scheme ) ) + ( "function " (push name functions) ) + ( t (push name variables) ) + ) ) + ( putpropqq (push name symbols) ) + ( ( \\\@fun @fun defun defglobalfun defmethod defmacro procedure globalProc ) (push name functions) ) + ));foreach line + ;; Report global symbol properties only when required + (if show_props + (list functions variables scheme classes symbols ) + (list functions variables scheme classes) + ));if ;let + ));letf ;with + ));if ;fun + + (@fun escape_quotes ( ( str ?type string ) ) + ?doc "Escape quotes inside STR and return it." + ?out string + (@exact_replace "\"" str "\\\"") ) - ?doc "Return all global definitions from after loading FILES and run INIT." - ?out ( ( symbol ... ) ... ) - (destructuringBind ( stdout stderr _status ) - (@bash (@str " -export SKILL_SHARP_BEFORE_COMMAND=\"{before}\"; -export SKILL_SHARP_INIT_COMMAND=\"{init}\"; -$SKILL_SHARP_ROOT/bin/globals {(buildString files)}")) - (unless (blankstrp stderr) (warn "Error when running `globals`: %s" stderr)) - (foreach mapcar str (parseString stdout "\n") (car (linereadstring str))) - )) + + );closure ;; ======================================================= ;; Generate .fnd documentation @@ -31,6 +109,8 @@ $SKILL_SHARP_ROOT/bin/globals {(buildString files)}")) (let () + ;; TODO - In docgen, we were cleaning backslashes, it might be simpler to add them only when necessary + (@fun escape ( ( str ?type string ) ) @@ -91,7 +171,9 @@ $SKILL_SHARP_ROOT/bin/globals {(buildString files)}")) (@assertion ?doc "Make sure special characters are well escaped." (title '_\@str) - ?out "_\\\\@str" + ?out "_@str" + ;; TODO - Test is waived for now + ;?out "_\\\\@str" ) (@assertion @@ -171,7 +253,7 @@ $SKILL_SHARP_ROOT/bin/globals {(buildString files)}")) ));let ;when (fprintf port ")") ;; Print output when defined - (when (memq '@out (get name '?)) (fprintf port " => %s" (@pretty_print (get name '@out) t))) + (when (memq '@output (get name '?)) (fprintf port " => %s" (@pretty_print (get name '@output) t))) (getOutstring port) ));with ;fun @@ -196,7 +278,7 @@ $SKILL_SHARP_ROOT/bin/globals {(buildString files)}")) (fprintf port ";; %s\n" test->doc) ) (foreach map assertions (@get_assertions test) - (@when (@is? '@nonblankstring? (car assertions)->doc) + (@when (@nonblankstring? (car assertions)->doc) ?var doc (fprintf port ";; %s\n" doc) ) @@ -204,9 +286,9 @@ $SKILL_SHARP_ROOT/bin/globals {(buildString files)}")) (letseq ( ( assertion (car assertions) ) ( input assertion->body_quoted ) ( output (car assertion->body_result) ) - ( info (@is? '@nonblankstring? assertion->info_expected ) ) - ( warn (@is? '@nonblankstring? assertion->warn_expected ) ) - ( error (@is? '@nonblankstring? assertion->error_expected) ) + ( info (@nonblankstring? assertion->info_expected ) ) + ( warn (@nonblankstring? assertion->warn_expected ) ) + ( error (@nonblankstring? assertion->error_expected) ) ) ;; Shape input so it can be copy-pasted and run in CIW by any user (when (listp input) @@ -252,7 +334,7 @@ $SKILL_SHARP_ROOT/bin/globals {(buildString files)}")) Print associated documentation (as .fnd file content) to stdout." ?out t|nil ?global t - (destructuringBind ( functions _variables _scheme _classes _symbols ) + (destructuringBind ( functions _variables _scheme _classes @optional _symbols ) (@globals ?files files ?before (@str "(progn nil (inSkill (sklint)) {before})") ?init init) ;; Load all files containing tests (@letf ( ( (status keepNLInString ) t ) @@ -278,6 +360,7 @@ Print associated documentation (as .fnd file content) to stdout." {source})\n" );@fprintf ));let ;foreach function + t ));dbind ;fun );closure @@ -358,10 +441,10 @@ A valid .fnd expression should be t or a list containing three strings." ?global t (assert files "@fndcheck - no files were provided...") (forall file files - (@with ( ( port (infile file)) + (@with ( ( port (or (infile file) (error "@fndcheck - Unable to read file %N" file)) ) ;; This was used to match native Finder behavior which probably uses a different interpreter. ;; As it seems OK with meaningless escaped characters. - ;( port (instring (@exact_replace "\\@" (@file_contents file) "\\\\@")) ) + ;( port (instring (@exact_replace "\\@" (@read_file file) "\\\\@")) ) ) (prog ( sexp ) (while (car (setq sexp (errset (lineread port) t))) diff --git a/skill/autoloaded/finder.scm b/skill/autoloaded/finder.scm index dc6116f..6d6b084 100644 --- a/skill/autoloaded/finder.scm +++ b/skill/autoloaded/finder.scm @@ -27,10 +27,13 @@ (let ( ( table (makeTable t nil) ) ) - (defmethod initializeInstance @after ( ( obj @fnd_category ) @rest _ ) - "Properly store OBJ." - (setf table[obj->name] obj) - ) + ;; Waiver so Lint does not report `initializeInstance` as a global definition + ;; (Files in autoloaded folder are used to check that Lint and `globals` return the same output) + (@no_lint + (defmethod initializeInstance @after ( ( obj @fnd_category ) @rest _ ) + "Properly store OBJ." + (setf table[obj->name] obj) + )) (@fun _\@fnd_category_by_name ( ( name ?type string ) @@ -107,7 +110,7 @@ functions ) ;; Fix backslash issues before parsing the file - ;( port (instring (@exact_replace "\\@" (@file_contents path) "\\\\@")) ) + ;( port (instring (@exact_replace "\\@" (@read_file path) "\\\\@")) ) (@with ( (port (infile path)) ) (muffleWarnings @@ -342,7 +345,7 @@ (isReadable (setq file (@realpath source))) ) ;; Try to find definition in file - (let ( ( text (@file_contents file) ) + (let ( ( text (@read_file file) ) ( line 1 ) ) (@letf ( ( (rexMagic) t ) @@ -575,13 +578,24 @@ It contains predefined filters. (@fun _\@fnd_replace_native_finder_in_ciw () ?doc "Replace 'SKILL API Finder' by 'SKILL# API Finder' in CIW->Tools menu." ?global t - (@menu_replace_item + ; (@menu_replace_item + ; ?window (hiGetCIWindow) + ; ?menu_label "Tools" + ; ?item_label "SKILL API Finder" + ; ?new_item_icon (hiLoadIconData (@realpath "$SKILL_SHARP_ROOT/pictures/icons/sharp.png")) + ; ?new_item_callback "(if (equal \"TRUE\" (getShellEnvVar \"SKILL_SHARP_KEEP_NATIVE_FINDER\")) (startFinder) (@fnd_gui))" + ; ) + ;; Inserting a new item is always safer than replacing an existing one + (@menu_insert_item_before ?window (hiGetCIWindow) ?menu_label "Tools" ?item_label "SKILL API Finder" + ?new_item_name 'skill_sharp_api_finder_item + ?new_item_label "SKILL# API Finder" ?new_item_icon (hiLoadIconData (@realpath "$SKILL_SHARP_ROOT/pictures/icons/sharp.png")) ?new_item_callback "(if (equal \"TRUE\" (getShellEnvVar \"SKILL_SHARP_KEEP_NATIVE_FINDER\")) (startFinder) (@fnd_gui))" - )) + ) + ) ;; Replacing SKILL API Finder by force. ;; This is a bit intrusive but this finder supports all the native features and adds more. diff --git a/skill/autoloaded/lint.scm b/skill/autoloaded/lint.scm index 3049e81..ff047cc 100644 --- a/skill/autoloaded/lint.scm +++ b/skill/autoloaded/lint.scm @@ -4,173 +4,6 @@ ;; A. Buchet - September 2025 ;; =============================================================================================================== -;; ======================================================= -;; Fixes arguments check for macros and syntax forms -;; ======================================================= - -;; TODO - Contact Cadence support about (arglist '...) for all the wrongly defined functions - -(setf (@arglist 'if) - '( ( g_general ?type general ) - ( g_general ?type general ) - ;; @rest here to support 'then & 'else - @rest - ( g_general ?type general ?def nil ) - )) - -;; No idea why but (arglist 'defun) does not mention body -(setf (@arglist 'defun) - '( ( s_symbol ?type symbol ) - ( g_general ?type general ) - ( g_general ?type general ) - @rest - ( body ?type ( general ... ) ) - )) - -(setf (@arglist 'defglobalfun) (@arglist 'defun )) -(setf (@arglist 'globalProc ) (@arglist 'procedure)) - -(setf (@arglist '@macro) - '( ( name ?type symbol ) - ( args ?type list ) - ( doc ?type string ) - @rest - ( body ?type ( general ...) ) - )) - -(setf (@arglist 'defmacro) - '( ( name ?type symbol ) - ( args ?type list ) - @rest - ( body ?type ( general ...) ) - )) - -(setf (@arglist 'defclass) - '( ( s_className ?type symbol ) - ( s_superClassNames ?type ( symbol ... ) ?def nil ) - ( slots ?type ( symbol general ... ) ?def nil ) - )) - -(setf (@arglist 'defmethod) (@arglist 'defun)) - -(setf (@arglist 'prog) - '( ( l_list ?type list ) - @rest - ( g_general ?type general ) - )) - -(setf (@arglist 'destructuringBind) - '( ( args ?type list ) - ( list ?type list ) - @rest - ( body ?type general) - )) - -(setf (@arglist '_destructuringBind) (@arglist 'destructuringBind)) - -(setf (@arglist 'unwindProtect) - '( ( body ?type general ) - ( cleanup ?type general ) - )) - -(setf (@arglist 'cfiUnwindProtect) (@arglist 'unwindProtect)) - - -(setf (@arglist 'setf) - '( ( g_general ?type general ) - ( g_general ?type general ) - )) - -;; `setf` helpers -(foreach fun_name '( arrayref car cadr get getd getq getqq getShellEnvVar nth status ) - (setf (@arglist (concat 'setf_ fun_name)) (cons '( obj ?type general ) (@arglist fun_name))) - ) - -(setf (@arglist 'push) - '( ( obj ?type general ) - ( target ?type list ) - )) - -(setf (@arglist 'pushf) (@arglist 'push)) - -(setf (@arglist 'funcall) - '( ( u_function ?type function ) - @rest - ( g_general ?def nil ?type ( general ... ) ) - )) - -(setf (@arglist 'apply) - '( ( u_function ?type function ) - @rest - ( g_general ?def nil ?type ( general ... ) ) - )) - -;; Printing functions -(foreach function '( info warn error printf lsprintf ) - (setf (@arglist function) - '( ( string ?type string ?def "" ) - @rest - ( values ?type ( general ... ) ) - ) - )) - -(setf (@arglist 'assert) (cons '( predicate ?type general) (@arglist 'error))) - -(setf (@arglist 'for) - '( ( var ?type symbol ) - ( beg ?type integer ) - ( end ?type integer ) - @rest - ( body ?type ( general ...) ) - )) - -(setf (@arglist '@while) - '( ( bool ?type general ) - @key - ( var ?type symbol|nil ) - @rest - ( body ?type ( general ...) ) - )) - -(setf (@arglist '_backquote) '( ( obj ?type general ) )) - -(setf (@arglist 'let) - '( ( bindings ?type list ) - ( body ?type general ) - @rest - ( body ?type ( general ... )) - )) - -(setf (@arglist 'letseq) (@arglist 'let)) - -(setf (@arglist 'fprintf) - '( ( p_port ?type port ) - ( t_string ?type string ) - @rest - ( g_general ?def nil ?type general) - )) - -(setf (@arglist 'strcat) - '( ( S_stringSymbol ?type stringSymbol ) - @rest - ( S_stringSymbol ?type stringSymbol ) - )) - -(setf (@arglist 'makeInstance) - '( ( class ?type class|symbol ) - @rest - ( args ?type ( general ... ) ) - )) - -(setf (@arglist 'nconc) - '( ( l0 ?type list ) - ( l1 ?type list ) - @rest - ( ln ?type ( list ... ) ) - )) - -(setf (@arglist 'dynamic) '( ( name ?type symbol ) )) - ;; ======================================================= ;; Add Rule ;; ======================================================= @@ -179,18 +12,18 @@ ;; Default rule ;; ------------------------------------------------------- -(@fun @lint_default_rule +(@fun _\@lint_default_rule ( ( sexp ?type list ) ( messages ?type tconc ) ( levels ?type list ) ( parents ?type list ) ( envs ?type list ) - ( scheme ?type boolean ) + ( scheme ?type t|nil ) ) ?doc "Apply Lint recursively on all sublists of SEXP. This is the default Lint 'control' rule." ?out nil - ;(@debug "@lint_default_rule - sexp: {sexp}\n messages: {messages}\n\n") + ;(@debug "_\\@lint_default_rule - sexp: {sexp}\n messages: {messages}\n\n") (let ( ( sexp_pos 1 ) ( fun (car sexp) ) ( args (cdr sexp) ) @@ -207,17 +40,17 @@ This is the default Lint 'control' rule." ;; Variable is callable ( (isCallable fun) ) ;; Not callable... - ( t (@lint_msg sexp messages levels 'WARNING 'UNCALLABLE "{fun} is not callable") ) + ( t (_\@lint_msg sexp messages levels 'WARNING 'UNCALLABLE "{fun} is not callable") ) )) ( list ;; TODO - List might sometimes be callable ) - ( t (@lint_msg sexp messages levels 'WARNING 'UNCALLABLE "{fun} is not callable") ) + ( t (_\@lint_msg sexp messages levels 'WARNING 'UNCALLABLE "{fun} is not callable") ) ) ;; Check arguments (foreach sub_sexp args - (@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) + (_\@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) )) nil) @@ -229,7 +62,7 @@ This is the default Lint 'control' rule." ( rules_by_fun (makeTable t nil) ) ) - (@fun @lint_rule + (@fun _\@lint_rule ( @key ( functions ?type ( symbol ... ) ) ( control ?type t|nil ?def nil ) @@ -246,9 +79,9 @@ This is the default Lint 'control' rule." t );fun - (defglobalfun @lint_sexp ( sexp messages levels parents envs scheme ) + (defglobalfun _\@lint_sexp ( sexp messages levels parents envs scheme ) "Lint SEXP." - ;(@debug "_@lint_sexp\n sexp: {sexp}\n messages: {messages}\n\n") + ;(@debug "_\\@lint_sexp\n sexp: {sexp}\n messages: {messages}\n\n") ;; TODO - At least when debugging, assert that levels and parents are matching (in terms of nested expressions) (cond @@ -265,7 +98,7 @@ This is the default Lint 'control' rule." ( (eq '? (getchar sexp 1)) ) ;; Variable is bound ( (if scheme (boundp sexp (schemeTopLevelEnv)) (boundp sexp)) - (@lint_msg (car parents) messages levels 'WARNING 'GLOBAL_USE (@str "Global variable is used: {sexp}") + (_\@lint_msg (car parents) messages levels 'WARNING 'GLOBAL_USE (@str "Global variable is used: {sexp}") ?predicate (lambda _ ;; Make sure function is not defined later @@ -277,7 +110,7 @@ This is the default Lint 'control' rule." ))) )) ) - ( t (@lint_msg (car parents) messages levels 'ERROR 'GLOBAL_USE (@str "Undefined global variable is used: {sexp}") + ( t (_\@lint_msg (car parents) messages levels 'ERROR 'GLOBAL_USE (@str "Undefined global variable is used: {sexp}") ?predicate (lambda _ ;; Make sure function is not defined later @@ -311,7 +144,7 @@ This is the default Lint 'control' rule." ;; Function is global, check its arguments and its rules (@nif (getd fun) (progn - (@lint_msg sexp messages levels 'WARNING 'NOT_CALLABLE (@str "Function {fun} is not callable") + (_\@lint_msg sexp messages levels 'WARNING 'NOT_CALLABLE (@str "Function {fun} is not callable") ;; Following predicate is here to guarantee that function is not defined afterwards in another environment ?predicate (lambda _ @@ -327,12 +160,12 @@ This is the default Lint 'control' rule." (let ( ( sexp_pos 1 ) ) (foreach sub_sexp (cdr sexp) - (@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) + (_\@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) )) ) ;; Check function arguments (unless (errset (check_arguments sexp messages levels (get_arguments fun)) nil) - (@lint_msg sexp messages levels 'WARNING 'ARGS_CHECK_FAIL (@str "Error when checking arguments: {errset.errset}")) + (_\@lint_msg sexp messages levels 'WARNING 'ARGS_CHECK_FAIL (@str "Error when checking arguments: {errset.errset}")) ) ;; Fetch and apply rules (prog ( ( control_rule control_rule_by_fun[fun] ) @@ -342,26 +175,26 @@ This is the default Lint 'control' rule." ;; When a macro is encountered, try to expand it and report expansion errors (@nif (isMacro fun) ;; Not a macro, use default control rule unless provided - (push (or control_rule '@lint_default_rule) rules) + (push (or control_rule '_\@lint_default_rule) rules) ;; Macro (setq expanded_sexp (expand_macro sexp messages levels)) (unless expanded_sexp (return)) ;; If macro has no control rule, parse its expanded value (if control_rule (push control_rule rules) - (@lint_sexp expanded_sexp messages (cons 'STOP levels) (cons sexp parents) envs scheme) + (_\@lint_sexp expanded_sexp messages (cons 'STOP levels) (cons sexp parents) envs scheme) )) ;; Apply rules (foreach rule rules (unless (errset (funcall rule sexp messages levels parents envs scheme) nil) - (@lint_msg sexp messages levels 'WARNING 'LINT_ERROR (@str "Error when applying `{fun}` rule: {errset.errset}")) + (_\@lint_msg sexp messages levels 'WARNING 'LINT_ERROR (@str "Error when applying `{fun}` rule: {errset.errset}")) )) );prog ));nif ;symbolp ;; TODO - Lists might be callable ;; Any other arugment is not supposed to be called - ( t (@lint_msg sexp messages levels 'WARNING 'NOT_CALLABLE (@str "Not callable")) ) + ( t (_\@lint_msg sexp messages levels 'WARNING 'NOT_CALLABLE (@str "Not callable")) ) ));cond ;dbind );t ));cond ;fun @@ -374,7 +207,7 @@ This is the default Lint 'control' rule." ) ?doc "Check if SEXP respects ARGLIST." (@nif arguments - (@lint_msg sexp messages levels 'INFO 'UNSUPPORTED (@str "`{(car sexp)}` arguments check is not supported, see (@arglist `{(car sexp)}`)")) + (_\@lint_msg sexp messages levels 'INFO 'UNSUPPORTED (@str "`{(car sexp)}` arguments check is not supported, see (@arglist `{(car sexp)}`)")) (destructuringBind ( positional_args key_args rest_arg ) arguments (let ( ( provided_args (copy (cdr sexp)) ) ( remaining_args nil ) @@ -392,7 +225,7 @@ This is the default Lint 'control' rule." (eq '? (getchar arg 1)) (neq '? arg) (neq 'quote (car sexp)) - (@lint_msg sexp messages levels 'WARNING 'POSITIONAL_KEY_ARG (@str "`{(car sexp)}` argument {arg} is treated as positional, move or quote it for disambiguation")) + (_\@lint_msg sexp messages levels 'WARNING 'POSITIONAL_KEY_ARG (@str "`{(car sexp)}` argument {arg} is treated as positional, move or quote it for disambiguation")) ) )) ;; Missing argument, check if argument is required or optional @@ -401,7 +234,7 @@ This is the default Lint 'control' rule." ( t missing_args_count++ ) ));cond ;foreach (when (plusp missing_args_count) - (@lint_msg sexp messages levels 'ERROR 'MISSING_ARG (@str "`{(car sexp)}` requires {missing_args_count} more positional arguments")) + (_\@lint_msg sexp messages levels 'ERROR 'MISSING_ARG (@str "`{(car sexp)}` requires {missing_args_count} more positional arguments")) ) ;; Check key arguments (while provided_args @@ -414,20 +247,20 @@ This is the default Lint 'control' rule." ;; Argument is unexpected ( (not key_args[arg]) (unless (memq (car sexp) '( funcall apply makeInstance )) - (@lint_msg sexp messages levels 'WARNING 'EXTRA_KEY_ARG (@str "`{(car sexp)}` extra key argument {arg} is provided")) + (_\@lint_msg sexp messages levels 'WARNING 'EXTRA_KEY_ARG (@str "`{(car sexp)}` extra key argument {arg} is provided")) ) (push arg remaining_args) ) ;; Argument is expected and value is provided ( provided_args (pop provided_args) ) ;; Argument is expected but has no value - ( t (@lint_msg sexp messages levels 'ERROR 'MISSING_KEY_VALUE (@str "`{(car sexp)} key argument {arg} requires a value`")) ) + ( t (_\@lint_msg sexp messages levels 'ERROR 'MISSING_KEY_VALUE (@str "`{(car sexp)} key argument {arg} requires a value`")) ) )) ( t (push arg remaining_args) ) );cond ));let ;while (when (and remaining_args (not rest_arg)) - (@lint_msg sexp messages levels 'ERROR 'EXTRA_ARGS (@str "`{(car sexp)}` extra arguments are provided")) + (_\@lint_msg sexp messages levels 'ERROR 'EXTRA_ARGS (@str "`{(car sexp)}` extra arguments are provided")) ) ));let ;dbind ));fun @@ -475,13 +308,13 @@ Output is positional arguments, key arguments and rest argument." ;; Return expanded macro (car res) ;; Fail to expand macro, raise Lint error and return nil - (@lint_msg sexp messages levels 'ERROR 'MACRO_EXPANSION (@str "`{(car sexp)}` error when expanding macro: {errset.errset}")) + (_\@lint_msg sexp messages levels 'ERROR 'MACRO_EXPANSION (@str "`{(car sexp)}` error when expanding macro: {errset.errset}")) nil )) );closure -(defun @lint_msg ( sexp messages levels type name msg @key ( predicate '@t ) @rest _) +(defun _\@lint_msg ( sexp messages levels type name msg @key ( predicate '@t ) @rest _) "Add Lint message to MESSAGES. SEXP is the expression concerned by the message. LEVELS contains the information about the nested parent expressions to reach the concerned SEXP. @@ -490,7 +323,7 @@ NAME is the message reference." (tconc messages (list predicate type name levels msg sexp)) nil) -(defun @lint_resolve_env ( sexp messages levels env ) +(defun _\@lint_resolve_env ( sexp messages levels env ) "Resolve ENV and report unused variables in SEXP." (let ( ( fun (car sexp) ) ) @@ -499,11 +332,11 @@ NAME is the message reference." (@caseq env[name]->status ( ( used called global ) nil ) ( assigned - (@lint_msg sexp messages levels 'WARNING (concat (upperCase fun) '_ASSIGNED_ONLY) + (_\@lint_msg sexp messages levels 'WARNING (concat (upperCase fun) '_ASSIGNED_ONLY) (@str "`{fun}` variable {name} is assigned only")) ) ( t - (@lint_msg sexp messages levels 'WARNING (concat (upperCase fun) '_UNUSED) + (_\@lint_msg sexp messages levels 'WARNING (concat (upperCase fun) '_UNUSED) (@str "`{fun}` variable {name} is unused") ;; Make sure function was not called before its definition (which is valid) ?predicate (let ( ( key name ) ) (lambda _ (neq 'used env[key]->status))) @@ -521,19 +354,7 @@ NAME is the message reference." ;; Lint waiver ;; ------------------------------------------------------- -(@macro @no_lint ( @rest body ) - "Lint waiver, equivalent to `progn'." - (constar 'progn "NO_LINT" body)) - -(@no_lint - (SK_RULE SK_CONTROL ( @no_lint ) t nil) - (SK_RULE SK_CONTROL ( progn ) t - ;; Check `progn' first argument - (unless (equal "NO_LINT" (car (SK_ARGS))) - (foreach map sexp (SK_ARGS) (SK_CHECK_FORM sexp)) - ))) - -(@lint_rule +(_\@lint_rule ?functions '( quote @no_lint ) ?control t ?rule_fun '@nil @@ -543,19 +364,19 @@ NAME is the message reference." ;; `progn` ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( progn ) ?control t ?rule_fun (lambda ( sexp @rest args ) - (unless (equal "NO_LINT" (nth 1 sexp)) (apply '@lint_default_rule sexp args)) + (unless (equal "NO_LINT" (nth 1 sexp)) (apply '_\@lint_default_rule sexp args)) )) ;; ------------------------------------------------------- ;; `if`, `when`, `unless` ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( if ) ?control t ?rule_fun @@ -567,28 +388,28 @@ NAME is the message reference." (foreach sub_sexp (cdr sexp) pos++ (unless (memq sub_sexp '( then else )) - (@lint_sexp sub_sexp messages (cons pos levels) (cons sexp parents) envs scheme) + (_\@lint_sexp sub_sexp messages (cons pos levels) (cons sexp parents) envs scheme) ) )) - (@lint_msg sexp messages levels 'ERROR 'EXTRA_ARGS (@str "`if` extra args were provided: {(cddddr sexp)}")) + (_\@lint_msg sexp messages levels 'ERROR 'EXTRA_ARGS (@str "`if` extra args were provided: {(cddddr sexp)}")) ) )) -(@lint_rule +(_\@lint_rule ?functions '( if ) ?rule_fun (lambda ( sexp messages levels @rest _ ) ;; (if nil ...) can be replaced by `unless` (unless (nth 2 sexp) - (@lint_msg sexp messages levels 'INFO 'IF_NIL (@str "(if nil ...) can be replaced by (unless ...)")) + (_\@lint_msg sexp messages levels 'INFO 'IF_NIL (@str "(if nil ...) can be replaced by (unless ...)")) ) ;; (if ) can be replaced by `when` (unless (nthcdr 3 sexp) - (@lint_msg sexp messages levels 'INFO 'IF_THEN (@str "(if ) can be replaced by (when )")) + (_\@lint_msg sexp messages levels 'INFO 'IF_THEN (@str "(if ) can be replaced by (when )")) ) )) -(@lint_rule +(_\@lint_rule ?functions '( if when unless ) ?rule_fun (lambda ( sexp messages levels @rest _ ) @@ -600,7 +421,7 @@ NAME is the message reference." (not (memq (type condition) '( list symbol ))) (and (listp condition) (eq 'quote (car condition))) ) - (@lint_msg sexp messages levels 'WARNING 'STATIC_CONDITION (@str "`{(car sexp)}` is useless, condition is static: {condition}")) + (_\@lint_msg sexp messages levels 'WARNING 'STATIC_CONDITION (@str "`{(car sexp)}` is useless, condition is static: {condition}")) )) )) @@ -608,7 +429,7 @@ NAME is the message reference." ;; `setof`, `exists` & `forall` ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( setof exists forall ) ?control t ?rule_fun @@ -617,33 +438,33 @@ NAME is the message reference." (errset (destructuringBind ( fun var elts predicate ) sexp (@nif (symbolp var) - (@lint_msg sexp messages levels 'ERROR (concat (upperCase fun) '_VARIABLE) + (_\@lint_msg sexp messages levels 'ERROR (concat (upperCase fun) '_VARIABLE) (@str "`{fun}` first argument should be an unquoted symbol") ) (let ( (env (makeTable t nil)) ) (setf env[var] (list nil 'status 'unused)) - (@lint_sexp elts messages (cons 2 levels) (cons sexp parents) envs scheme) - (@lint_sexp predicate messages (cons 3 levels) (cons sexp parents) (cons env envs) scheme) - (@lint_resolve_env sexp messages levels env) + (_\@lint_sexp elts messages (cons 2 levels) (cons sexp parents) envs scheme) + (_\@lint_sexp predicate messages (cons 3 levels) (cons sexp parents) (cons env envs) scheme) + (_\@lint_resolve_env sexp messages levels env) ) )) nil) - (@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase (car sexp))) + (_\@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase (car sexp))) (@str "`{(car sexp)}` syntax should be ({(car sexp)} )")) ) )) ;; ------------------------------------------------------- -;; (car (setof ...)) +;; (car (setof ...)) to replace by (car (exists ...)) ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( setof ) ?rule_fun (lambda ( sexp messages levels parents @rest _ ) (when (eq 'car (caar parents)) - (@lint_msg sexp messages (cdr levels) 'INFO 'CAR_SETOF "(car (setof ...)) can almost always be replaced by (car (exists ...))") + (_\@lint_msg sexp messages (cdr levels) 'INFO 'CAR_SETOF "(car (setof ...)) can almost always be replaced by (car (exists ...))") )) ) @@ -651,32 +472,32 @@ NAME is the message reference." ;; case-like functions ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( case caseq @case @caseq ) ?control t ?rule_fun (lambda ( sexp messages levels parents envs scheme ) (cond ;; Check minumun number of arguments - ( (not (cddr sexp)) (@lint_msg sexp messages levels 'ERROR 'CASE_MISSING_ARGS (@str "`{(car sexp)}` requires at least two arguments")) ) + ( (not (cddr sexp)) (_\@lint_msg sexp messages levels 'ERROR 'CASE_MISSING_ARGS (@str "`{(car sexp)}` requires at least two arguments")) ) ( t (destructuringBind ( fun val @rest cases ) sexp (let ( ( case_sexp_pos 1 ) ) - (@lint_sexp val messages (cons case_sexp_pos levels) (cons sexp parents) envs scheme) + (_\@lint_sexp val messages (cons case_sexp_pos levels) (cons sexp parents) envs scheme) ;; Browse cases (foreach case cases case_sexp_pos++ (cond ( (not (listp case)) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_CASE (@str "`{fun}` argument should be a list: {case}")) + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_CASE (@str "`{fun}` argument should be a list: {case}")) ) ;; Parse result S-expressions ( t (let ( ( sexp_pos 1 ) ) (foreach sub_sexp (cdr case) - (@lint_sexp sub_sexp messages + (_\@lint_sexp sub_sexp messages (constar sexp_pos++ case_sexp_pos levels ) (constar case sexp parents ) envs scheme @@ -692,7 +513,7 @@ NAME is the message reference." ;; cond ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( cond ) ?control t ?rule_fun @@ -704,11 +525,11 @@ NAME is the message reference." cond_pos++ (setq sexp_pos 0) (unless (listp tuple) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_CASE (@str "`{(car sexp)}` argument should be a list: {tuple}")) + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_CASE (@str "`{(car sexp)}` argument should be a list: {tuple}")) (return) ) (foreach sub_sexp tuple - (@lint_sexp sub_sexp messages + (_\@lint_sexp sub_sexp messages (constar sexp_pos++ cond_pos levels ) (constar tuple sexp parents ) envs scheme @@ -720,7 +541,7 @@ NAME is the message reference." ;; getq & getqq ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( getq getqq ) ?control t ?rule_fun @@ -730,18 +551,18 @@ NAME is the message reference." ( key (caddr sexp) ) ) (@caseq fun - ( getq (@lint_sexp obj messages (cons 1 levels) (cons sexp parents) envs scheme) ) + ( getq (_\@lint_sexp obj messages (cons 1 levels) (cons sexp parents) envs scheme) ) ( getqq (unless (symbolp obj) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_GETQQ (@str "`{fun}` argument should be an unquoted symbol: {obj}")))) + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_GETQQ (@str "`{fun}` argument should be an unquoted symbol: {obj}")))) ) (unless (symbolp key) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_ (concat (upperCase fun)) + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_ (concat (upperCase fun)) (@str "`{fun}` argument should be an unquoted symbol: {key}") )) ) )) -(@lint_rule +(_\@lint_rule ?functions '( putpropq putpropqq ) ?control t ?rule_fun @@ -752,15 +573,18 @@ NAME is the message reference." ( key (cadddr sexp) ) ) (@caseq fun - ( putpropq (@lint_sexp obj messages (cons 1 levels) (cons sexp parents) envs scheme) ) - ( putpropqq (unless (symbolp obj) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_PUTPROPQQ (@str "`{fun}` argument should be an unquoted symbol: {obj}")))) + ( putpropq (_\@lint_sexp obj messages (cons 1 levels) (cons sexp parents) envs scheme) ) + ( putpropqq + (if (symbolp obj) + (_\@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global definition: {obj}.{key}")) + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_PUTPROPQQ (@str "`{fun}` argument should be an unquoted symbol: {obj}")) + )) ) (unless (symbolp key) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_ (concat (upperCase fun)) + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_ (concat (upperCase fun)) (@str "`{fun}` argument should be an unquoted symbol: {key}") )) - (@lint_sexp val messages (cons 2 levels) (cons sexp parents) envs scheme) + (_\@lint_sexp val messages (cons 2 levels) (cons sexp parents) envs scheme) ) )) @@ -768,7 +592,7 @@ NAME is the message reference." ;; let ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( let letseq prog ) ?control t ?rule_fun @@ -784,7 +608,7 @@ NAME is the message reference." ;; In `letseq` current environment is already available for next definitions (when (eq fun 'letseq) (setq envs (cons env envs))) (@nif (listp defs) - (@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase fun)) + (_\@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase fun)) (@str "`{fun}` first argument should be a list: {defs}")) ;; Define each variable in environment (let ( ( def_pos -1 ) @@ -799,11 +623,11 @@ NAME is the message reference." ( list (@nif (and (symbolp (car def)) (cdr def) (not (cddr def))) ;; Definition is wrong, report it - (@lint_msg sexp messages (constar def_pos 1 levels) 'ERROR (concat 'SYNTAX_ (upperCase fun) '_BINDING) + (_\@lint_msg sexp messages (constar def_pos 1 levels) 'ERROR (concat 'SYNTAX_ (upperCase fun) '_BINDING) (@str "`{fun}` binding must be a symbol or symbol-value pair: {def}")) (setq name (car def)) ;; Check variable definition - (@lint_sexp (cadr def) messages + (_\@lint_sexp (cadr def) messages (constar 1 def_pos 1 levels ) (constar def defs sexp parents) envs scheme @@ -811,20 +635,20 @@ NAME is the message reference." ));nif ;list (t ;; Variable definition should be a symbol or a symbol-value pair - (@lint_msg sexp messages (constar def_pos 1 levels) 'ERROR (concat 'SYNTAX_ (upperCase fun) '_BINDING) + (_\@lint_msg sexp messages (constar def_pos 1 levels) 'ERROR (concat 'SYNTAX_ (upperCase fun) '_BINDING) (@str "`{fun}` binding must be a symbol or symbol-value pair: {def}")) ));t ;caseq ;; Add variable to env ;; Report superseded variable (when (and (symbolp name) (neq '_ (getchar name 1)) (exists env envs env[name])) - (@lint_msg sexp messages (constar def_pos 1 levels) 'WARNING (concat (upperCase fun) '_SUPERSEDE) + (_\@lint_msg sexp messages (constar def_pos 1 levels) 'WARNING (concat (upperCase fun) '_SUPERSEDE) (@str "`{fun}` variable {name} is superseded") )) ;; Report two variables having the same name in the same let (cond ( (not name) ) ( env[name] - (@lint_msg sexp messages (constar def_pos 1 levels) 'WARNING (concat (upperCase fun) '_UNREACHABLE_VAR) + (_\@lint_msg sexp messages (constar def_pos 1 levels) 'WARNING (concat (upperCase fun) '_UNREACHABLE_VAR) (@str "`{fun}` another variable is already called {name}")) ) (t (setf env[name] (list nil 'status 'unused)) ) ) @@ -832,10 +656,10 @@ NAME is the message reference." (push env envs) ;; Check body (foreach sub_sexp body - (@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) + (_\@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) ) ;; Check unused variables - (@lint_resolve_env sexp messages levels env) + (_\@lint_resolve_env sexp messages levels env) );nif ));let ;dbind ));t ;cond @@ -845,14 +669,14 @@ NAME is the message reference." ;; `set` & `setq` ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( set setq ) ?control t ?rule_fun (lambda ( sexp messages levels parents envs scheme ) (unless (errset - (destructuringBind (fun name value) sexp + (destructuringBind ( fun name value @optional ( env '__UNDEFINED__ ) ) sexp (cond ;; Treat `setq` and (set (quote ) ...) the same way ( (or (eq fun 'setq) @@ -868,16 +692,26 @@ NAME is the message reference." ;; Assigned is a special status where variable appears as used but is in fact "only-assigned" (when (eq 'unused (car res_envs)[name]->status) (setf (car res_envs)[name]->status 'assigned)) - (@lint_msg sexp messages levels 'WARNING 'GLOBAL (@str "`{fun}` global definition: {name}")) - ) + (cond + ;; SKILL definition + ( (and (not scheme) (eq env '__UNDEFINED__)) + (_\@lint_msg sexp messages levels 'WARNING 'GLOBAL (@str "`{fun}` global definition: {name}")) + ) + ;; Function defintion + ( (and (listp value) (symbolp (car value)) (memq (@output (car value)) '( function funobj callable ))) + (_\@lint_msg sexp messages levels 'WARNING 'GLOBAL (@str "`{fun}` global function definition: {name}")) + ) + ;; Scheme definition + ( t (_\@lint_msg sexp messages levels 'WARNING 'GLOBAL (@str "`{fun}` global scheme definition: {name}")) ) + )) ;; Check value - (@lint_sexp value messages (cons 2 levels) (cons sexp parents) envs scheme) + (_\@lint_sexp value messages (cons 2 levels) (cons sexp parents) envs scheme) ) ;; Apply default rule otherwise - (t (@lint_default_rule sexp messages levels parents envs scheme)) + (t (_\@lint_default_rule sexp messages levels parents envs scheme)) ));cond ;dbind nil);errset - (@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase (car sexp))) + (_\@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase (car sexp))) (@str "`{(car sexp)}` syntax must be ({(car sexp)} )")) ) )) @@ -886,7 +720,7 @@ NAME is the message reference." ;; Functions definition ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( define procedure globalProc defun defglobalfun defmacro defmethod lambda ) ?control t ?rule_fun @@ -907,19 +741,26 @@ NAME is the message reference." (cond ;; Wrong syntax ( (or (not (cdr args)) (cddr args)) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_DEFINE + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_DEFINE (@str "`{fun}` syntax must be ({fun} ) or ({fun} ( ... ) ...)") ) (return) ) ;; Local variable - ;; In SKILL, `define` can only be used to define global functions ( (and scheme (tablep (car envs))) (setf (car envs)[name] (list nil 'status 'unused)) ) ;; Global variable - ( t (@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global definition: {name}")) ) - ) + ;; In SKILL, `define` can only be used to define global functions + ( t + (if (and (listp (cadr args)) + (symbolp (caadr args)) + (memq (@output (caadr args)) '( function funobj callable )) + ) + (_\@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global function definition: {name}")) + (_\@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global definition: {name}")) + )) + );cond ;; Check assigned value S-expression - (@lint_sexp (cadr args) messages (cons 2 levels) (cons sexp parents) envs scheme) + (_\@lint_sexp (cadr args) messages (cons 2 levels) (cons sexp parents) envs scheme) (return) ) @@ -930,7 +771,7 @@ NAME is the message reference." (cdr args) ) ;; Invalid syntax - (@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase fun)) + (_\@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase fun)) (@str "`{fun}` syntax must be ({fun} ( ... ) ...)") ) (return) @@ -968,7 +809,7 @@ NAME is the message reference." )) ) ;; Invalid syntax - (@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase fun)) + (_\@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase fun)) (@str "`{fun}` syntax must be ({fun} ( ... ) ...)") ) (return) @@ -1006,7 +847,7 @@ NAME is the message reference." (unless (and (listp (car args)) (cdr args) ) - (@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase fun)) + (_\@lint_msg sexp messages levels 'ERROR (concat 'SYNTAX_ (upperCase fun)) (@str "`{fun}` syntax must be ({fun} ( ... ) ...)") ) (return) @@ -1026,21 +867,27 @@ NAME is the message reference." ;; Check if function supersedes another one (when (and name (exists env envs (and (tablep env) env[name]))) (unless (and (eq fun 'defmethod) (isGeneric name)) - (@lint_msg sexp messages levels 'WARNING (concat (upperCase fun) '_SUPERSEDE) + (_\@lint_msg sexp messages levels 'WARNING (concat (upperCase fun) '_SUPERSEDE) (@str "`{fun}` variable {name} is superseded") ))) ;; Define variable (cond ( (not name) (assert (eq fun 'lambda) "Only `lambda` should not be defining a variable") ) ( (tablep (car envs)) - (@nif (memq fun '( globalProc defglobalfun defmacro defmethod )) - ;; Definition is local only - (setf (car envs)[name] (list nil 'status 'unused 'type 'function)) - ;; Definition is local and global - (setf (car envs)[name] (list nil 'status 'global)) - (@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global definition: {name}")) + (cond + ( (or (not scheme) + (memq fun '( globalProc defglobalfun defmacro defmethod )) + ) + ;; Definition is local and global + (setf (car envs)[name] (list nil 'status 'global)) + (_\@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global function definition: {name}")) + ) + ( t + ;; Definition is local only + (setf (car envs)[name] (list nil 'status 'unused 'type 'function)) + ) )) - ( t (@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global definition: {name}")) ) + ( t (_\@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global function definition: {name}")) ) );cond ;; Make sure bindings syntax is valid, define new_env using bindings @@ -1059,7 +906,7 @@ NAME is the message reference." (symbolp (cadr binding)) (not (cddr binding)) ) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_DEFMETHOD + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_DEFMETHOD "`defmethod` syntax is (defmethod ( ( ) ... ) ...)") (setf env[(car binding)] (list nil 'status 'unused)) ))) @@ -1075,7 +922,7 @@ NAME is the message reference." ( (and (listp binding) (symbolp (car binding)) (cdr binding) (not (cddr binding))) (setq arg_name (car binding)) ;; Check default value - (@lint_sexp (cadr binding) messages + (_\@lint_sexp (cadr binding) messages (constar 1 binding_pos bindings_levels) (constar binding bindings sexp parents) (if scheme (cons env envs) envs) @@ -1087,13 +934,13 @@ NAME is the message reference." ) ( t - (@lint_msg sexp messages (constar binding_pos bindings_levels) 'ERROR (concat 'SYNTAX_ (upperCase fun) '_BINDING) + (_\@lint_msg sexp messages (constar binding_pos bindings_levels) 'ERROR (concat 'SYNTAX_ (upperCase fun) '_BINDING) (@str "`{fun}` binding must be a symbol or symbol-value pair: {binding}")) ));t ;cond (cond ( (not arg_name) ) ( env[arg_name] - (@lint_msg sexp messages (constar binding_pos bindings_levels) 'WARNING (concat (upperCase fun) '_UNREACHABLE_VAR) + (_\@lint_msg sexp messages (constar binding_pos bindings_levels) 'WARNING (concat (upperCase fun) '_UNREACHABLE_VAR) (@str "`{fun}` another argument is already called {arg_name}")) ) ( t (setf env[arg_name] (list nil 'status 'unused)) ) ) @@ -1102,14 +949,14 @@ NAME is the message reference." (and name (neq 'defmacro fun) (not (stringp (car body))) - (@lint_msg sexp messages levels 'WARNING 'MISSING_DOCSTRING (@str "`{fun}` {name} has no docstring")) + (_\@lint_msg sexp messages levels 'WARNING 'MISSING_DOCSTRING (@str "`{fun}` {name} has no docstring")) ) ;; Check body (foreach sub_sexp body - (@lint_sexp sub_sexp messages (cons body_pos++ levels) (cons sexp parents) (cons env envs) scheme) + (_\@lint_sexp sub_sexp messages (cons body_pos++ levels) (cons sexp parents) (cons env envs) scheme) );foreach ;; Check unused variables - (@lint_resolve_env sexp messages levels env) + (_\@lint_resolve_env sexp messages levels env) );let );prog )) @@ -1119,7 +966,7 @@ NAME is the message reference." ;; foreach ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( foreach ) ?control t ?rule_fun @@ -1138,21 +985,21 @@ NAME is the message reference." ( (symbolp (car body)) (setq names (list (car body))) ) ( (and (listp (car body)) (forall name (car body) (symbolp name))) (setq names (car body)) ) ( t - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_FOREACH (@str "`{fun}` syntax is (foreach [map_fun] ...)")) + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_FOREACH (@str "`{fun}` syntax is (foreach [map_fun] ...)")) (return) )) (progn (pop body) sexp_pos++) ;; Parse list definitions (setq env (makeTable t nil)) (foreach name names - (@lint_sexp (pop body) messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) + (_\@lint_sexp (pop body) messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) (setf env[name] (list 'status 'unused)) ) ;; Parse body (foreach sub_sexp body - (@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) (cons env envs) scheme) + (_\@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) (cons env envs) scheme) ) - (@lint_resolve_env sexp messages levels env) + (_\@lint_resolve_env sexp messages levels env) ) )) @@ -1160,7 +1007,7 @@ NAME is the message reference." ;; for ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( for ) ?control t ?rule_fun @@ -1174,16 +1021,16 @@ NAME is the message reference." ( sexp_pos 2 ) ) (unless (symbolp var) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_FOR (@str "`{fun}` syntax is (for ...)")) + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_FOR (@str "`{fun}` syntax is (for ...)")) (return) ) (setf env[var] (list 'status 'unused)) - (@lint_sexp beg messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) - (@lint_sexp end messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) + (_\@lint_sexp beg messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) + (_\@lint_sexp end messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) (foreach sub_sexp body - (@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) (cons env envs) scheme) + (_\@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) (cons env envs) scheme) ) - (@lint_resolve_env sexp messages levels env) + (_\@lint_resolve_env sexp messages levels env) ) )) @@ -1198,7 +1045,7 @@ NAME is the message reference." ;; inScheme, inSkill & dynamic ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( inSkill inScheme ) ?control t ?rule_fun @@ -1206,18 +1053,18 @@ NAME is the message reference." (let ( ( pos 1 ) ) (foreach sub_sexp (cdr sexp) - (@lint_sexp sub_sexp messages (cons pos++ levels) (cons sexp parents) envs (@caseq (car sexp) ( inSkill nil ) ( inScheme t ))) + (_\@lint_sexp sub_sexp messages (cons pos++ levels) (cons sexp parents) envs (@caseq (car sexp) ( inSkill nil ) ( inScheme t ))) )) )) -(@lint_rule +(_\@lint_rule ?functions '( dynamic ) ?control t ?rule_fun (lambda ( sexp messages levels parents envs _scheme ) (@nif (symbolp (cadr sexp)) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_DYNAMIC (@str "`{(car sexp)}` argument should be a symbol: {(cadr sexp)}")) - (@lint_sexp (cadr sexp) messages (cons 1 levels) (cons sexp parents) envs nil) + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_DYNAMIC (@str "`{(car sexp)}` argument should be a symbol: {(cadr sexp)}")) + (_\@lint_sexp (cadr sexp) messages (cons 1 levels) (cons sexp parents) envs nil) ) )) @@ -1225,27 +1072,20 @@ NAME is the message reference." ;; Unknown `status` or `sstatus` calls ;; ------------------------------------------------------- -;; This is required at least when running Lint from the SKILL Interpreter -;; Otherwise some valid statuses are reported as unknown -(@no_lint - (SK_RULE SK_CONTROL ( status sstatus ) (not (errset (funcall 'status (car (SK_ARGS))))) - (SK_ERROR UNKNOWN_STATUS_FLAG "Unknown (s)status flag: %N\n" (SK_FORM)) - )) - -(@lint_rule +(_\@lint_rule ?functions '( status sstatus ) ?control t ?rule_fun (lambda ( sexp messages levels parents @rest args ) ;; Static condition (unless (errset (funcall 'status (nth 1 sexp))) - (@lint_msg sexp messages levels 'WARNING 'STATUS_FLAG (@str "`{(car sexp)}` unknown flag: {(nth 1 sexp)}")) + (_\@lint_msg sexp messages levels 'WARNING 'STATUS_FLAG (@str "`{(car sexp)}` unknown flag: {(nth 1 sexp)}")) ) ;; Parse remaining arguments (let ( ( sexp_pos 2 ) ) (foreach sub_sexp (nthcdr 2 sexp) - (apply '@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) args) + (apply '_\@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) args) ));foreach ;let )) @@ -1254,7 +1094,7 @@ NAME is the message reference." ;; ------------------------------------------------------- ;; TODO - defclass is waived for now -(@lint_rule +(_\@lint_rule ?functions '( defclass @class ) ?control t ?rule_fun '@nil @@ -1264,7 +1104,7 @@ NAME is the message reference." ;; Anaphoric macros ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( @if @nif @when ) ?control t ?rule_fun @@ -1285,9 +1125,9 @@ NAME is the message reference." (setq sub_sexp (pop body)) (cond ( (eq '?var sub_sexp) sexp_pos++ (setq sub_sexp (pop body)) ) - ( t (@lint_sexp sub_sexp messages (cons sexp_pos levels) (cons sexp parents) envs scheme)) + ( t (_\@lint_sexp sub_sexp messages (cons sexp_pos levels) (cons sexp parents) envs scheme)) ));cond ;while - (when name (@lint_resolve_env sexp messages levels env)) + (when name (_\@lint_resolve_env sexp messages levels env)) );let )) @@ -1295,7 +1135,7 @@ NAME is the message reference." ;; With ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( @with ) ?control t ?rule_fun @@ -1308,7 +1148,7 @@ NAME is the message reference." ( env (makeTable t nil) ) ) (unless (listp bindings) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_WITH (@str "`{fun}` syntax is (@with ( ( ) ... ) ...)")) + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_WITH (@str "`{fun}` syntax is (@with ( ( ) ... ) ...)")) (return) ) ;; Parse bindings @@ -1317,18 +1157,18 @@ NAME is the message reference." (cdr binding) (not (cddr binding)) ) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_WITH (@str "`{fun}` syntax is (@with ( ( ) ... ) ...)")) + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_WITH (@str "`{fun}` syntax is (@with ( ( ) ... ) ...)")) (return) ) - (@lint_sexp (cadr binding) messages (constar 1 binding_pos++ sexp_pos++ levels) (constar binding bindings sexp parents) (cons env envs) scheme) + (_\@lint_sexp (cadr binding) messages (constar 1 binding_pos++ sexp_pos++ levels) (constar binding bindings sexp parents) (cons env envs) scheme) (setf env[(car binding)] (list nil 'status 'unused)) ) sexp_pos++ ;; Parse body (foreach sub_sexp body - (@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) (cons env envs) scheme) + (_\@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) (cons env envs) scheme) ) - (@lint_resolve_env sexp messages levels env) + (_\@lint_resolve_env sexp messages levels env) );prog )) @@ -1336,7 +1176,7 @@ NAME is the message reference." ;; Wrap ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( @wrap ) ?control t ?rule_fun @@ -1344,10 +1184,10 @@ NAME is the message reference." (let ( ( sexp_pos 1 ) ) (unless (or (cadr sexp) (caddr sexp)) - (@lint_msg sexp messages levels 'INFO 'EXTRA_WRAP "`@wrap` without IN or OUT can be removed or replaced by `progn`") + (_\@lint_msg sexp messages levels 'INFO 'EXTRA_WRAP "`@wrap` without IN or OUT can be removed or replaced by `progn`") ) (foreach sub_sexp (cdr sexp) - (@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) + (_\@lint_sexp sub_sexp messages (cons sexp_pos++ levels) (cons sexp parents) envs scheme) )) )) @@ -1355,7 +1195,7 @@ NAME is the message reference." ;; Fun ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( @fun ) ?control t ?rule_fun @@ -1370,14 +1210,14 @@ NAME is the message reference." sub_sexp ) (unless (and (symbolp name) (listp bindings)) - (@lint_msg sexp messages levels 'ERROR 'SYNTAX_FUN + (_\@lint_msg sexp messages levels 'ERROR 'SYNTAX_FUN "`@fun` syntax is (@fun ( ( [?def ] [?type ] ... ) ... ) ?doc ...)") (return) ) ;; Check if function supersedes another one (when (and name (exists env envs (and (tablep env) env[name]))) - (@lint_msg sexp messages levels 'WARNING (concat (upperCase fun) '_SUPERSEDE) + (_\@lint_msg sexp messages levels 'WARNING (concat (upperCase fun) '_SUPERSEDE) (@str "`{fun}` variable {name} is superseded") )) ;; Define variable @@ -1388,9 +1228,9 @@ NAME is the message reference." (setf (car envs)[name] (list nil 'status 'unused 'type 'function)) ;; Definition is local and global (setf (car envs)[name] (list nil 'status 'global 'type 'function)) - (@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global definition: {name}")) + (_\@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global definition: {name}")) )) - ( t (@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global definition: {name}")) ) + ( t (_\@lint_msg sexp messages levels 'INFO 'GLOBAL (@str "`{fun}` global definition: {name}")) ) );cond ;; Parse bindings @@ -1399,7 +1239,7 @@ NAME is the message reference." (cond ( (memq binding '( @key @rest _ )) nil ) ( (not (and (listp binding) (symbolp (car binding)))) - (@lint_msg sexp messages (cons binding_pos levels) 'ERROR 'SYNTAX_FUN + (_\@lint_msg sexp messages (cons binding_pos levels) 'ERROR 'SYNTAX_FUN (@str "`{fun}` binding format is ( [?def ] [?type ] ... ): {binding}") ) (return) @@ -1423,12 +1263,12 @@ NAME is the message reference." ( (memq sub_sexp '( ?def ?doc )) nil ) ;; Binding is ?... ( (and (symbolp sub_sexp) (eq '? (getchar sub_sexp 1))) - (@lint_msg sexp messages (cons binding_pos levels) 'INFO 'EXTRA_KEY_ARG + (_\@lint_msg sexp messages (cons binding_pos levels) 'INFO 'EXTRA_KEY_ARG (@str "`{fun}` extra key argument {sub_sexp} in binding {binding}") )) (t ;; Parse sexp - (@lint_sexp sub_sexp messages + (_\@lint_sexp sub_sexp messages (constar pos binding_pos sexp_pos levels ) (constar binding bindings sexp parents) (if scheme (cons env envs) env) @@ -1452,9 +1292,9 @@ NAME is the message reference." ) ( (memq sub_sexp '( ?doc ?global ?memoize )) nil ) ;; Parse any other sexp - ( t (@lint_sexp sub_sexp messages (cons sexp_pos levels) (cons sexp parents) (cons env envs) scheme)) + ( t (_\@lint_sexp sub_sexp messages (cons sexp_pos levels) (cons sexp parents) (cons env envs) scheme)) ));cond ;while - (@lint_resolve_env sexp messages levels env) + (_\@lint_resolve_env sexp messages levels env) );prog )) @@ -1462,7 +1302,7 @@ NAME is the message reference." ;; Debugging functions ;; ------------------------------------------------------- -(@lint_rule +(_\@lint_rule ?functions '( break breakpt breakptMethod clear cont continue count debugQuit debugStatus dump @@ -1483,7 +1323,7 @@ NAME is the message reference." ) ?rule_fun (lambda ( sexp messages levels @rest _ ) - (@lint_msg sexp messages levels (if (@get_debug) 'INFO 'WARNING) 'DEBUGGING + (_\@lint_msg sexp messages levels (if (@get_debug) 'INFO 'WARNING) 'DEBUGGING (@str "`{(car sexp)}` debugging function should not be used in production") )) ) @@ -1497,12 +1337,19 @@ NAME is the message reference." (@fun @lint ( @key - ( files ?type ( string ... ) ) - ( info_port ?type port ?def (@poport) ) - ( warn_port ?type port ?def (@errport) ) - ( err_port ?type port ?def (@errport) ) + ( files ?type ( string ... ) ) + ( info_port ?type port ?def (@poport) ) + ;; warn_port defaults to stderr using SKILL Interpreter but woport otherwise + ( warn_port ?type port ?def (if (eq (@poport) (@woport)) (@errport) (@woport)) ) + ( err_port ?type port ?def (@errport) ) + ( filters + ?type ( symbol ... )|nil + ?def (mapcar 'concat (parseString (or (getShellEnvVar "SKILL_SHARP_LINT_FILTERS") "") ",")) + ?doc "Only print infos, warnings and errors that matches exactly words in this comma-separated value" + ) ( ignores - ?type ( symbol ... ) + ;; TODO - Type checking should be ok when ( ... ) is an empty list + ?type ( symbol ... )|nil ?def (mapcar 'concat (parseString (or (getShellEnvVar "SKILL_SHARP_LINT_HIDE_IGNORES") "") ",")) ?doc "Waive infos, warnings and errors whose names matches exactly words in this comma-separated value" ) @@ -1511,6 +1358,11 @@ NAME is the message reference." ?def (equal "TRUE" (getShellEnvVar "SKILL_SHARP_LINT_HIDE_SEXPS")) ?doc "Do not print S-expressions where error occured" ) + ( no_header + ?type t|nil + ?def nil + ?doc "When non-nil, header and output status are omitted." + ) ) ?doc "Run Sharper Lint on FILES. All report messages are printed to PORT." @@ -1523,8 +1375,9 @@ All report messages are printed to PORT." (let ( ( results_by_file (tconc nil nil) ) ( lint_status t ) ) - (@letf ( ( (status optimizeTailCall) t ) - ( @str.pretty t ) + (@letf ( ( (status debugMode ) nil ) + ( (status optimizeTailCall) t ) + ( @str.pretty t ) ) (foreach file files (let ( ( in_port (infile file) ) @@ -1547,7 +1400,7 @@ All report messages are printed to PORT." ( sexp_pos 0 ) ) (foreach sexp sexps - (@lint_sexp sexp messages (list sexp_pos++) sexps nil scheme) + (_\@lint_sexp sexp messages (list sexp_pos++) sexps nil scheme) );foreach (setq messages (cdar messages)) ;; Filter messages whose predicate does not pass @@ -1571,9 +1424,9 @@ All report messages are printed to PORT." ;; ------------------------------------------------------- ;; Format messages in a nice report ;; ------------------------------------------------------- - (@fprintf info_port "Running Lint - {(getCurrentTime)}\n") + (unless no_header (@fprintf info_port "Running Lint - {(getCurrentTime)}\n")) (@foreach_dbind ( file res ) (cdar results_by_file) - (@fprintf info_port "File {file}:\n") + (unless no_header (@fprintf info_port "File {file}:\n")) (@foreach_dbind ( _beg_pos ( _beg_line _end_line ) messages ) res ;; No need to print where top-level S-expressions are found ;; Only the info, warnings and errors matter @@ -1583,22 +1436,25 @@ All report messages are printed to PORT." ; (@fprintf info_port " Top-level S-Expression at lines {beg_line} - {(sub1 end_line)}:\n") ; )) (@foreach_dbind ( type name line text sexp ) messages - (unless (memq name ignores) - (let ( port ) - (@caseq type - ( INFO (setq port info_port) ) - ( WARNING (setq port warn_port) (setq lint_status nil) ) - ( ERROR (setq port err_port ) (setq lint_status nil) ) - );caseq - (if (or hide_sexps (eq 'GLOBAL name)) - (@fprintf port " {type%7s} {name%s} at line {line%-3d} - {text}\n") - (@fprintf port " {type%7s} {name%s} at line {line%-3d} - {text} - {sexp}\n") - ));if ;let - ));unless ;foreach_dbind message - );foreach_dbind lines - (newline info_port) + (cond + ( (memq name ignores) ) + ( (and filters (not (memq name filters))) ) + ( t + (let ( port ) + (@caseq type + ( INFO (setq port info_port) ) + ( WARNING (setq port warn_port) (setq lint_status nil) ) + ( ERROR (setq port err_port ) (setq lint_status nil) ) + );caseq + (if (or hide_sexps (eq 'GLOBAL name)) + (@fprintf port " {type%7s} {name%s} at line {line%-3d} - {text}\n") + (@fprintf port " {type%7s} {name%s} at line {line%-3d} - {text} - {sexp}\n") + ));if ;let + ));t ;cond + ));foreach_dbind message ;foreach_dbind lines + (unless no_header (newline info_port)) );foreach_dbind file - (println (if lint_status 'PASS 'FAIL)) + (unless no_header (println (if lint_status 'PASS 'FAIL) info_port)) ;; Return status lint_status );letf diff --git a/skill/autoloaded/script.scm b/skill/autoloaded/script.scm index 54f6923..89a9204 100755 --- a/skill/autoloaded/script.scm +++ b/skill/autoloaded/script.scm @@ -8,7 +8,7 @@ ;; A. Buchet - April 2025 ;; =============================================================================================================== -(setf @skill.exit_status 0) +(@no_lint (setf @skill.exit_status 0)) (@fun @exit ( ( status ?type integer ?def @skill.exit_status ) @@ -29,10 +29,10 @@ (let ( ( description "*UNDEFINED* (please use `@script_set_description')" ) ( version "??? (please use `@script_set_version')" ) - ( arguments_by_name (makeTable t nil) ) - ( arguments_by_key (makeTable t nil) ) - ( positional_arguments (tconc nil nil) ) - ( argument_count 0 ) + ( arguments_by_name (makeTable t nil) ) + ( arguments_by_key (makeTable t nil) ) + ( positional_arguments (tconc nil nil) ) + ( argument_count 0 ) ) ;; ------------------------------------------------------- @@ -76,8 +76,8 @@ ?out t|nil ?global t ;; This is equivalent to Python (__name__ == '__main__') - (equal (@realpath (get_filename (@piport)) ) - (@realpath (argv 0) ) + (equal (@realpath (get_filename (@piport)) ) + (@realpath (or (argv 0) (car (last (getShellArgs)))) ) )) (@fun deduce_name @@ -385,12 +385,12 @@ A positional required argument (i.e. without ?default) cannot be defined after a );closure ;; Add `setf' helpers -(define setf_\@script_get_description (getd '@script_set_description)) -(define setf_\@script_get_version (getd '@script_set_version )) +(define setf_\@script_get_description (@getd '@script_set_description)) +(define setf_\@script_get_version (@getd '@script_set_version )) ;; Fix lint warnings -(define setf_\\\@script_get_description (getd '@script_set_description)) -(define setf_\\\@script_get_version (getd '@script_set_version )) +(define setf_\\\@script_get_description (@getd '@script_set_description)) +(define setf_\\\@script_get_version (@getd '@script_set_version )) (setf (fdoc 'setf_\@script_get_description ) "`setf' helper for `@script_get_description'") (setf (fdoc 'setf_\\\@script_get_description) "`setf' helper for `@script_get_description'") diff --git a/skill/autoloaded/ui.scm b/skill/autoloaded/ui.scm index 5b99b2d..e0c2a51 100644 --- a/skill/autoloaded/ui.scm +++ b/skill/autoloaded/ui.scm @@ -63,6 +63,7 @@ (@fun @color_field ( @key + ( name ?type symbol ) ( tech_files ?type ( tech_file ... ) ?def (@tech_files) ) @rest ( args ) ) @@ -70,6 +71,7 @@ Except for ?choices all arguments are inherited from `hiCreateCyclicField'." ?out field (apply 'hiCreateCyclicField + ?name name ?choices (foreach mapcar color (@get_available_colors ?tech_files tech_files ?sorted t ?unique t) (list color (@color_icon color))) diff --git a/skill/functional.scm b/skill/functional.scm index ec7ff67..fe42309 100644 --- a/skill/functional.scm +++ b/skill/functional.scm @@ -4,6 +4,12 @@ ;; A. Buchet - April 2025 ;; =============================================================================================================== +(@fun @getd ( ( name ?type symbol ) ) + ?doc "`getd` wrapper to guarantee output type." + ?out callable + (or (getd name) (@error "@getd - Unable to retrieve function named {name}")) + ) + (@fun @nil ( @rest _ ) ?doc "Always return nil." ?out nil @@ -52,7 +58,7 @@ See reference : https://en.wikipedia.org/wiki/Fold_(higher-order_function)" ?global t ;; Make sure tail-call optimization is enabled - (@letf ( ( (status optimizeTailCall) t ) + (@letf ( ( (status optimizeTailCall) (not (status debugMode)) ) ) (rec function (car list) (cdr list)) )) @@ -80,13 +86,19 @@ See reference : https://en.wikipedia.org/wiki/Fold_(higher-order_function)" ?doc "`@queue' helper to be called inside `hiEnqueueCmd'." ?out t ?global t - (while (cdar queue) - (@if (cddar queue) (funcall (popf (cdar queue))) - ;; Prevent queue from becoming empty and breaking tconc structure - (tconc queue nil) - (assert (not (popf (car queue))) "_\\@queue - A non-nil object was removed from queue...") - (funcall (popf (car queue))) - )) + (unless + (errset + (while (cdar queue) + (@if (cddar queue) (funcall (popf (cdar queue))) + ;; Prevent queue from becoming empty and breaking tconc structure + (tconc queue nil) + (assert (not (popf (car queue))) "_\\@queue - A non-nil object was removed from queue...") + (funcall (popf (car queue))) + )) + t) + ;; Restore queue in case an error occured + (setq queue (tconc nil nil)) + ) ;; Always return t t) diff --git a/skill/globals.il b/skill/globals.il index a456b8a..fbaa822 100755 --- a/skill/globals.il +++ b/skill/globals.il @@ -14,8 +14,11 @@ ;; Make sure stdin is not polluted when loading the target file (setf __globals__.poport (progn "NO_LINT" poport)) +(setf __globals__.woport (progn "NO_LINT" woport)) (setguard 'poport (lambda _ (outfile "/dev/null"))) +(setguard 'woport (lambda _ (outfile "/dev/null"))) (progn "NO_LINT" (setq poport nil)) +(progn "NO_LINT" (setq woport nil)) ;; Run before command (when (stringp (getShellEnvVar "SKILL_SHARP_BEFORE_COMMAND")) @@ -77,8 +80,11 @@ ;; Print difference between the two states (sstatus printinfix ()) -(foreach names (list __globals__.new_functions __globals__.new_variables __globals__.new_scheme __globals__.new_classes __globals__.new_symbols) - (println names __globals__.poport) +(foreach names (if (equal "TRUE" (getShellEnvVar "SKILL_SHARP_GLOBALS_SHOW_PROPS")) + (list __globals__.new_functions __globals__.new_variables __globals__.new_scheme __globals__.new_classes __globals__.new_symbols) + (list __globals__.new_functions __globals__.new_variables __globals__.new_scheme __globals__.new_classes) + ) + (println (sort names 'alphalessp) __globals__.poport) ) (exit 0) diff --git a/skill/init.scm b/skill/init.scm index 879887b..b12b21e 100644 --- a/skill/init.scm +++ b/skill/init.scm @@ -47,8 +47,8 @@ )) ;; Name / value pairs for global SKILL variables ( global_variables - '( ( tracelength ( nil on 50 off ,(and (boundp tracelength) (symeval 'tracelength)) ) ) - ( _stacktrace ( nil on 50 off ,(and (boundp _stacktrace) (symeval '_stacktrace)) ) ) + `( ( tracelength ( nil on 50 off ,(and (boundp 'tracelength) (symeval 'tracelength)) ) ) + ( _stacktrace ( nil on 50 off ,(and (boundp '_stacktrace) (symeval '_stacktrace)) ) ) )) ;; Debugging status ( debug_bool nil ) @@ -150,43 +150,27 @@ (rexMagic magic) ));unwindProtect ;let -(defun @realpath ( file "t" ) - "`simplifyFilename' wrapper to make it safe from `rexMagic' value." +(@fun @realpath + ( ( file ?type string ) + ( dont_resolve_links ?type general ?def nil ) + ) + ?doc "Expand variables and symlinks inside FILE path. +This is `simplifyFilename' wrapper to make it safe from `rexMagic' value." + ?out string (@letf ( ( (rexMagic) t ) ) - (simplifyFilename file) + (simplifyFilename file dont_resolve_links) )) - -;; ======================================================= -;; Read and write files -;; ======================================================= - -(defun @read_file ( path "t" ) - "Read file at PATH and return its content as a string." - (@with ( ( in_port (infile path) ) - ( out_port (outstring ) ) - ) - (let ( line ) (while (gets line in_port) (fprintf out_port "%s" line)));while ;let - (getOutstring out_port) - ));with ;def - -(defun @write_file ( path string @optional (mode "w") "ttt") - "Write STRING to file at PATH. - -(Arguments order is meant to match `fprintf' one)" - (@with ( ( port (outfile path mode) ) - ) - (fprintf port "%s" string) - ));with ;def - - ;; ======================================================= ;; Run Shell commands ;; ======================================================= -(defun @bash ( command "t" ) - "Run COMMAND using `bash` then return a list containing generated stdout, stderr and exit status." +(@fun @bash + ( ( command ?type string ) + ) + ?doc "Run COMMAND using `bash` then return a list containing generated stdout, stderr and exit status." + ?out ( string string integer ) ;; Writing everything to temporary files is not the most elegant way... ;; But it guarantees that input command is well understood ;; (even if it contains special characters like newline, single-quote or double-quote) @@ -321,7 +305,7 @@ If NO_RELOAD is non-nil, FILE is not re-loaded if already marked." ) (@letf ( ( (@poport) port ) ) - (@load (strcat skill_root "autoloaded/lint.scm")) + (@load (strcat skill_root "lint_rules.il")) (setq text (getOutstring port)) )) ;; Print remaining output while filtering 'INFO (LoadFile) lines' diff --git a/skill/legacy.scm b/skill/legacy.scm index f7333b0..2e97bbc 100644 --- a/skill/legacy.scm +++ b/skill/legacy.scm @@ -36,7 +36,13 @@ Warnings catched during evaluation can be fetched using `getMuffleWarnings'." (rexCompile "*WARNING*") (setq str (rexReplace str "¶" 0)) ) - (setq warnings (foreach mapcar warning (parseString str "¶") (strcat "*WARNING*" warning))) + (setq warnings + ;; Remove added warning in case it was printed before being catched + (foreach mapcon _warnings (parseString str "¶") + (unless (and (not (cdr _warnings)) (blankstrp (car _warnings))) + (list (strcat "*WARNING*" (car _warnings))) + )) + ) );when ;; This variable name is poorly chosen but at least it's consistent with errset.errset... (setf muffleWarnings.muffleWarnings warnings) @@ -51,12 +57,6 @@ Warnings catched during evaluation can be fetched using `getMuffleWarnings'." );unless -(unless (isCallable 'xor) - (@fun xor ( (e0) (e1) ) - ?doc "Returns the XOR value of the boolean inputs E0 and E1." - (and (or e0 e1) (not (and e0 e1)))) - );unless - ;; ======================================================= ;; Missing setf helpers ;; ======================================================= diff --git a/skill/lint_rules.il b/skill/lint_rules.il new file mode 100644 index 0000000..499797e --- /dev/null +++ b/skill/lint_rules.il @@ -0,0 +1,77 @@ +;; =============================================================================================================== +;; Custom Lint rules are defined here. +;; Having a dedicated file is much cleaner. +;; It can be loaded directly when using `sklint`. +;; Also SK_RULE macro almost never passes Lint +;; +;; A. Buchet - September 2025 +;; =============================================================================================================== + +;; ------------------------------------------------------- +;; Lint waiver +;; ------------------------------------------------------- + +{ "NO_LINT" + (SK_RULE SK_CONTROL ( @no_lint ) t nil) + } + +{ "NO_LINT" + (SK_RULE SK_CONTROL ( progn ) t + ;; Check `progn' first argument + (unless (equal "NO_LINT" (car (SK_ARGS))) + (foreach map sexp (SK_ARGS) (SK_CHECK_FORM sexp)) + )) + } + +;; ------------------------------------------------------- +;; (car (setof ...)) to replace by (car (exists ...)) +;; ------------------------------------------------------- + +{ "NO_LINT" + (SK_RULE ( setof ) (equal 'car (caar (SK_FORM 2))) + (SK_HINT CAR_SETOF "(car (setof ...)) should be replaced by (car (exists ...)): %N" (SK_FORM)) + ) + } + +;; ------------------------------------------------------- +;; Unknown `status` or `sstatus` calls +;; ------------------------------------------------------- + +;; This is required at least when running Lint from the SKILL Interpreter +;; Otherwise some valid statuses are reported as unknown +{ "NO_LINT" + (SK_RULE SK_CONTROL ( status sstatus ) (not (errset (funcall 'status (car (SK_ARGS))))) + (SK_ERROR UNKNOWN_STATUS_FLAG "Unknown (s)status flag: %N\n" (SK_FORM)) + ) + } + +;; ------------------------------------------------------- +;; Debugging functions +;; ------------------------------------------------------- + +{ "NO_LINT" + (SK_RULE ( break breakpt breakptMethod + clear cont continue count + debugQuit debugStatus dump + gcsummary getAllLoadedFiles getCallingFunction getFunctions getGFbyClass + ilAddTopLevelErrorHandler ilDebugCountLevels ilGetGFbyClass ilGetIdeSessionWindow ilGetTCovFiles ilMergeTCovData + ilRemoveMethod ilRemoveTopLevelErrorHandler ilSlotBoundp ilToolBox inNext inStepOut installDebugger + listAlias listFunctions listVariables + memoryAllocated + next + pp printFunctions printObject printstruct printVariables + removeMethod resume + skillDebugger skillDevStatus stacktrace step stepend stepout + toplevel tracef tracelevlimit tracelevunlimit tracep tracev + unbreakpt unbreakptMethod uncount uninstallDebugger untrace untracep untracev unwatch + watch where whereIs + ;; Custom + @show @print_args @print_table @runtime + ) + t + (SK_WARNING DEBUG_FUNCTIONS "%N debugging function should not be used in production" (car (SK_FORM))) + ) + } + +;*/ + diff --git a/skill/macros/class.scm b/skill/macros/class.scm index 57bdd2c..b226907 100644 --- a/skill/macros/class.scm +++ b/skill/macros/class.scm @@ -38,7 +38,7 @@ This is managed by default when using `@class'." ( slots ?type list ) ) ?doc "`@class' helper to generate builder function." - ?out symbol + ?out list (list ;; Define builder arglist, only for documentation purposes `(setf (@arglist ',builder_name) diff --git a/skill/macros/f-strings.scm b/skill/macros/f-strings.scm index 74b912a..0216b7e 100644 --- a/skill/macros/f-strings.scm +++ b/skill/macros/f-strings.scm @@ -5,8 +5,8 @@ ;; =============================================================================================================== (@fun @to_string - ( ( obj ?type any ?doc "Any S-expression to be returned as a string" ) - ( spec ?type string ?def "%N" ?doc "Format specification as described in `fprintf' documentation." ) + ( ( obj ?type any ?doc "Any S-expression to be returned as a string" ) + ( spec ?type string|nil ?def nil ?doc "Format specification as described in `fprintf' documentation." ) ) ?doc "Return OBJ as a string (like `printself'). If OBJ is already a string, it is returned as is. @@ -17,9 +17,12 @@ Those double-quotes are easily added by hand when required while removing afterw This design choice is also consistent with Python's f-strings." ?out string (cond - ( (stringp obj) obj ) - ( (and (listp obj) @str.pretty ) (@pretty_print obj) ) - ( t (lsprintf spec obj) ) + ( spec (lsprintf spec obj) ) + ( (stringp obj) obj ) + ;; Fix backslashes when printing symbols + ( (symbolp obj) (strcat obj) ) + ( (and (listp obj) @str.pretty ) (@pretty_print obj) ) + ( t (lsprintf (or spec "%N") obj) ) ));cond ;fun (let ( in out args char translate error_message ) @@ -62,7 +65,7 @@ A %s is printed to output port, while read string is added to S-expressions to e ;; Any other character to translate, ;; read the whole block ( t - (let ( ( format_spec "%N" ) + (let ( ( format_spec nil ) sexp_str sexp ) diff --git a/skill/macros/function.scm b/skill/macros/function.scm index 6f1e560..3435216 100644 --- a/skill/macros/function.scm +++ b/skill/macros/function.scm @@ -145,7 +145,7 @@ ,@(when global `( ( when (theEnvironment) ( putd ',name ,name) ) )) (setf (@arglist ',name) ',args) (setf (@fdoc ',name) ',doc ) - (setf (@out ',name) ',out ) + (setf (@output ',name) ',out ) );prog1 ));let ;fun @@ -180,6 +180,7 @@ Return nil otherwise." )) (@type_add 'any (lambda ( _obj ) t) ) + (@type_add 'general (lambda ( _obj ) t) ) (@type_add 'callable 'isCallable ) ;(@type_add 'boolean 'booleanp ) t|nil is more explicit than boolean (@type_add 'stdobj (lambda ( obj ) (classp obj 'standardObject)) ) @@ -190,6 +191,19 @@ Return nil otherwise." (@type_add 'ptrnum (lambda ( obj ) (eq 'ptrnum (type obj))) ) + (@type_add 'tconc + (lambda ( obj ) + (and + (listp obj) + (listp (car obj)) + (cdr obj) + (not (cddr obj)) + ;; This is the right test to guarantee that a `tconc` structure is valid + ;; But it implies browsing the whole list... (disabled for now) + ;; TODO - Maybe a variable to enable this test could be nice + ;(eq (last (car obj)) (cdr obj)) + ))) + (when (isCallable 'windowp) (@type_add 'window 'windowp)) (when (isCallable 'dbIsId ) diff --git a/skill/macros/macro.scm b/skill/macros/macro.scm index 7b89b64..0247c36 100644 --- a/skill/macros/macro.scm +++ b/skill/macros/macro.scm @@ -144,18 +144,18 @@ ;; (otherwise `fdoc' gets overwritten) ;; ------------------------------------- - (defglobalfun @out ( fun "u" ) + (defglobalfun @output ( fun "u" ) "Return FUN arguments list." - ;; TODO - @out should work with macros + ;; TODO - @output should work with macros (let ( (name (get_name fun)) ) - (when (symbolp name) (get name '@out)) + (when (symbolp name) (get name '@output)) ));let ;def - (defglobalfun setf_\@out ( args fun "gs" ) + (defglobalfun setf_\@output ( args fun "gs" ) "Set ARGS as FUN arguments list." - ;; TODO - setf_\@out should work with macros - (setf (get fun '@out) args) + ;; TODO - setf_\@output should work with macros + (setf (get fun '@output) args) ) );closure @@ -164,11 +164,11 @@ ;; The comparison works with double escape (contact Cadence support) (define setf_\\\@arglist (getd 'setf_\@arglist)) (define setf_\\\@fdoc (getd 'setf_\@fdoc )) -(define setf_\\\@out (getd 'setf_\@out )) +(define setf_\\\@output (getd 'setf_\@output )) (setf (fdoc 'setf_\\\@arglist) "`setf' helper for `@arglist'") (setf (fdoc 'setf_\\\@fdoc ) "`setf' helper for `@fdoc'" ) -(setf (fdoc 'setf_\\\@out ) "`setf' helper for `@out'" ) +(setf (fdoc 'setf_\\\@output ) "`setf' helper for `@output'" ) (setf (@fdoc '@macro) "`defmacro' wrapper, mostly for documentation purposes.") diff --git a/skill/macros/patterns.scm b/skill/macros/patterns.scm index c5b3ee7..87f1d24 100644 --- a/skill/macros/patterns.scm +++ b/skill/macros/patterns.scm @@ -4,6 +4,10 @@ ;; A. Buchet - July 2025 ;; =============================================================================================================== +(@macro @no_lint ( @rest body ) + "Lint waiver, equivalent to `progn'." + (constar 'progn "NO_LINT" body)) + ;; ======================================================= ;; Debugging macro ;; ======================================================= @@ -112,8 +116,11 @@ temporary value becomes permanent.) (list `(let ( ( __\@letf_var__ ,(car def) ) ) + ;; `setf` call is placed here, if it fails, the value should not be set + ;; And this is required so `status optimizeTailCall` can be used within `@letf` + (@setf ,(car def) ,(cadr def)) (unwindProtect - (progn (setf ,(car def) ,(cadr def)) ,@(_\@letf (cdr defs) body)) + (progn ,@(_\@letf (cdr defs) body)) (@setf ,(car def) __\@letf_var__) ))) );let @@ -161,10 +168,10 @@ See also `@wrap' and `@with' for context management." `(let ( ( ,(car def) ,(cadr def) ) ) (unwindProtect - (progn (@in ,(car def)) ,@(_\@with (cdr defs) body)) - ;; TODO - Should we asser that `@out' output is non-nil? + (progn (_\@in ,(car def)) ,@(_\@with (cdr defs) body)) + ;; TODO - Should we assert that `_\@out' output is non-nil? ;; This might help detect cases where a cellview cannot be closed for instance - (@out ,(car def)) + (_\@out ,(car def)) ))) );let ;; No other definition, return body @@ -174,12 +181,12 @@ See also `@wrap' and `@with' for context management." (@macro @with ( defs @rest body ) "Assign DEFS variable-value pairs, like `let' would do, but wrap BODY in a context manager: -1. Call `@in' method for each defined variable. +1. Call `_\\@in' method for each defined variable. 2. Run BODY S-expressions. -3. Call `@out' method for each defined variable. (This step occurs whatever happended in 1. or 2.) +3. Call `_\\@out' method for each defined variable. (This step occurs whatever happended in 1. or 2.) 4. Return final BODY evaluation result. -`@in' and `@out' methods are meant to be redefined for unsupported or custom classes. +`_\\@in' and `_\\@out' methods are meant to be redefined for unsupported or custom classes. They take one positional argument, which is the object being managed. This is inspired by Python `with` context manager. @@ -202,11 +209,11 @@ See also `@wrap' and `@with' for context management." ;; Ports ;; ------------------------------------- -(defmethod @in ( ( _obj port ) @rest _ ) +(defmethod _\@in ( ( _obj port ) @rest _ ) "Context manager when opening a port, nothing to do..." nil) -(defmethod @out ( ( obj port ) @rest _ ) +(defmethod _\@out ( ( obj port ) @rest _ ) "Context manager when releasing a port" (close obj)) @@ -218,11 +225,11 @@ See also `@wrap' and `@with' for context management." ;; Avoid warnings when running with SKILL Interpreter or cdsmps (when (findClass 'dbobject) - (defmethod @in ( ( _obj dbobject ) @rest _ ) + (defmethod _\@in ( ( _obj dbobject ) @rest _ ) "Context manager when opening a dbobject, nothing to do..." nil) - (defmethod @out ( ( obj dbobject ) @rest _ ) + (defmethod _\@out ( ( obj dbobject ) @rest _ ) "Context manager when releasing a dbobject." (@case obj->objType ( "cellView" (dbClose obj)) diff --git a/skill/sharp.scm b/skill/sharp.scm index 57f07d7..5f6016a 100755 --- a/skill/sharp.scm +++ b/skill/sharp.scm @@ -48,7 +48,7 @@ (let ( ( commands (makeTable t nil) ) ) - (@fun @sharp_run_command + (@fun _\@sharp_run_command ( ( name ?type string ) ( args ?type (string ...) ) ) @@ -96,8 +96,29 @@ (add_command "test" (lambda ( @rest args ) (@debug "Running Test on {args}") - ;; Load SKILL and test files, then run tests and exit accordingly - (@exit (if (@test_run_all ?files (@skill_files args)) 0 1)) + (let ( ( source_files nil ) + ( test_files nil ) + ( tests_status 1 ) + ) + ;; Toggle required switches + ;; TODO - Those should be arguments provided using Shell variables + (sstatus keepNLInString t) + (sstatus saveInlineDoc t) + ;; Segregate source and test files according to _test suffix + (foreach file (@skill_files args) + (if (pcreMatchp "_test\\.(ils?|scm)$" file) + (push file test_files) + (push file source_files) + )) + (cond + ;; No tests files, load all provided files + ( (not test_files) (when (@test_run_all ?test_files source_files) (setq tests_status 0)) ) + ( t (when (@test_run_all ?source_files source_files ?test_files test_files) (setq tests_status 0)) ) + ) + (@exit tests_status) + ;; Load SKILL and test files, then run tests and exit accordingly + ;(@exit (if (@test_run_all ?files ) 0 1)) + ) )) ;; ------------------------------------------------------- @@ -107,11 +128,13 @@ (add_command "globals" (lambda ( @rest args ) (@debug "Running Globals on {args}") - (destructuringBind ( stdout stderr _status ) - (@bash (@str "$SKILL_SHARP_ROOT/bin/globals {(buildString args)}")) - (fprintf (@errport) "%s" stderr) - (fprintf (@poport ) "%s" stdout) - ) + ;; Make sure warnings are printed to stderr + (@letf ( ( (@woport) (@errport) ) + ) + ;; Most arguments are passed to `@globals` using shell variables + (foreach names (@globals ?files (@skill_files args)) + (println (sort (@unique names) 'alphalessp) (@poport)) + )) )) ;; ------------------------------------------------------- @@ -160,7 +183,7 @@ ( args args_table["args" ]->value ) ) (@debug "Running Sharp {command} on {args}") - (@exit (if (errset (@sharp_run_command command args) t) 0 1)) + (@exit (if (errset (_\@sharp_run_command command args) t) 0 1)) )) ;*/ diff --git a/skill/testing.scm b/skill/testing.scm index 9de5a78..37da3b2 100644 --- a/skill/testing.scm +++ b/skill/testing.scm @@ -110,7 +110,7 @@ ;; TODO - Remove commented code ; (defmethod initializeInstance @after ( ( assertion @assertion ) @rest _ ) ; "Set OBJ as currently built one, so it can be accessed in class default values." -; (assert (xor (neq assertion->out '__undefined__) assertion->error) +; (assert (@xor (neq assertion->out '__undefined__) assertion->error) ; "@assertion - Exactly one of ?out or ?error should be provided.") ; ) @@ -164,7 +164,7 @@ (setf assertion->status value) ) - (@fun @test_print_report ( @rest _ ) + (@fun @test_print_report ( @key ( globals ?type ( symbol ... )|nil ?def nil ) @rest _) ?doc "Print Unit-Tests report." ?out t|nil ?global t @@ -193,9 +193,16 @@ (drain port) )) ) - ;; Print global report - (let ( ( pass (and (plusp test_new) (zerop test_fail) (zerop assertion_fail)) ) - ) + ;; Print untested functions + (letseq ( ( untested_names (sort (@unique (setof name globals (and (nequal '_ (getchar name 1)) (not (get name '@test))))) 'alphalessp) ) + ( pass (and (plusp test_new) (zerop test_fail) (zerop assertion_fail) (not untested_names)) ) + ) + ;; Print untested functions + (when untested_names + (@info "Untested Functions:\n {(buildString untested_names \"\n \")}\n") + (newline) + ) + ;; Print global report (@info "\ Total tests: {test_new}\n\ - skipped tests: {test_skip}\n\ @@ -239,7 +246,7 @@ Total assertions: {assertion_new}\n\ (destructuringBind ( @key (doc "") (out '__undefined__) (error '__undefined__) @rest _ ) (cdr sexp) ;; Assert cannot be used here as `error' is redefined locally (unless (stringp doc) (funcall 'error "@assertion - ?doc should be a string.")) - (unless (xor (eq out '__undefined__) (eq error '__undefined__)) + (unless (@xor (eq out '__undefined__) (eq error '__undefined__)) (funcall 'error "@assertion - Exactly one of ?out or ?error should be provided.")) ;; Define assertion and expand it in `_@assertion' macro call (let ( ( assertion (makeInstance '@assertion ?num num++ ?doc doc) ) ) @@ -262,10 +269,11 @@ Total assertions: {assertion_new}\n\ ));let ;fun (@macro @test ( @key - ( fun (@error "@test - ?fun is required, it should be a quoted symbol. (It can be set to 'nofun)") ) - ( title "" ) - ( doc "" ) - ( skip nil ) + ( fun (@error "@test - ?fun is required, it should be a quoted symbol. (It can be set to 'nofun)") ) + ( inherit nil ) + ( title "" ) + ( doc "" ) + ( skip nil ) @rest body ) "TODO - `@test' macro is neither finished nor properly documented." ;; Check input arguments @@ -275,65 +283,70 @@ Total assertions: {assertion_new}\n\ (not (cddr fun)) ) "@test - ?fun is required, it should be a quoted symbol. (It can be set to 'nofun)") + (assert (or (nequal fun ''nofun) (@nonblankstring? title)) "@test - ?title is required and should be a non-blank string when ?fun is 'nofun.") + (assert (or (not inherit) (and (listp inherit) (eq 'quote (car inherit)) (symbolp (cadr inherit)) (not (cddr inherit)))) + "@test - ?inherit should be a quoted symbol (or nil).") (assert (stringp doc ) "@test - ?doc should be a string.") (assert (stringp title) "@test - ?title should be a string.") - (assert (or (nequal fun ''nofun) (@nonblankstring? title)) - "@test - ?title is required and should be a non-blank string when ?fun is 'nofun.") - (@when (car (exists arg body (and (symbolp arg) (equal "?" (substring arg 1 1))))) - ?var key_arg - (error "@test - Unrecognized key argument: %N" key_arg) - ) - ;; Define test - ;; It might be a good idea to define a SHELL variable (like $SKILL_SHARP_NO_TEST) to completely skip test definitions - ;; (This would be cleaner for production code or when creating a context) - (when (equal "TRUE" (getShellEnvVar "SKILL_SHARP_RUN_TEST")) - (let ( ( test (makeInstance '@test ?fun (cadr fun) ?title title ?doc doc ?body body ?skip skip) ) - ) - ;; Parse and update test body to find assertions - (_\@test_update_body test) - (setq body test->body) - ;; Return updated body - `(progn - ;; For global functions, store test behind the function name symbol - (when (getd (get ,test 'fun)) - (when (@get ,test 'fun '@test) - (@set_status ,test 'fail) - (let ( ( msg (lsprintf "Function %s is already tested by %A." - (get ,test 'fun) (@get ,test 'fun '@test)) ) - ) - (pushf msg (get ,test 'messages)) - (error "%s" msg) - )) - (setf (@get ,test 'fun '@test) ,test) - ) - ;; Store test environment to be able to re-run it - (setf (get ,test 'environment) (theEnvironment)) - (cond - ;; Check skip boolean, skip and mark test accordingly - ( ,skip - (@set_status ,test 'skip) - (foreach assertion (@get_assertions ,test) - (@set_status assertion 'skip) - ) + (@if inherit + ;; Test is inherited + `(setf (get ',(cadr fun) '@test) (get ',(cadr inherit) '@test)) + ;; Test is normally defined + (@when (car (exists arg body (and (symbolp arg) (equal "?" (substring arg 1 1))))) + ?var key_arg + (error "@test - Unrecognized key argument: %N" key_arg) + ) + ;; Define test + ;; It might be a good idea to define a SHELL variable (like $SKILL_SHARP_NO_TEST) to completely skip test definitions + ;; (This would be cleaner for production code or when creating a context) + (when (equal "TRUE" (getShellEnvVar "SKILL_SHARP_RUN_TEST")) + (let ( ( test (makeInstance '@test ?fun (cadr fun) ?title title ?doc doc ?body body ?skip skip) ) ) - ;; Run test, mark it as ran - ;; TODO - Maybe put a switch or a variable here to detail errors in test (or not) - ;; For now showing all errors seems simpler for debugging - ( (errset (progn ,@body) t) - (@update_status ,test) + ;; Parse and update test body to find assertions + (_\@test_update_body test) + (setq body test->body) + ;; Return updated body + `(progn + ;; For global functions, store test behind the function name symbol + (when (getd (get ,test 'fun)) + (when (get (get ,test 'fun) '@test) + (@set_status ,test 'fail) + (let ( ( msg (lsprintf "Function %s is already tested by %A." + (get ,test 'fun) (get (get ,test 'fun) '@test)) ) + ) + (pushf msg (get ,test 'messages)) + (error "%s" msg) + )) + (setf (get (get ,test 'fun) '@test) ,test) ) - ;; Error occured, mark test as failed - ( t - (pushf - (lsprintf "Error occured when running test: %N\n" (nth 4 errset.errset)) - (get ,test 'messages) + ;; Store test environment to be able to re-run it + (setf (get ,test 'environment) (theEnvironment)) + (cond + ;; Check skip boolean, skip and mark test accordingly + ( ,skip + (@set_status ,test 'skip) + (foreach assertion (@get_assertions ,test) + (@set_status assertion 'skip) + ) ) - (@set_status ,test 'fail) - ) - );cond - );progn - ));let ;when - );macro + ;; Run test, mark it as ran + ;; TODO - Maybe put a switch or a variable here to detail errors in test (or not) + ;; For now showing all errors seems simpler for debugging + ( (errset (progn ,@body) t) + (@update_status ,test) + ) + ;; Error occured, mark test as failed + ( t + (pushf + (lsprintf "Error occured when running test: %N\n" (nth 4 errset.errset)) + (get ,test 'messages) + ) + (@set_status ,test 'fail) + ) + );cond + );progn + ));let ;when + ));if ;macro (@macro _\@assertion (assertion @key doc skip info warn error (out ''__undefined__) @rest body ) "Actual assertion builder, store values and run assertion checks." @@ -516,7 +529,10 @@ Got : █{assertion->warn_result}█")) ;; ======================================================= (@fun @test_run_all - ( @key ( files ?type ( string ... ) ) + ( @key + ( test_files ?type ( string ... ) ?doc "Files containing tests (and/or definitions) those files are loaded." ) + ( source_files ?type ( string ... ) ?def test_files ?doc "Source files are used to make sure all global definitions are tested." ) + ( load_source_files ?type t|nil ?def nil ?doc "If non-nil, source files are also loaded." ) @rest _ ) ?doc "Load all SKILL or SKILL++ FILES. @@ -528,9 +544,11 @@ Return nil otherwise." ) ;; Reset existing tests. ;(_\@tests_reset) + ;; Load source files when required + (when load_source_files (mapcar '@load source_files)) ;; Load all files containing tests - (mapcar '@load files) + (mapcar '@load test_files) ;; Run tests and return t or nil accordingly - (@test_print_report) + (@test_print_report ?globals (and source_files (car (@globals ?files source_files)))) ));letf ;fun diff --git a/skill/utils.scm b/skill/utils.scm index 4b3e808..8a97edb 100644 --- a/skill/utils.scm +++ b/skill/utils.scm @@ -4,6 +4,22 @@ ;; A. Buchet - April 2025 ;; =============================================================================================================== +;; ======================================================= +;; Booleans +;; ======================================================= + +(@fun @xor + ( ( obj0 ?type general ) + ( obj1 ?type general ) + ) + ?doc "Return nil if OBJ0 and OBJ1 are both non-nil or both nil. +Otherwise, it returns a non-nil value (OBJ1 or t). + +Native `xor` is a macro and thus it cannot be used in functional programming. +(i.e. with `foldl1` for instance." + (if obj0 (not obj1) obj1) + ) + ;; ======================================================= ;; Unix utilites ;; ======================================================= @@ -93,7 +109,7 @@ This is probably equivalent to `mktemp` \"unsafe\" --dry-run mode." ) ?doc "Return a list containing OBJ N times." ?out list - (@for _i 1 n obj) + (@for _ 1 n obj) ) ;; ======================================================= @@ -214,19 +230,19 @@ If NUM is negative, STR is right-padded instead." (pcreReplace (pcreCompile "\n*$") str "\n" 1) ) -(@fun @escape_chars - ( ( str ?type string ) - ) - ?doc "Return STR where special characters have been escaped." - ?out string - (foreach pair '( ;( "\\" "\\\\" ) - ( "\"" "\\\"" ) - ) - (destructuringBind (match replace) pair - (setq str (@exact_replace match str replace)) - ));destructuringBind ;foreach - str - ) +; (@fun @escape_chars +; ( ( str ?type string ) +; ) +; ?doc "Return STR where special characters have been escaped." +; ?out string +; (foreach pair '( ;( "\\" "\\\\" ) +; ( "\"" "\\\"" ) +; ) +; (destructuringBind (match replace) pair +; (setq str (@exact_replace match str replace)) +; ));destructuringBind ;foreach +; str +; ) ;; ======================================================= ;; Numbers @@ -280,7 +296,9 @@ If END is not provided, END defaults to BEG minus 1 and BEG defaults to 0." ) ?doc "Convert HEX into decimal." ?out integer - (evalstring (strcat "0x" hex))) + (or (car (errsetstring (strcat "0x" hex))) + (error "@hex_to_dec - Not a valid hexadecimal number: %N" hex) + )) (@fun @dec_to_hex ( ( dec ?type integer ) @@ -291,7 +309,7 @@ If END is not provided, END defaults to BEG minus 1 and BEG defaults to 0." (let ( ( res (numConv (lsprintf "%d" dec) "hex" nil) ) ) (if (plusp digits) - (@padd res digits) + (@padd res digits "0") res );if ));let ;fun @@ -301,7 +319,7 @@ If END is not provided, END defaults to BEG minus 1 and BEG defaults to 0." ;; ======================================================= (@fun @box_width - ( ( box ?type box ) + ( ( box ?type box|dbobject ) ) ?doc "Return BOX width" ?out number @@ -309,7 +327,7 @@ If END is not provided, END defaults to BEG minus 1 and BEG defaults to 0." ) (@fun @box_height - ( ( box ?type box ) + ( ( box ?type box|dbobject ) ) ?doc "Return BOX height" ?out number @@ -332,7 +350,7 @@ If END is not provided, END defaults to BEG minus 1 and BEG defaults to 0." (parseString stdout "\n") ))) -(@fun @file_contents +(@fun @read_file ( ( path ?type string ) ) ?doc "Return the contents of file at PATH as one string." @@ -341,54 +359,67 @@ If END is not provided, END defaults to BEG minus 1 and BEG defaults to 0." (@with ( ( in (infile path) ) ( out (outstring) ) ) - (let ( line ) - (while (gets line in) (fprintf out "%s" line)) - ) + (let ( line ) (while (gets line in) (fprintf out "%s" line))) (getOutstring out) )) +(@fun @write_file + ( ( path ?type string ) + ( string ?type string ) + ( mode ?type string ?def "w" ) + ) + ?doc "Write STRING to file at PATH. +(Arguments order is meant to match `fprintf' one)" + ?out t + (@with ( ( port (outfile path mode) ) + ) + (fprintf port "%s" string) + ));with ;def + + ;; ======================================================= ;; Predicates ;; ======================================================= -(@fun @is? - ( ( predicate ?type callable ) - ( object ?type any ) - ) - ?doc "PREDICATE wrapper. -Return OBJECT when it passes PREDICATE and is non-nil. -Return t when OBJECT passes PREDICATE but is nil. -Return nil otherwise." - (when (funcall predicate object) (or object t)) - ) - -(@fun @of_type? - ( ( type ?type symbol ) - ( object ?type any ) - ) - ?doc "`type' predicate wrapper. -Return OBJECT when it is of TYPE and is non-nil. -Return t when OBJECT is of TYPE but is nil. -Return nil otherwise." - (when (eq type (typep object)) (or object t)) - ) - -(@fun @of_class? - ( ( class ?type symbol ) - ( object ?type any ) - ) - ?doc "`classp' predicate wrapper. -Return OBJECT when it belongs to CLASS and is non-nil. -Return t when OBJECT belongs to CLASS but is nil. -Return nil otherwise." - (when (classp object class) (or object t)) - ) +; (@fun @is? +; ( ( predicate ?type callable ) +; ( object ?type any ) +; ) +; ?doc "PREDICATE wrapper. +; Return OBJECT when it passes PREDICATE and is non-nil. +; Return t when OBJECT passes PREDICATE but is nil. +; Return nil otherwise." +; (when (funcall predicate object) (or object t)) +; ) + +; (@fun @of_type? +; ( ( type ?type symbol ) +; ( object ?type any ) +; ) +; ?doc "`type' predicate wrapper. +; Return OBJECT when it is of TYPE and is non-nil. +; Return t when OBJECT is of TYPE but is nil. +; Return nil otherwise." +; (when (eq type (typep object)) (or object t)) +; ) + +; (@fun @of_class? +; ( ( class ?type symbol ) +; ( object ?type any ) +; ) +; ?doc "`classp' predicate wrapper. +; Return OBJECT when it belongs to CLASS and is non-nil. +; Return t when OBJECT belongs to CLASS but is nil. +; Return nil otherwise." +; (when (classp object class) (or object t)) +; ) (@fun @nonblankstring? ( ( obj ?type any ) ) - ?doc "Return t if STR is a non-blank string, nil otherwise." - (and (stringp obj) (not (blankstrp (@strip obj)))) + ?doc "Return STR if it is a non-blank string, nil otherwise." + ?out string|nil + (and (stringp obj) (not (blankstrp (@strip obj))) obj) ) ; (@fun @when_list @@ -516,7 +547,7 @@ Return nil otherwise." ( label ?type string ?doc "Label displayed by one of the banner menus in WINDOW." ) @rest _ ) - ?doc "Return the first CIW menu whose label matches LABEL." + ?doc "Return the first WINDOW menu whose label matches LABEL." ?out hiMenu ?global t ?strict t @@ -538,7 +569,7 @@ Return nil otherwise." ( label ?type string ?doc "Label displayed by one of the items in MENU." ) @rest _ ) - ?doc "Return the first CIW menu whose label matches LABEL." + ?doc "Return the first WINDOW MENU item whose label matches LABEL." ?out hiMenuItem ?global t ?strict t diff --git a/spec/code_spec.sh b/spec/code_spec.sh index d6861be..1a7ce5c 100644 --- a/spec/code_spec.sh +++ b/spec/code_spec.sh @@ -37,7 +37,7 @@ End It 'does not contain whitespace' Skip if "fd not available" missing_fd # shellcheck disable=SC2046 # Intended word splitting -When run grep -En '\s+$' $(list_files --exclude='README.md') +When run grep -En '\s+$' $(list_files --exclude='*.md' --exclude='*.pdf') The stdout should be blank The stderr should be blank The status should be failure @@ -47,7 +47,7 @@ End It 'does not contain tabs' Skip if "fd not available" missing_fd # shellcheck disable=SC2046 # Intended word splitting -When run grep -n $'\t' $(list_files --exclude='Makefile') +When run grep -n $'\t' $(list_files --exclude='Makefile' --exclude='*.pdf') The stdout should be blank The stderr should be blank The status should be failure @@ -57,7 +57,7 @@ End It 'does not contain carriage returns' Skip if "fd not available" missing_fd # shellcheck disable=SC2046 # Intended word splitting -When run grep -n $'\r' $(list_files) +When run grep -n $'\r' $(list_files --exclude='*.pdf') The stdout should be blank The stderr should be blank The status should be failure @@ -75,7 +75,7 @@ End It 'contains 15-25% of comments' Skip if "scc not available" missing_scc -comments_ratio() { scc | grep -E ^Total | awk '{ printf "%.2f\n", ($5 * 100 / ($5 + $6)) }'; } +comments_ratio() { scc --exclude-dir test | grep -E ^Total | awk '{ printf "%.2f\n", ($5 * 100 / ($5 + $6)) }'; } # shellcheck disable=SC2016 # Intended quoted variable When run env COMMENTS_RATIO="$(comments_ratio)" bash -c 'echo "15.00 <= $COMMENTS_RATIO && $COMMENTS_RATIO <= 25.00" | bc -l' The stdout should equal 1 diff --git a/spec/globals_spec.sh b/spec/globals_spec.sh index edd6b34..3fbefe9 100644 --- a/spec/globals_spec.sh +++ b/spec/globals_spec.sh @@ -3,61 +3,138 @@ Describe 'sharp' Describe 'globals' It 'is executable' -When run test -x ./bin/globals +When run env SKILL_SHARP_GLOBALS_LOAD=TRUE test -x ./bin/globals The stdout should be blank The stderr should be blank The status should be success End It 'reports global SKILL variables' -When run ./bin/sharp globals ./metatest/globals/variables.il +When run env SKILL_SHARP_GLOBALS_LOAD=TRUE SKILL_SHARP_GLOBALS_SHOW_PROPS=TRUE ./bin/sharp globals ./metatest/globals/variables.il The stdout should equal $'nil\n(global_variable nonlocal)\nnil\nnil\n(global_symbol)' The stderr should be blank The status should be success End It 'reports global Scheme variables' -When run ./bin/sharp globals ./metatest/globals/variables.ils +When run env SKILL_SHARP_GLOBALS_LOAD=TRUE SKILL_SHARP_GLOBALS_SHOW_PROPS=TRUE ./bin/sharp globals ./metatest/globals/variables.ils The stdout should equal $'nil\nnil\n(global_variable nonlocal)\nnil\n(global_symbol)' The stderr should be blank The status should be success End It 'reports global SKILL functions' -When run ./bin/sharp globals ./metatest/globals/functions.il -The stdout should equal $'(local_fun nonlocal global_fun)\n(lambda_variable)\nnil\nnil\nnil' +When run env SKILL_SHARP_GLOBALS_LOAD=TRUE SKILL_SHARP_GLOBALS_SHOW_PROPS=TRUE ./bin/sharp globals ./metatest/globals/functions.il +The stdout should equal $'(global_fun local_fun nonlocal)\n(lambda_variable)\nnil\nnil\nnil' The stderr should be blank The status should be success End It 'reports global Scheme functions' -When run ./bin/sharp globals ./metatest/globals/functions.ils -The stdout should equal $'(lambda_variable nonlocal global_fun)\nnil\nnil\nnil\nnil' +When run env SKILL_SHARP_GLOBALS_LOAD=TRUE ./bin/sharp globals ./metatest/globals/functions.ils +The stdout should equal $'(global_fun lambda_variable nonlocal)\nnil\nnil\nnil' The stderr should be blank The status should be success End It 'reports global SKILL classes and methods' -When run ./bin/sharp globals ./metatest/globals/classes.il -The stdout should equal $'(global_method local_method)\nnil\nnil\n(global_class local_class)\n(global_class local_class)' +When run env SKILL_SHARP_GLOBALS_LOAD=TRUE ./bin/sharp globals ./metatest/globals/classes.il +The stdout should equal $'(global_method local_method)\nnil\nnil\n(global_class local_class)' The stderr should be blank The status should be success End It 'reports global Scheme classes and methods' -When run ./bin/sharp globals ./metatest/globals/classes.ils +When run env SKILL_SHARP_GLOBALS_LOAD=TRUE SKILL_SHARP_GLOBALS_SHOW_PROPS=TRUE ./bin/sharp globals ./metatest/globals/classes.ils The stdout should equal $'(global_method local_method)\nnil\nnil\n(global_class local_class)\n(global_class local_class)' The stderr should be blank The status should be success End It 'reports global definitions' -When run ./bin/sharp globals ./metatest/globals/definitions.scm -The stdout should equal '(global_skill_function skill_method local_skill_function global_scheme_function nonlocal_scheme_function scheme_method) -(only_skill_var global_skill_var imported_skill_var) +When run env SKILL_SHARP_GLOBALS_LOAD=TRUE SKILL_SHARP_GLOBALS_SHOW_PROPS=TRUE ./bin/sharp globals ./metatest/globals/definitions.scm +The stdout should equal '(global_scheme_function global_skill_function local_skill_function nonlocal_scheme_function scheme_method skill_method) +(global_skill_var imported_skill_var only_skill_var) (global_skill_var imported_skill_var only_scheme_var) -(skill_class scheme_class) -(skill_class skill_container scheme_class scheme_container)' +(scheme_class skill_class) +(scheme_class scheme_container skill_class skill_container)' +The stderr should be blank +The status should be success +End + +## Same tests but using Lint to detect global definitions + +It 'reports global SKILL variables (no load)' +When run env SKILL_SHARP_GLOBALS_SHOW_PROPS=TRUE ./bin/sharp globals ./metatest/globals/variables.il +The stdout should equal $'nil\n(global_variable nonlocal)\nnil\nnil\n(global_symbol)' +The stderr should be blank +The status should be success +End + +It 'reports global Scheme variables (no load)' +When run ./bin/sharp globals ./metatest/globals/variables.ils +The stdout should equal $'nil\nnil\n(global_variable nonlocal)\nnil' +The stderr should be blank +The status should be success +End + +It 'reports global SKILL functions (no load)' +When run ./bin/sharp globals ./metatest/globals/functions.il +The stdout should equal $'(global_fun local_fun nonlocal)\n(lambda_variable)\nnil\nnil' +The stderr should be blank +The status should be success +End + +It 'reports global Scheme functions (no load)' +When run env SKILL_SHARP_GLOBALS_SHOW_PROPS=TRUE ./bin/sharp globals ./metatest/globals/functions.ils +The stdout should equal $'(global_fun lambda_variable nonlocal)\nnil\nnil\nnil\nnil' +The stderr should be blank +The status should be success +End + +It 'reports global SKILL classes and methods (no load)' +Pending +When run env SKILL_SHARP_GLOBALS_SHOW_PROPS=TRUE ./bin/sharp globals ./metatest/globals/classes.il +The stdout should equal $'(global_method local_method)\nnil\nnil\n(global_class local_class)\n(global_class local_class)' +The stderr should be blank +The status should be success +End + +It 'reports global Scheme classes and methods (no load)' +Pending +When run ./bin/sharp globals ./metatest/globals/classes.ils +The stdout should equal $'(global_method local_method)\nnil\nnil\n(global_class local_class)' +The stderr should be blank +The status should be success +End + +It 'reports global definitions (no load)' +Pending +When run env SKILL_SHARP_GLOBALS_SHOW_PROPS=TRUE ./bin/sharp globals ./metatest/globals/definitions.scm +The stdout should equal '(global_scheme_function global_skill_function local_skill_function nonlocal_scheme_function scheme_method skill_method) +(global_skill_var imported_skill_var only_skill_var) +(global_skill_var imported_skill_var only_scheme_var) +(scheme_class skill_class) +(scheme_class scheme_container skill_class skill_container)' +The stderr should be blank +The status should be success +End + +## Check all SKILL# autoloaded files + +Parameters:dynamic + # shellcheck disable=SC2044 # shellspec %data directive cannot be used inside -exec + for file in $(find skill/autoloaded -name '*.il' -o -name '*.ils' -o -name '*.scm') ; do + %data "$file" + done +End + +It "reports same global definitions with Lint and Load in $1" +When run bash -c "diff <(./bin/sharp globals $1)\ + <(env SKILL_SHARP_GLOBALS_LOAD=TRUE \ + SKILL_SHARP_BEFORE_COMMAND='(load \"./skill/loader.scm\")' \ + ./bin/sharp globals $1)" +The stdout should be blank The stderr should be blank The status should be success End diff --git a/spec/lint_spec.sh b/spec/lint_spec.sh index 4dfd910..05c4061 100644 --- a/spec/lint_spec.sh +++ b/spec/lint_spec.sh @@ -105,7 +105,7 @@ When run ./bin/sharp lint ./metatest/lint/extra_key_arguments.scm The stderr should include 'WARNING EXTRA_KEY_ARG at line 2 - `let` extra key argument ?unexpected is provided' The stderr should include 'WARNING POSITIONAL_KEY_ARG at line 4 - `progn` argument ?weird is treated as positional' The stderr should include 'WARNING EXTRA_KEY_ARG at line 4 - `progn` extra key argument ?what' -The stderr should include 'WARNING EXTRA_KEY_ARG at line 7 - `\@if` extra key argument ?extra_var' +The stderr should include 'WARNING EXTRA_KEY_ARG at line 7 - `@if` extra key argument ?extra_var' The stderr should not include 'argument ?do_not_report' The stdout should end with 'FAIL' The status should be failure @@ -132,9 +132,7 @@ It 'reports messages inside `let` definitions' When run ./bin/sharp lint ./metatest/lint/lint_errors_inside_let_definitions.il The stdout should include 'INFO CAR_SETOF at line 4' The stderr should include 'ERROR EXTRA_ARGS at line 10 - `setq`' -The stderr should include 'ERROR SYNTAX_SETQ at line 10 - `setq`' The stderr should include 'ERROR EXTRA_ARGS at line 20 - `setq`' -The stderr should include 'ERROR SYNTAX_SETQ at line 20 - `setq`' The stderr should include 'ERROR GLOBAL_USE at line 22 - Undefined global variable is used: abc' The stdout should include 'INFO CAR_SETOF at line 24' The status should be failure @@ -235,10 +233,10 @@ The stderr should include '*Error* @str: argument #1 should be a string' The stderr should include "*Error* @str: too many arguments (1 expected, 2 given)" The stderr should include '*Error* Open-bracket is never closed in f-string : \"Bracket is never closed { 12 27\"' ## TODO - Test more advanced f-string cases (never opened closing-bracket, brackets inside evaluated part, ...) -The stderr should include 'ERROR MACRO_EXPANSION at line 9 - `\@str` error when expanding macro' -The stderr should include 'ERROR EXTRA_ARGS at line 13 - `\@str` extra arguments are provided' -The stderr should include 'ERROR MACRO_EXPANSION at line 13 - `\@str` error when expanding macro' -The stderr should include 'ERROR MACRO_EXPANSION at line 16 - `\@str` error when expanding macro' +The stderr should include 'ERROR MACRO_EXPANSION at line 9 - `@str` error when expanding macro' +The stderr should include 'ERROR EXTRA_ARGS at line 13 - `@str` extra arguments are provided' +The stderr should include 'ERROR MACRO_EXPANSION at line 13 - `@str` error when expanding macro' +The stderr should include 'ERROR MACRO_EXPANSION at line 16 - `@str` error when expanding macro' The stderr should not include '(@str "{var} {var}")' The stdout should end with 'FAIL' The status should be failure @@ -255,9 +253,9 @@ End It 'reports unused variables in anaphoric macros' When run ./bin/sharp lint ./metatest/lint/anaphoric_macros.scm -The stderr should include 'WARNING @IF_UNUSED at line 7 - `\@if` variable var_if is unused' -The stderr should include 'WARNING @NIF_UNUSED at line 11 - `\@nif` variable var_nif is unused' -The stderr should include 'WARNING @WHEN_UNUSED at line 15 - `\@when` variable var_when is unused' +The stderr should include 'WARNING @IF_UNUSED at line 7 - `@if` variable var_if is unused' +The stderr should include 'WARNING @NIF_UNUSED at line 11 - `@nif` variable var_nif is unused' +The stderr should include 'WARNING @WHEN_UNUSED at line 15 - `@when` variable var_when is unused' The stdout should end with 'FAIL' The status should be failure End @@ -265,7 +263,7 @@ End It 'only reports wrong arguments in `lambda` and `defun` calls' When run ./bin/sharp lint ./metatest/lint/symbol_as_fun_args.scm The stderr should include 'ERROR SYNTAX_DEFUN at line 4' -The stdout should include 'INFO GLOBAL at line 9 - `defglobalfun` global definition: valid_fun' +The stdout should include 'INFO GLOBAL at line 9 - `defglobalfun` global function definition: valid_fun' The stderr should include 'WARNING LAMBDA_UNUSED at line 13 - `lambda` variable args is unused' The stderr should not include 'ERROR SYNTAX_DEFUN at line 9' The stderr should not include 'variable _ is unused' @@ -310,7 +308,7 @@ When run ./bin/sharp lint ./metatest/lint/functions.scm The stderr should include 'unused_defun_function0 is unused' The stderr should include 'superseded_defun_function0 is unused' The stderr should include 'superseded_defun_function1 is unused' -The stdout should include 'INFO GLOBAL at line 17 - `defglobalfun` global definition: defglobalfun_function0' +The stdout should include 'INFO GLOBAL at line 17 - `defglobalfun` global function definition: defglobalfun_function0' The stdout should end with 'FAIL' The status should be failure End @@ -318,7 +316,7 @@ End It 'reports duplicated definitions' When run ./bin/sharp lint ./metatest/lint/functions.scm The stderr should include 'WARNING DEFUN_SUPERSEDE at line 13 - `defun` variable superseded_defun_function0 is superseded' -The stderr should include 'WARNING @FUN_SUPERSEDE at line 26 - `\@fun` variable superseded_defun_function1 is superseded' +The stderr should include 'WARNING @FUN_SUPERSEDE at line 26 - `@fun` variable superseded_defun_function1 is superseded' The stdout should end with 'FAIL' The status should be failure End @@ -326,7 +324,7 @@ End It 'reports usage of debugging functions' When run ./bin/sharp lint ./metatest/lint/debugging_functions.scm -The stderr should include 'WARNING DEBUGGING at line 4 - `\@show` debugging function should not be used in production - (\@show 12 27)' +The stderr should include 'WARNING DEBUGGING at line 4 - `@show` debugging function should not be used in production - (\@show 12 27)' The stderr should include 'WARNING DEBUGGING at line 9 - `pp` debugging function should not be used in production - (pp \@show)' The stdout should end with 'FAIL' The status should be failure diff --git a/spec/skill_sharp_spec.sh b/spec/skill_sharp_spec.sh index 1320db1..a404257 100644 --- a/spec/skill_sharp_spec.sh +++ b/spec/skill_sharp_spec.sh @@ -33,21 +33,21 @@ End Describe 'unit-tests' It 'passes unit-tests using SKILL interpreter' - When run ./bin/sharp test ./test + When run ./bin/sharp test ./skill ./test The stdout should end with 'PASS' The stderr should be blank The status should be success End It 'passes unit-tests (including in-code ones) using SKILL interpreter' - When run env SKILL_SHARP_RUN_TEST=TRUE ./bin/sharp test ./test + When run env SKILL_SHARP_RUN_TEST=TRUE ./bin/sharp test ./skill ./test The stdout should end with 'PASS' The stderr should be blank The status should be success End It 'passes unit-tests (including in-code ones) using SKILL interpreter with strict Type-Checking' - When run env SKILL_SHARP_RUN_TEST=TRUE SKILL_SHARP_STRICT_TYPE_CHECKING=TRUE ./bin/sharp test ./test + When run env SKILL_SHARP_RUN_TEST=TRUE SKILL_SHARP_STRICT_TYPE_CHECKING=TRUE ./bin/sharp test ./skill ./test The stdout should end with 'PASS' The stderr should be blank The status should be success @@ -56,7 +56,7 @@ Describe 'unit-tests' It 'passes unit-tests using cdsmps' When run env SKILL_INTERPRETER="$CDS_INST_DIR/tools.lnx86/bin/cdsmps" \ SKILL_SHARP_RUN_TEST=TRUE \ - ./bin/sharp test ./test + ./bin/sharp test ./skill ./test The stdout should end with 'PASS' The stderr should be blank The status should be success diff --git a/test/autoloaded/arglist_test.scm b/test/autoloaded/arglist_test.scm new file mode 100644 index 0000000..e69de29 diff --git a/test/autoloaded/browse_test.scm b/test/autoloaded/browse_test.scm index e69de29..24dc988 100644 --- a/test/autoloaded/browse_test.scm +++ b/test/autoloaded/browse_test.scm @@ -0,0 +1,32 @@ + +(@test + ?fun '@list_lcv + ?doc "Return the list of Library / Cell / Views referenced from a known cell." + ?skip (not (isCallable 'dbOpenCellViewByType)) + + (@assertion + (@with ( ( cv (dbOpenCellViewByType "rfExamples" "BB_test_bench" "schematic") ) + ) + (@list_lcv ?cellview cv) + ) + ?out '(("rfLib" "IQ_mod_BB" "symbol") + ("rfLib" "ind_BB" "symbol") + ("analogLib" "vsin" "symbol") + ("rfLib" "PA_PB" "symbol") + ("analogLib" "cap" "symbol") + ("rfLib" "cap_BB" "symbol") + ("analogLib" "ind" "symbol") + ("analogLib" "res" "symbol") + ("rfExamples" "BB_test_bench" "schematic") + ("rfLib" "PA_BB" "symbol") + ("rfLib" "IQ_modulator" "symbol") + ("rfLib" "res_BB" "symbol") + ("analogLib" "port" "symbol") + ("analogLib" "gnd" "symbol") + ("analogLib" "gnd" "schematic") + ) + ) + ) + + + diff --git a/test/autoloaded/debug_test.scm b/test/autoloaded/debug_test.scm index e69de29..994359e 100644 --- a/test/autoloaded/debug_test.scm +++ b/test/autoloaded/debug_test.scm @@ -0,0 +1,51 @@ +(@test + ?fun '@print_args + ?doc "Print simple arguments." + + (@assertion + (@print_args 12+27 42) + ?info "args: (39 42)" + ?out '(39 42) + ) + ) + +(@test + ?fun '@print_table + ?doc "Print simple table contents." + + (@assertion + (@print_table + '( ( "Name" "Value" "Description" ) + ( abc 12 just_a_number ) + ( dummy_name dummy_value dummy_description) + )) + ?info " Name Value Description\n abc 12 just_a_number\n dummy_name dummy_value dummy_description" + ?out t + ) + + (@assertion + (@print_table + '( ( "Name" "Value" "Description" ) + ( abc 12 just_a_number ) + ( dummy_name dummy_value dummy_description) + ) + ?has_headers t) + ?info " Name Value Description\n \n abc 12 just_a_number\n dummy_name dummy_value dummy_description" + ?out t + ) + ) + +(@test + ?fun '@runtime + ?doc "Runtime prints a nice table." + + (@assertion + (@runtime 12 27 ?runs 10) + ?info "S-Expression User CPU Time (us) System CPU Time (us) Clock Time (us) Page Faults" + ?out t + ) + ) + + + + diff --git a/test/autoloaded/docgen_test.scm b/test/autoloaded/docgen_test.scm index e69de29..db4b9ae 100644 --- a/test/autoloaded/docgen_test.scm +++ b/test/autoloaded/docgen_test.scm @@ -0,0 +1,45 @@ +(@test + ?fun '@globals + ?doc "Run `@globals` on known files." + + (@assertion + (@globals ?files (list (@realpath "$SKILL_SHARP_ROOT/metatest/globals/functions.ils"))) + ?out '( ( global_fun nonlocal lambda_variable ) nil nil nil ) + ) + + ) + +(@test + ?fun '@docgen + ?doc "Run `@docgen` on known files." + + (@assertion + (@docgen ?files (list (@realpath "$SKILL_SHARP_ROOT/metatest/globals/functions.ils"))) + ?out t + ?info "( \"nonlocal\"\n \"nonlocal()\"\n \"Missing documentation for function `nonlocal'.\"\n )" + ) + + ) + +(@test + ?fun '@fndcheck + ?doc "Run `@fndcheck` on known files." + + (@assertion + (@fndcheck ?files (list (@realpath "$SKILL_SHARP_ROOT/metatest/fndcheck/valid.fnd"))) + ?out t + ) + + (@assertion + (@fndcheck ?files (list (@realpath "$SKILL_SHARP_ROOT/metatest/fndcheck/warning.fnd"))) + ?warn "Error when reading .fnd file" + ?out nil + ) + + (@assertion + (@fndcheck ?files (list (@realpath "$SKILL_SHARP_ROOT/metatest/fndcheck/errorful_characters.fnd"))) + ?warn "character found after backslash is not meaningful" + ?out t + ) + ) + diff --git a/test/autoloaded/finder_test.scm b/test/autoloaded/finder_test.scm index e69de29..284139d 100644 --- a/test/autoloaded/finder_test.scm +++ b/test/autoloaded/finder_test.scm @@ -0,0 +1,12 @@ +(@test + ?fun '@fnd_gui + ?doc "Display the finder and return" + ?skip t + + (@assertion + (@fnd_gui) + ?out t + + ) + ) + diff --git a/test/autoloaded/lint_test.scm b/test/autoloaded/lint_test.scm index e69de29..4272230 100644 --- a/test/autoloaded/lint_test.scm +++ b/test/autoloaded/lint_test.scm @@ -0,0 +1,22 @@ + + +(@test + ?fun '@lint + ?doc "Make sure Lint return the expected messages on known files." + + (@assertion + (@lint ?files (list (@realpath "$SKILL_SHARP_ROOT/metatest/lint/car_setof.scm"))) + ?info "INFO CAR_SETOF at line 5" + ?out t + ) + + (@assertion + (@lint ?files (list (@realpath "$SKILL_SHARP_ROOT/metatest/lint/functions_without_docstrings.scm"))) + ?info "INFO GLOBAL at line 1" + ?warn "WARNING MISSING_DOCSTRING at line 5" + ?out nil + ) + + ) + + diff --git a/test/autoloaded/on_the_fly_test.scm b/test/autoloaded/on_the_fly_test.scm index e69de29..3c8e4e7 100644 --- a/test/autoloaded/on_the_fly_test.scm +++ b/test/autoloaded/on_the_fly_test.scm @@ -0,0 +1,49 @@ + +(@test + ?fun '@ciw + ?doc "This function is simply a shortcut for `hiGetCIWindow`." + ?skip (not (isCallable 'hiGetCIWindow)) + + (@assertion + (windowp (@ciw)) + ?out t + ) + + ) + +(@test + ?fun '@cw + ?doc "This function is simply a shortcut for `hiGetCurrentWindow`." + ?skip (not (isCallable 'hiGetCurrentWindow)) + + (@assertion + (when (hiGetCurrentWindow) (windowp (@cw))) + ?out t + ) + + ) + +(@test + ?fun '@ccv + ?doc "This function is simply a shortcut for `geGetEditCellView`." + ?skip (not (isCallable 'geGetEditCellView)) + + (@assertion + (when (geGetEditCellView) (dbobjectp (@ccv))) + ?out t + ) + + ) + +(@test + ?fun '@ctf + ?doc "This function is simply a shortcut for `techGetTechFile`." + ?skip (not (isCallable 'techGetTechFile)) + + (@assertion + (when (techGetTechFile) (dbobjectp (@ctf))) + ?out t + ) + + ) + diff --git a/test/autoloaded/script_test.scm b/test/autoloaded/script_test.scm index 8b59efc..b516790 100644 --- a/test/autoloaded/script_test.scm +++ b/test/autoloaded/script_test.scm @@ -1,11 +1,106 @@ +(@test + ?fun '@exit + ?doc "`@exit` can not be tested for obvious reasons..." + ?skip t + + (@assertion + (@exit) + ?out nil + ) + + (@assertion + (@exit 0) + ?out nil + ) + + (@assertion + (@exit 127) + ?out nil + ) + + ) + +;; Script description + +(@test + ?fun '@script_get_description + ?doc "Set and get script description" + + (@assertion + (@script_set_description "New script description") + ?out "New script description" + ) + + (@assertion + (@script_get_description) + ?out "New script description" + ) + + (@assertion + (setf (@script_get_description) "Another script description") + ?out "Another script description" + ) + + (@assertion + (@script_get_description) + ?out "Another script description" + ) + ) + +(@test ?fun '@script_set_description ?inherit '@script_get_description) +(@test ?fun 'setf_\@script_get_description ?inherit '@script_get_description) +(@test ?fun 'setf_\\\@script_get_description ?inherit '@script_get_description) + +;; Script version + +(@test + ?fun '@script_get_version + ?doc "Set and get script version" + + (@assertion + (@script_set_version "0.0.1") + ?out "0.0.1" + ) + + (@assertion + (@script_get_version) + ?out "0.0.1" + ) + + (@assertion + (setf (@script_get_version) "1.12.27") + ?out "1.12.27" + ) + + (@assertion + (@script_get_version) + ?out "1.12.27" + ) + ) + +(@test ?fun '@script_set_version ?inherit '@script_get_version) +(@test ?fun 'setf_\@script_get_version ?inherit '@script_get_version) +(@test ?fun 'setf_\\\@script_get_version ?inherit '@script_get_version) + ;; Mock `@script_is_running?' +;(putd '_\@script_is_running? (getd '@script_is_running?)) (putd '@script_is_running? nil) (@fun @script_is_running? ( @rest _ ) ?doc "Mocking replacer. Always return t." ?out t t) +(@test + ?fun '@script_is_running? + ?doc "When running SKILL as a script (not inside virtuoso)." + + (@assertion + (@script_is_running?) + ?out t + ) + ) + (@test ?fun '@script_add_argument @@ -43,4 +138,32 @@ A positional required argument (i.e. without ?default) cannot be defined after a ) +(@test + ?fun '@script_get_arguments + ?doc "Get script arguments (When running SKILL file directly (outside Virtuoso)." + ?skip t + + (@assertion + (tablep (@script_get_arguments)) + ?out t + ) + + (@assertion + (sort (foreach mapcar dpl (@table_elements (@script_get_arguments)) dpl->name) 'alphalessp) + ?out '( "args" "command" "help" "optional" "usage" "version" ) + ) + + ) + +(@test + ?fun '@script_parse_arguments + ?doc "This is tested in SKILL# metatest." + ?skip t + + (@assertion + (@script_parse_arguments) + ?out nil + ) + ) + diff --git a/test/autoloaded/tcp_server_test.scm b/test/autoloaded/tcp_server_test.scm index e69de29..43cb5c0 100644 --- a/test/autoloaded/tcp_server_test.scm +++ b/test/autoloaded/tcp_server_test.scm @@ -0,0 +1,17 @@ +(@test + ?fun '@skill_server + ?doc "Make sure server is working" + ?skip t ;(not (member (@basename (car (getShellArgs))) '( "cdsmps" "virtuoso" ))) + + ;; TODO - @skill_server test is not robust enough + (@assertion + (progn + (setf @skill_server.test_server (@skill_server) ) + (ipcWaitForProcess @skill_server.test_server) + (@bash "echo '(progn (println 12) (ipcKillProcess @skill_server.test_server)' | $SKILL_SHARP_ROOT/bin/tcp_client -l skill") + (ipcWait @skill_server.test_server 30 5) + ) + ?out t + ) + + ) diff --git a/test/autoloaded/ui_test.scm b/test/autoloaded/ui_test.scm index e69de29..886c6a9 100644 --- a/test/autoloaded/ui_test.scm +++ b/test/autoloaded/ui_test.scm @@ -0,0 +1,38 @@ + +(@test + ?fun '@get_available_colors + ?doc "Return the list of available colors from layers defined in DRF." + ?skip (not (isCallable 'techGetTechFile)) + + (@assertion + (let ( ( colors (@get_available_colors) ) + ) + (and colors (listp colors) (forall color colors (stringp color))) + ) + ?out t + ) + + ) + +(@test + ?fun '@color_icon + ?doc "Return a colored icon." + ?skip (not (isCallable 'hiStringToIcon)) + + (@assertion + (hiIsIcon (@color_icon "red")) + ?out t + ) + ) + +(@test + ?fun '@color_field + ?doc "Return a color name picking field." + ?skip (not (isCallable 'hiCreateCyclicField)) + + (@assertion + (eq 'cyclicStruct (type (@color_field ?name 'color_field))) + ?out t + ) + ) + diff --git a/test/functional_test.scm b/test/functional_test.scm index e69de29..73e90fe 100644 --- a/test/functional_test.scm +++ b/test/functional_test.scm @@ -0,0 +1,192 @@ + +(@test + ?fun '@getd + ?doc "`@getd` returns the same results as `getd`." + + (@assertion + (isCallable (@getd 'println)) + ?out t + ) + + (@assertion + (@getd 'println) + ?out (getd 'println) + ) + + (@assertion + (@getd '@getd) + ?out (getd '@getd) + ) + + (@assertion + ?doc "`@getd` raises an error when function does not exist." + (@getd 'this_function_does_not_exist) + ?error "Unable to retrieve function named this_function_does_not_exist" + ) + + ) + +(@test + ?fun '@nil + ?doc "Always return nil." + + (@assertion + (@nil) + ?out nil + ) + + (@assertion + (@nil 12 27) + ?out nil + ) + + (@assertion + (@nil t) + ?out nil + ) + + ) + +(@test + ?fun '@t + ?doc "Always return t." + + (@assertion + (@t) + ?out t + ) + + (@assertion + (@t 12 27) + ?out t + ) + + (@assertion + (@t nil) + ?out t + ) + + ) + +(@test + ?fun '@identity + ?doc "Always return input argument as is." + + (@assertion + (@identity t) + ?out t + ) + + (@assertion + (@identity (list 12 27)) + ?out '( 12 27 ) + ) + + (@assertion + (@identity 12 27) + ?error "@identity: too many arguments" + ) + + ) + +(@test + ?fun '@getter + ?doc "Return a getter function" + + (@assertion + (isCallable (@getter 'prop0)) + ?out t + ) + + (@assertion + (funcall (@getter 'prop1) '( nil prop0 12 prop1 27 prop2 42 )) + ?out 27 + ) + + (@assertion + (funcall (@getter 'prop1 'a) '( nil prop0 12 prop1 ( nil a "a" b "b" c "c" ) prop2 42 )) + ?out "a" + ) + ) + +(@test + ?fun '@memoize + + (@assertion + ?doc "Define `memoize_test`." + (getFunType (putd 'memoize_test (@memoize (lambda (obj) (println 'this_will_be_printed_only_once) (times obj obj))))) + ?out 'lambda + ) + + (@assertion + ?doc "First time the function is called with a given set of arguments, body is processed and symbol is printed." + (memoize_test 12) + ?info "this_will_be_printed_only_once" + ?out 144 + ) + + (@assertion + ?doc "Any other time the function is called with a known set of arguments, output value is directly return and body is not processed." + (memoize_test 12) + ?out 144 + ) + + ) + +(@test + ?fun '@foldl1 + ?doc "Foldl works with simple functions." + + (@assertion + (@foldl1 'plus '( 0 1 2 3 4 )) + ?out 10 + ) + + (@assertion + (@foldl1 'difference '( 1 2 3 4 5 )) + ?out -13 + ) + + (@assertion + (@foldl1 'times '( 1 2 3 4 5 6 )) + ?out 720 + ) + + (@assertion + (@foldl1 '@xor '( t t t nil nil t t nil )) + ?out t + ) + + ) + +(@test + ?fun '@queue + ?doc "@queue cannot be tested using the standard framework." + ?skip t + ;; TODO - test `@queue` inside shellspec script + + (@assertion + (@queue (lambda () (println 'this_is_queued))) + ?out t + ) + + ) + +(@test + ?fun '@timer + ?doc "@timer cannot be tested using the standard framework." + ?skip t + + (@assertion + (@timer 10 (lambda () (println 'this_is_delayed))) + ?out t + ) + + (@assertion + (ipcSleep 2) + ?info "this_is_delayed" + ?out t + ) + + ) + diff --git a/test/init_test.scm b/test/init_test.scm index e69de29..74fb0e1 100644 --- a/test/init_test.scm +++ b/test/init_test.scm @@ -0,0 +1,170 @@ + +;; ======================================================= +;; Setf helpers +;; ======================================================= + +(@test + ?fun 'setf_fdoc + ?doc "Make sure `(setf (fdoc ...) ...)` and `fdoc` work well." + + (@assertion + (defglobalfun dummy_function () "example docstring" 12 27) + ?out 'dummy_function + ) + + (@assertion + (setf (fdoc 'dummy_function) "updated docstring") + ?out "updated docstring" + ) + + (@assertion + (fdoc 'dummy_function) + ?out "updated docstring" + ) + ) + +(@test + ?fun 'setf_rexMagic + ?doc "Make sure `(setf (rexMagic) ...)` works." + + (@assertion + (setf (rexMagic) nil) + ?out nil + ) + + (@assertion + (rexMagic) + ?out nil + ) + + (@assertion + (setf_rexMagic t) + (rexMagic) + ?out t + ) + ) + + +;; ======================================================= +;; Debugging functions +;; ======================================================= + +(@test + ?fun '@get_debug + ?doc "Get & set the debugging status." + ?skip t + + (@assertion + (@get_debug) + ?out nil + ) + + (@assertion + (@set_debug t) + ?out t + ) + + (@assertion + (@get_debug) + ?out t + ) + + (@assertion + (setf (@get_debug) nil) + ?out nil + ) + + (@assertion + (@get_debug) + ?out nil + ) + ) + +(@test ?fun '@set_debug ?inherit '@get_debug) +(@test ?fun 'setf_\@get_debug ?inherit '@get_debug) +(@test ?fun 'setf_\\\@get_debug ?inherit '@get_debug) + +(@test + ?fun '@realpath + ?doc "Expand variables and symlinks inside a given path." + + (@assertion + (setShellEnvVar "DUMMY_PATH_EXAMPLE" "/tmp/dir") + ?out t + ) + + (@assertion + (@realpath "$DUMMY_PATH_EXAMPLE/subdir/file") + ?out "/tmp/dir/subdir/file" + ) + + ) + +;; ======================================================= +;; Run Shell Commands +;; ======================================================= + +(@test + ?fun '@bash + ?doc "Make sure `@bash` returns the proper stdout, stdin & exit status values." + + (@assertion + (@bash "echo simple bash message") + ?out '("simple bash message\n" "" 0) + ) + + (@assertion + (@bash ">&2 echo stderr message") + ?out '("" "stderr message\n" 0) + ) + + (@assertion + (@bash "echo 12 ; echo 27 >&2 ; exit 3") + ?out '("12\n" "27\n" 3) + ) + + (@assertion + (@bash "false") + ?out '("" "" 1) + ) + + (@assertion + ?doc "Check stdout, stderr and exit status are well returned." + (@bash "echo 12 ; >&2 echo 27 ; exit 42") + ?out '("12\n" "27\n" 42) + ) + + (@assertion + ?doc "Check special characters are well taken in account" + (@bash "printf '%-10s\n\"Second line\".\n\n' word") + ?out '("word \n\"Second line\".\n\n" "" 0) + ) + + );test + +;; ======================================================= +;; Loading functions +;; ======================================================= + +(@test + ?fun '@load + ?doc "Make sure `@load` works as expected on a known file." + + (@assertion + (@load "$SKILL_SHARP_ROOT/metatest/hello_world.scm") + ?info "Hello World!\n" + ?out t + ) + + (@assertion + (@load "$SKILL_SHARP_ROOT/metatest/hello_world.scm" ?no_reload t) + ?out t + ) + + (@assertion + (@load "$SKILL_SHARP_ROOT/metatest/hello_world.scm") + ?info "Hello World!\n" + ?out t + ) + ) + diff --git a/test/legacy_test.scm b/test/legacy_test.scm index e69de29..2128593 100644 --- a/test/legacy_test.scm +++ b/test/legacy_test.scm @@ -0,0 +1,63 @@ + +(@test + ?fun 'muffleWarnings + ?doc "Muffle warnings suppresses all warning messages from woport." + + (@assertion + (warn "printed warning") + ?warn "printed warning" + ?out nil + ) + + (@assertion + (muffleWarnings (warn "hidden warning")) + ?out nil + ) + + (@assertion + (progn (muffleWarnings (warn "reported warning")) (getMuffleWarnings)) + ?out '("*WARNING* reported warning") + ) + + ) + +(@test ?fun 'getMuffleWarnings ?inherit 'muffleWarnings) + +(@test + ?fun '@setf_getShellEnvVar + ?doc "`@setf_getShellEnvVar` is meant to be used inside `@setf`." + + (@assertion + (@setf (getShellEnvVar "DUMMY_VARIABLE") "DUMMY_VALUE") + ?out t + ) + + (@assertion + (getShellEnvVar "DUMMY_VARIABLE") + ?out "DUMMY_VALUE" + ) + + (@assertion + (@setf (getShellEnvVar "DUMMY_VARIABLE") nil) + ?out t + ) + + (@assertion + (getShellEnvVar "DUMMY_VARIABLE") + ?out nil + ) + + (@assertion + ?doc "It also works on its own." + (@setf_getShellEnvVar "NEW_VALUE" "DUMMY_VARIABLE") + ?out t + ) + + (@assertion + ?doc "It also works on its own." + (getShellEnvVar "DUMMY_VARIABLE") + ?out "NEW_VALUE" + ) + + ) + diff --git a/test/lint_rules_test.il b/test/lint_rules_test.il new file mode 100644 index 0000000..e69de29 diff --git a/test/loader_test.scm b/test/loader_test.scm index b86b008..e69de29 100644 --- a/test/loader_test.scm +++ b/test/loader_test.scm @@ -1,16 +0,0 @@ -(@test - ?fun '@bash - - (@assertion - ?doc "Check stdout, stderr and exit status are well returned." - (@bash "echo 12 ; >&2 echo 27 ; exit 42") - ?out '("12\n" "27\n" 42) - ) - - (@assertion - ?doc "Check special characters are well taken in account" - (@bash "printf '%-10s\n\"Second line\".\n\n' word") - ?out '("word \n\"Second line\".\n\n" "" 0) - ) - - );test diff --git a/test/macros/class_test.scm b/test/macros/class_test.scm index db69e5c..8edcadd 100644 --- a/test/macros/class_test.scm +++ b/test/macros/class_test.scm @@ -1,2 +1,34 @@ ;; TODO - `@class' should be deeply tested! +(@test + ?fun '@built_obj + ?doc "`@built_obj` is meant to make dependent arguments inside a class." + + (@assertion + (@class + ?name 'example_class + ?doc "Example class" + ( length @arg ?init 1.0 ?type float ) + ( width @arg ?init 1.0 ?type float ) + ( area ?init (let ( ( obj (@built_obj) ) ) obj->length*obj->width) ?type integer ) + ) + ?warn "unknown class example_class when defining _ilSharedInitialize method" + ?out 'example_class + ) + + (@assertion + (classp (example_class ?length 2.0) 'example_class) + ?out t + ) + + (@assertion + (example_class ?length 2.0 ?width 3.0)->area + ?out 6.0 + ) + ) + +(@test ?fun '@class ?inherit '@built_obj) + +;; Testing this method makes no sense... +(@test ?fun 'initializeInstance ?inherit '@built_obj) + diff --git a/test/macros/f-strings_test.scm b/test/macros/f-strings_test.scm index e69de29..db22e74 100644 --- a/test/macros/f-strings_test.scm +++ b/test/macros/f-strings_test.scm @@ -0,0 +1,223 @@ + +(@test + ?fun '@to_string + + (@assertion + ?doc "Works with symbols." + (@to_string 'abc) + ?out "abc" + ) + + (@assertion + ?doc "Works with symbols containing special characters." + (@to_string '@abc_\@\ def\-0) + ?out "@abc_@ def-0" + ) + + (@assertion + ?doc "Works with strings" + (@to_string "this is a string") + ?out "this is a string" + ) + + (@assertion + ?doc "Works with strings and spec" + (@to_string "this is a string" "%N") + ?out "\"this is a string\"" + ) + + (@assertion + ?doc "Works with atoms." + (mapcar '@to_string '( 12.27 42 nil)) + ?out '( "12.27" "42" "nil" ) + ) + + (@assertion + ?doc "Works with lists." + (@letf ( ( @str.pretty nil ) ) (@to_string '( 12.27 42 nil '( a b c )))) + ?out "(12.27 42 nil (quote (a b c)))" + ) + + (@assertion + ?doc "Works with lists (pretty printed)." + (@letf ( ( @str.pretty t ) ) (@to_string '( 12.27 42 nil '( a b c)))) + ?out "( 12.27 42 nil '( a b c ) )" + ) + + ) + +(@test + ?fun '@str + + (@assertion + ?doc "Simple replacement." + (@str "The result of 12+27 is {12+27}.") + ?out "The result of 12+27 is 39." + ) + + (@assertion + ?doc "Variables replacement." + (let ( ( a 12 ) ( b 27 ) ) (@str "The result of {a}+{b} is {a+b}.")) + ?out "The result of 12+27 is 39." + ) + + (@assertion + ?doc "Double-brackets are not evaluated." + (let ( ( var 'evaluated ) ) (@str "This is {var}, this is not {{evaluated}}.")) + ?out "This is evaluated, this is not {evaluated}." + ) + + (@assertion + ?doc "Formatting is taken in account." + (let ((str "simple string")) (@str "no format: {str}, %s format: {str%s}, %N format: {str%N}")) + ?out "no format: simple string, %s format: simple string, %N format: \"simple string\"" + ) + + (@assertion + ?doc "Non-closed brackets raise errors." + (eval '(let ( ( var 'evaluated ) ) (@str "This is {var"))) + ?error "Open-bracket is never closed in f-string" + ) + + (@assertion + ?doc "Non-open brackets are [maybe] okay?" + (let ( ( var 'evaluated ) ) (@str "This is var}")) + ?out "This is var}" + ) + + ) + +(@test + ?fun '@debug + ?doc "Messages are printed only when using debugging mode." + + (@assertion + (@letf ( ( (@get_debug) nil ) ) (@debug "This should not be printed")) + ?out nil + ) + + (@assertion + (@letf ( ( (@get_debug) t ) ) (@debug "This should be printed")) + ?out nil + ?info "This should be printed" + ) + + ) + +(@test + ?fun '@info + ?doc "Info messages using f-string formatting." + + (@assertion + (@info "The result of 12+27 is {12+27}") + ?out nil + ?info "The result of 12+27 is 39" + ) + + (@assertion + (@info "The value of pi is {(acos -1)%7.4f}") + ?out nil + ?info "The value of pi is 3.1416" + ) + + (@assertion + (let ( ( str "this is a string" ) ) (@info "Single-quotes : '{str}' ; Double-quotes : {str%N}")) + ?out nil + ?info "Single-quotes : 'this is a string' ; Double-quotes : \"this is a string\"" + ) + ) + +(@test + ?fun '@warn + ?doc "Warn messages using f-string formatting." + + (@assertion + (@warn "The result of 12+27 is {12+27}") + ?out nil + ?warn "The result of 12+27 is 39" + ) + + (@assertion + (@warn "The value of pi is {(acos -1)%7.4f}") + ?out nil + ?warn "The value of pi is 3.1416" + ) + + (@assertion + (let ( ( str "this is a string" ) ) (@warn "Single-quotes : '{str}' ; Double-quotes : {str%N}")) + ?out nil + ?warn "Single-quotes : 'this is a string' ; Double-quotes : \"this is a string\"" + ) + ) + +(@test + ?fun '@error + ?doc "Error messages using f-string formatting." + + (@assertion + (@error "The result of 12+27 is {12+27}") + ?error "The result of 12+27 is 39" + ) + + (@assertion + (@error "The value of pi is {(acos -1)%7.4f}") + ?error "The value of pi is 3.1416" + ) + + (@assertion + (let ( ( str "this is a string" ) ) (@error "Single-quotes : '{str}' ; Double-quotes : {str%N}")) + ?error "Single-quotes : 'this is a string' ; Double-quotes : \"this is a string\"" + ) + ) + +(@test + ?fun '@fprintf + ?doc "Fprintf messages using f-string formatting." + + (@assertion + (@with ( ( port (outstring) ) ) (@fprintf port "The result of 12+27 is {12+27}") (getOutstring port)) + ?out "The result of 12+27 is 39" + ) + + (@assertion + (@with ( ( port (outstring) ) ) (@fprintf port "The value of pi is {(acos -1)%7.4f}") (getOutstring port)) + ?out "The value of pi is 3.1416" + ) + + (@assertion + (@with ( ( port (outstring) ) ) + (let ( ( str "this is a string" ) ) + (@fprintf port "Single-quotes : '{str}' ; Double-quotes : {str%N}") + (getOutstring port) + )) + ?out "Single-quotes : 'this is a string' ; Double-quotes : \"this is a string\"" + ) + ) + +(@test + ?fun '@assert + ?doc "Assertions with error message using f-string formatting" + + (@assertion + (@assert 12+27 "This message will never be printed.") + ?out nil + ) + + (@assertion + (let ( ( val 12) ) (@assert (oddp val) "Value should be odd: {val}")) + ?error "Value should be odd: 12" + ) + + (@assertion + (let ( ( val "12.27") ) (@assert (numberp val) "Value should be a number: {val}")) + ?error "Value should be a number: 12.27" + ) + + (@assertion + ?doc "Message is clearer when using %N formatting." + (let ( ( val "12.27") ) (@assert (numberp val) "Value should be a number: {val%N}")) + ?error "Value should be a number: \"12.27\"" + ) + + ) + diff --git a/test/macros/function_test.scm b/test/macros/function_test.scm index 0bc99da..ef23c72 100644 --- a/test/macros/function_test.scm +++ b/test/macros/function_test.scm @@ -1,5 +1,4 @@ - (@test ?fun '_\@fun_type_assert_rec ?doc "Make sure type-checking supports symbols, nested lists and '|' operator." @@ -382,5 +381,67 @@ );test +(@test + ?fun '@proc + ?doc "Define functions and call them." + + ;; Without argument + + @proc( no_args() + ?doc "Always return t." + t + ) + + (@assertion + (no_args) + ?out t + ) + + (@assertion + (no_args 12) + ?error "no_args: too many arguments (0 expected, 1 given) - (12)" + ) + + (@assertion + (no_args 12 27) + ?error "no_args: too many arguments (0 expected, 2 given) - (12 27)" + ) + + ) + +;; ------------------------------------------------------- +;; Type checking +;; ------------------------------------------------------- + +(@test + ?fun '@type_add + ?doc "Add a dummy type and test it." + + (@assertion + (@type? 'list nil) + ?out t + ) + + (@assertion + (@type? 'list (list 'a 12.27)) + ?out '(a 12.27) + ) + + (@assertion + (isCallable + (@type_add + 'dummy_symbol_float_pair + (lambda (obj) (and (listp obj) (symbolp (car obj)) (floatp (cadr obj)) (not (cddr obj)))) + )) + ?out t + ) + + (@assertion + (@type? 'dummy_symbol_float_pair (list 'a 12.27)) + ?out '(a 12.27) + ) + + ) +(@test ?fun '@type? ?inherit '@type_add) diff --git a/test/macros/macro_test.scm b/test/macros/macro_test.scm index b28b04f..5ba2a6c 100644 --- a/test/macros/macro_test.scm +++ b/test/macros/macro_test.scm @@ -1,3 +1,181 @@ +;; ------------------------------------------------------- +;; @arglist +;; ------------------------------------------------------- +(@test + ?fun '_\@arglist_expand + ?doc "`_\\@arglist_expand' is further tested in `@arglist`." + (@assertion + (_\@arglist_expand '( arg0 arg1 )) + ?out '((arg0) (arg1)) + ) + + (@assertion + (_\@arglist_expand '( arg0 arg1 "tg" )) + ?out '((arg0 ?type string) (arg1 ?type general)) + ) + + (@assertion + (_\@arglist_expand '( arg0 arg1 @key key_arg @rest argn "tgsg" )) + ?out '((arg0 ?type string) (arg1 ?type general) @key (key_arg ?def nil ?type symbol) @rest (argn ?def nil ?type general)) + ) + + (@assertion + (_\@arglist_expand '( arg0 arg1 @optional opt_arg @rest argn "tgsg" )) + ?out '((arg0 ?type string) (arg1 ?type general) (opt_arg ?def nil ?type symbol) @rest (argn ?def nil ?type general)) + ) + + ) + +(@test + ?fun '@arglist + ?doc "Retrieves argument of some well known functions." + + (@assertion + (@arglist '@arglist) + ?out '((fun ?type function)) + ) + + (@assertion + (@arglist '@alphalessp) + ?out '((str0 ?type (string | symbol)) (str1 ?type (string | symbol))) + ) + + (@assertion + (@arglist (lambda ( arg0 arg1 @key key_arg @rest argn "tgsg" ) nil)) + ?out '((arg0 ?type string) (arg1 ?type general) \@key (key_arg ?def nil ?type symbol) \@rest (argn ?def nil ?type general)) + ) + + ) + +(@test + ?fun 'setf_\@arglist + ?doc "`@arglist` output can be modified on demand." + + (@assertion + (inSkill (defmacro dummy_macro (@rest args) args)) + ?out 'dummy_macro + ) + + (@assertion + (@arglist 'dummy_macro) + ?out '((___)) + ) + + (@assertion + (setf (@arglist 'dummy_macro) '(\@rest (args ?def nil))) + ?out '(@rest (args ?def nil)) + ) + + (@assertion + (@arglist 'dummy_macro) + ?out '(@rest (args ?def nil)) + ) + + ) + +;; ------------------------------------------------------- +;; @fdoc +;; ------------------------------------------------------- + +(@test + ?fun '@fdoc + ?doc "Return docstrings of well-known functions." + + (@assertion + (@fdoc '@alphalessp) + ?out "Return t if STR0 is lower than STR1 regarding alphanumeric comparison, nil otherwise.\n\nThis is an improved `alphalessp' for strings containing numbers, which relies on `alphaNumCmp'.\nThis comparison works nicely with software versions." + ) + + (@assertion + (defglobalfun dummy_function () "Dummy docstring" 12 27) + ?out 'dummy_function + ) + + (@assertion + (@fdoc 'dummy_function) + ?out "Dummy docstring" + ) + + (@assertion + (setf (@fdoc 'dummy_function) "Docstring added afterwards.") + ?out "Docstring added afterwards." + ) + + (@assertion + (@fdoc 'dummy_function) + ?out "Docstring added afterwards." + ) + + ) + +(@test + ?fun 'setf_\@fdoc + ?inherit '@fdoc + ) + +;; ------------------------------------------------------- +;; @output +;; ------------------------------------------------------- + +(@test + ?fun '@output + ?doc "Return output of well-known functions." + + (@assertion + (@output '@alphalessp) + ?out '(t | nil) + ) + + (@assertion + (defglobalfun dummy_function () t) + ?out 'dummy_function + ) + + (@assertion + (@output 'dummy_function) + ?out nil + ) + + (@assertion + (setf (@output 'dummy_function) t) + ?out t + ) + + (@assertion + (@output 'dummy_function) + ?out t + ) + ) + +(@test + ?fun 'setf_\@output + ?inherit '@output + ) + +;; ------------------------------------------------------- +;; @macro +;; ------------------------------------------------------- + +(@test + ?fun '@macro + ?doc "`@macro` defines macro and stores valid docstring." + + (@assertion + (inSkill (@macro dummy_wrap ( in out @rest body ) "macro docstring" (list 'unwindProtect (constar 'progn in body) out))) + ?out 'dummy_wrap + ) + + (@assertion + (expandMacro '(dummy_wrap in out body)) + ?out '(unwindProtect (progn in body) out) + ) + + (@assertion + (@fdoc 'dummy_wrap) + ?out "macro docstring" + ) + + ) diff --git a/test/macros/patterns_test.scm b/test/macros/patterns_test.scm index 2d34986..32de897 100644 --- a/test/macros/patterns_test.scm +++ b/test/macros/patterns_test.scm @@ -1,3 +1,22 @@ +(@test + ?fun '@no_lint + ?doc "`@no_lint` simply works like `progn`." + + (@assertion + (@no_lint 12 27) + ?out 27 + ) + + (@assertion + (@no_lint (println 12) 27 42) + ?info "12\n" + ?out 42 + ) + ) + +;; ======================================================= +;; Debugging macro +;; ======================================================= (@test ?fun '@show @@ -19,19 +38,132 @@ ) -; (progn +;; ======================================================= +;; case & caseq +;; ======================================================= + +(@test + ?fun '@case + ?doc "Works like `case` but raises meaningful errors in unsupported cases." + + (@assertion + (@case 12 + ( 12 'even ) + ( 27 'odd ) + ) + ?out 'even + ) + + (@assertion + (@case "ellipse" + ( "rect" 'rectangle ) + ( "ellipse" 'ellipse ) + ( "polygon" 'polygon ) + ) + ?out 'ellipse + ) + + (@assertion + (@case "inst" + ( "rect" 'rectangle ) + ( "ellipse" 'ellipse ) + ( "polygon" 'polygon ) + ) + ?error "Value is not amongst valid cases (\"rect\" \"ellipse\" \"polygon\")" + ) + ) + +(@test + ?fun '@caseq + ?doc "Works like `caseq` but raises meaningful errors in unsupported cases." + + (@assertion + (@caseq 12 + ( 12 'even ) + ( 27 'odd ) + ) + ?out 'even + ) + + (@assertion + (@caseq 'ellipse + ( rect 'rectangle ) + ( ellipse 'ellipse ) + ( polygon 'polygon ) + ) + ?out 'ellipse + ) + + (@assertion + (@caseq 'inst + ( rect 'rectangle ) + ( ellipse 'ellipse ) + ( polygon 'polygon ) + ) + ?error "Value is not amongst valid cases (rect ellipse polygon)" + ) + ) + +;; ======================================================= +;; wrap +;; ======================================================= + +(@test + ?fun '@wrap + + (@assertion + ?doc "@wrap executes operation in the right order." + (@wrap (println 'BEG) (println 'END) (println 'BODY) 12) + ?out 12 + ?info "BEG\nBODY\nEND\n" + ) + + (@assertion + ?doc "@wrap executes end expression even when an error occurs." + (@wrap (println 'BEG) (println 'END) (error "BODY") 12) + ?info "BEG\nEND\n" + ?error "BODY" + ) + ) + +;; ======================================================= +;; letf +;; ======================================================= -; (@if (getShellEnvVar "IF_VARIABLE") -; (@info "IF_VARIABLE is defined: {(getShellEnvVar \"IF_VARIABLE\")}") -; (@warn "IF_VARIABLE is not defined") -; 12) +(@test + ?fun '@setf + ?doc "`@setf` is mostly meant to support nil in `(setf (getShellEnvVar ...) nil)`." -; (@nif (getShellEnvVar "NIF_VARIABLE") -; (@info "NIF_VARIABLE is defined: {(getShellEnvVar \"NIF_VARIABLE\")}") -; (@warn "NIF_VARIABLE is not defined") -; 27) + (@assertion + (@setf (getShellEnvVar "DUMMY_VARIABLE") "DUMMY_VALUE") + ?out t + ) -; ) + (@assertion + (getShellEnvVar "DUMMY_VARIABLE") + ?out "DUMMY_VALUE" + ) + + (@assertion + (@setf (getShellEnvVar "DUMMY_VARIABLE") nil) + ?out t + ) + + (@assertion + (getShellEnvVar "DUMMY_VARIABLE") + ?out nil + ) + + (@assertion + ?doc "`@setf` also works with any other `setf` helper." + (let ( ( dpl '( nil a 12 ) ) + ) + (@setf dpl->b 27) + dpl->b + ) + ?out 27 + ) + ) (@test ?fun '@letf @@ -58,6 +190,9 @@ );test +;; ======================================================= +;; with +;; ======================================================= (@test ?fun '@with @@ -66,7 +201,7 @@ ?doc "`@with' properly closes ports" (letseq ( ( port (outstring) ) ( str (@with ( ( out_port port ) - ) + ) (fprintf out_port "Hello World!\n") (getOutstring out_port) )) @@ -76,11 +211,266 @@ ?out (list nil "Hello World!\n") ) - );test + ;; TODO - test @with with dummy cellview using ?skip + + );test) + +;; ======================================================= +;; Anaphoric macros +;; ======================================================= + +(@test + ?fun '@if + + (@assertion + ?doc "`@if` works like `if` when condition is non-nil." + (@if t 'then 'else 12) + ?out 'then + ) + + (@assertion + ?doc "`@if` else statement can contain several expressions." + (@if nil 'then 'else 12) + ?out 12 + ) + + (@assertion + ?doc "`@if` can store the condition result into a variable." + (@if 12+27 + ?var res + (list res res) + 'else + ) + ?out '(39 39) + ) + + ) + +(@test + ?fun '@nif + + (@assertion + ?doc "`@nif` works like not `if` when condition is nil." + (@nif nil 'else 'then 12) + ?out 'else + ) + + (@assertion + ?doc "`@nif` then statement can contain several expressions." + (@nif t 'else 'then 12) + ?out 12 + ) + (@assertion + ?doc "`@nif` can store the condition result into a variable." + (@nif 12+27 + ?var res + 'then + (list res res) + ) + ?out '(39 39) + ) + + ) + +(@test + ?fun '@when + + (@assertion + ?doc "`@when` works like `when` without variable." + (eval '(@when t 'then 12)) + ?error "?var is required and should be an unquoted symbol" + ) + + (@assertion + ?doc "`@when` can store the condition result into a variable." + (@when 12+27 + ?var res + 'then + (list res res) + ) + ?out '(39 39) + ) + + ) + +;; ======================================================= +;; While +;; ======================================================= + +(@test + ?fun '@while + + (@assertion + ?doc "`@while` returns the list of last loop values by default." + (let ( ( i 3 ) + ) + (@while (plusp i) i--) + ) + ?out '(3 2 1) + ) + + (@assertion + ?doc "`@while mapc` returns the list condition results." + (let ( ( l (list 1 2 3) ) + ) + (@while mapc (pop l)) + ) + ?out '(1 2 3) + ) + + (@assertion + ?doc "`@while mapcar` returns the list of last loop values." + (let ( ( i 3 ) + ) + (@while mapcar (plusp i) i--) + ) + ?out '(3 2 1) + ) + + (@assertion + ?doc "`@while mapcan` returns the concatenated list of last loop values." + (let ( ( i 3 ) + ) + (@while mapcan (plusp i) (list i-- t)) + ) + ?out '(3 t 2 t 1 t) + ) + + ;; Using ?var + + (@assertion + ?doc "`@while` accepts ?var and returns the list of last loop values by default." + (let ( ( l (list 1 2 3) ) + ) + (@while (pop l) + ?var elt + (println elt) + (list elt elt) + ) + ) + ?info "1\n2\n3\n" + ?out '((1 1) (2 2) (3 3)) + ) + + (@assertion + ?doc "`@while mapc` accepts ?var and returns the list condition results." + (let ( ( l (list 1 2 3) ) + ) + (@while mapc (pop l) + ?var elt + (println elt) + ) + ) + ?info "1\n2\n3\n" + ?out '(1 2 3) + ) + + (@assertion + ?doc "`@while mapcar` accepts ?var and returns the list of last loop values." + (let ( ( l (list 1 2 3) ) + ) + (@while mapcar (pop l) + ?var elt + (println elt) + (list elt elt) + ) + ) + ?info "1\n2\n3\n" + ?out '((1 1) (2 2) (3 3)) + ) + + (@assertion + ?doc "`@while mapcan` accepts ?var and returns the concatenated list of last loop values." + (let ( ( l (list 1 2 3) ) + ) + (@while mapcan (pop l) + ?var elt + (println elt) + (list elt elt) + ) + ) + ?info "1\n2\n3\n" + ?out '(1 1 2 2 3 3) + ) + + ) + +;; ======================================================= +;; For +;; ======================================================= + +(@test + ?fun '@for + + (@assertion + ?doc "`@for` returns the list of last loop values." + (@for i 0 9 i) + ?out '(0 1 2 3 4 5 6 7 8 9) + ) + + (@assertion + ?doc "`@for mapcar` returns the list of last loop values." + (@for mapcar var 0 2 (println var) (list var var)) + ?info "0\n1\n2\n" + ?out '((0 0) (1 1) (2 2)) + ) + + (@assertion + ?doc "`@for mapcan` returns the concatenated list of last loop values." + (@for mapcan var 0 2 (println var) (list var var)) + ?info "0\n1\n2\n" + ?out '(0 0 1 1 2 2) + ) + + ) + +;; ======================================================= +;; Foreach D-bind +;; ======================================================= + +(@test + ?fun '@foreach_dbind + + (@assertion + ?doc "`@foreach_dbind` returns the list of last loop values." + (@foreach_dbind ( key value ) '( ( a 12) ( b 27 ) ( c 42 ) ) + (println key) + (list value value) + ) + ?info "a\nb\nc\n" + ?out '((12 12) (27 27) (42 42)) + ) + + (@assertion + ?doc "`@foreach_dbind mapc` returns the list of inputs." + (@foreach_dbind mapc ( key value ) '( ( a 12) ( b 27 ) ( c 42 ) ) + (println key) + (list value value) + ) + ?info "a\nb\nc\n" + ?out '((a 12) (b 27) (c 42)) + ) + + (@assertion + ?doc "`@foreach_dbind` returns the list of last loop values." + (@foreach_dbind mapcar ( key value ) '( ( a 12) ( b 27 ) ( c 42 ) ) + (println key) + (list value value) + ) + ?info "a\nb\nc\n" + ?out '((12 12) (27 27) (42 42)) + ) + + (@assertion + ?doc "`@foreach_dbind` returns the list of last loop values." + (@foreach_dbind mapcan ( key value ) '( ( a 12) ( b 27 ) ( c 42 ) ) + (println key) + (list value value) + ) + ?info "a\nb\nc\n" + ?out '(12 12 27 27 42 42) + ) + + ) -;; TODO - test @while -; ILS-2> l = (list 1 2 3) -; (1 2 3) -; ILS-2> (@while mapc (pop l) ?var toto (println toto)) -; (1 2 3) diff --git a/test/testing_test.scm b/test/testing_test.scm index e69de29..6eb8a71 100644 --- a/test/testing_test.scm +++ b/test/testing_test.scm @@ -0,0 +1,70 @@ +;; Mock @test behavior so that documentation is well printed. + +(defmethod @get_assertions ( (test list) ) + "Get TEST assertions objects." + test->assertions + ) + +(setf @test.@test + `(nil + doc "@test is used to define tests. A test should only contain assertion calls." + assertions + ( ( nil + body_quoted + (@test + ?fun '@xor + ?doc "`@xor` is SKILL boolean XOR equivalent." + (@assertion + (@xor t t) + ?out nil + ) + (@assertion + (@xor nil nil) + ?out nil + ) + (@assertion + (@xor t nil) + ?out t + ) + (@assertion + (@xor nil t) + ?out t + ) + ) + body_result nil + ) + ) + )) + +;; Testing functions are already tested in metatest as they cannot test themselve properly... +(@test ?fun '@assertion ?inherit '@test) +(@test ?fun '@get_assertions ?inherit '@test) +(@test ?fun '@set_status ?inherit '@test) +(@test ?fun '@update_status ?inherit '@test) +(@test ?fun '@test_print_report ?inherit '@test) +(@test ?fun '@test_run_all ?inherit '@test) + + +(@test + ?fun 'printself + + (@assertion + ?doc "`printself` works properly on integers" + (printself 12) + ?out "12" + ) + + (@assertion + ?doc "`printself` works properly on strings" + (printself "abc") + ?out "\"abc\"" + ) + + (@assertion + ?doc "`printself` works properly on lists" + (printself (list 12 27 "")) + ?out "(12 27 \"\")" + ) + ) + + diff --git a/test/utils_test.scm b/test/utils_test.scm index 4f4a0bd..6f44160 100644 --- a/test/utils_test.scm +++ b/test/utils_test.scm @@ -15,6 +15,35 @@ ?out "12\n" )) +;; ======================================================= +;; Booleans +;; ======================================================= + +(@test + ?fun '@xor + ?doc "@xor truth table." + + (@assertion + (@xor nil nil) + ?out nil + ) + + (@assertion + (@xor t nil) + ?out t + ) + + (@assertion + (@xor nil t) + ?out t + ) + + (@assertion + (@xor t t) + ?out nil + ) + ) + ;; ======================================================= ;; Unix utilities ;; ======================================================= @@ -100,6 +129,36 @@ ) +(@test + ?fun '@mktemp + ?doc "Temporary files are generated using Unix `mktemp`." + + (@assertion + (let ( ( file (@mktemp) ) ) (prog1 (and (stringp file) (isFile file)) (deleteFile file))) + ?out t + ) + + (@assertion + (let ( ( file0 (@mktemp "file.XXX") ) + ( file1 (@mktemp "file.XXX") ) + ) + (prog1 + (and (stringp file0) (isFile file0) + (stringp file1) (isFile file1) + (nequal file0 file1) + ) + (progn (deleteFile file0) (deleteFile file1)) + )) + ?out t + ) + + (@assertion + (@mktemp "test") + ?error "mktemp: too few X's in template" + ) + + ) + ;; ======================================================= ;; Lists ;; ======================================================= @@ -156,6 +215,28 @@ ) +(@test + ?fun '@repeat + ?doc "`@repeat` works with any object." + + (@assertion + (@repeat "abc" 5) + ?out '("abc" "abc" "abc" "abc" "abc") + ) + + (@assertion + (@repeat (list 12 27) 3) + ?out '((12 27) (12 27) (12 27)) + ) + + (@assertion + ?doc "All elements are identical (each reference is exactly the same pointer)." + (let ( ( l (@repeat (list 0 1 2 3) 10) ) ) (forall elt (cdr l) (eq elt (car l)))) + ?out t + ) + + ) + ;; ======================================================= ;; Tables ;; ======================================================= @@ -451,8 +532,14 @@ Kevin layouter\n\ ) - - +; (@test +; ?fun '@escape_chars +; (@assertion +; (@escape_chars "Escaped characters : \\@ \\\\ \"") +; ?out "Escaped characters : \\@ \\\\ \\\"" +; ) +; ;; TODO - Not sure @escape_chars is useful +; ) ;; ======================================================= ;; Numbers @@ -591,19 +678,454 @@ Kevin layouter\n\ ) +(@test + ?fun '@hex_to_dec + ?doc "Return hexadecimal values of given numbers." + ?skip (not (isCallable 'numConv)) + + (@assertion + (@hex_to_dec "0") + ?out 0 + ) + + (@assertion + (@hex_to_dec "1") + ?out 1 + ) + + (@assertion + (@hex_to_dec "A") + ?out 10 + ) + + (@assertion + (@hex_to_dec "F") + ?out 15 + ) + + (@assertion + (@hex_to_dec "G") + ?error "Not a valid hexadecimal number: \"G\"" + ) + + (@assertion + (@hex_to_dec "FF") + ?out 255 + ) + + (@assertion + (@hex_to_dec "E12AF25") + ?out 236105509 + ) + + (@assertion + ?doc "Make sure back and forth convertion is valid." + (forall num '( 0 1 12 27 42 4455 1234567890 ) + (equal num (@hex_to_dec (@dec_to_hex num))) + ) + ?out t + ) + + ) + +(@test + ?fun '@dec_to_hex + ?doc "Return hexadecimal values of given numbers." + ?skip (not (isCallable 'numConv)) + + (@assertion + (@dec_to_hex 0) + ?out "0" + ) + + (@assertion + (@dec_to_hex 1) + ?out "1" + ) + + (@assertion + (@dec_to_hex 10) + ?out "a" + ) + + (@assertion + (@dec_to_hex 15) + ?out "f" + ) + + (@assertion + (@dec_to_hex 255) + ?out "ff" + ) + + (@assertion + (@dec_to_hex 236105509) + ?out "e12af25" + ) + + (@assertion + (@dec_to_hex 255 4) + ?out "00ff" + ) + + (@assertion + ?doc "Make sure back and forth convertion is valid." + (forall num '( 0 1 12 27 42 4455 1234567890 ) + (equal num (@dec_to_hex (@hex_to_dec num))) + ) + ?out t + ) + + ) + + +;; ======================================================= +;; Bounding Boxes +;; ======================================================= + +(@test + ?fun '@box_width + ?doc "Check bounding box width for different objects." + ?skip (not (isCallable 'topEdge)) + + (@assertion + (@box_width (list 0:0 1:1)) + ?out 1 + ) + + (@assertion + (@box_width (list 0.0:12.01 27.3:42.002)) + ?out 27.3 + ) + + (@assertion + (@box_width (list -4.3:-22.123 -0.1:-0.543)) + ?out 4.2 + ) + + ) + +(@test + ?fun '@box_height + ?doc "Check bounding box height for different objects." + ?skip (not (isCallable 'topEdge)) + + (@assertion + (@box_height (list 0:0 1:1)) + ?out 1 + ) + + (@assertion + (@box_height (list 0.0:12.01 27.3:42.002)) + ?out 29.992 + ) + + (@assertion + (@box_height (list -4.3:-22.123 -0.1:-0.543)) + ?out 21.58 + ) + + ) ;; ======================================================= ;; Miscellaneous ;; ======================================================= +(@test + ?fun '@skill_files + + (@assertion + ?doc "Return SKILL files from a known folder." + (sort (mapcar '@basename (@skill_files (list "$SKILL_SHARP_ROOT/metatest/globals"))) '@alphalessp) + ?out '("classes.il" "classes.ils" "definitions.scm" "functions.il" "functions.ils" "variables.il" "variables.ils") + ) + ) + +(@test + ?fun '@read_file + ?doc "Retrieve contents of known files." + + (@assertion + (let ( ( tmp_file (@mktemp) ) + ) + (unwindProtect + (progn + (@bash (@str "echo 12 > {tmp_file} ; echo 27 >> {tmp_file}")) + (@read_file tmp_file) + ) + (deleteFile tmp_file) + )) + ?out "12\n27\n" + ) + ) + +(@test + ?fun '@write_file + ?doc "Retrieve contents of known files." + + (@assertion + (let ( ( tmp_file (@mktemp) ) + ) + (unwindProtect + (progn + (@write_file tmp_file "12\n27\n") + (@read_file tmp_file) + ) + (deleteFile tmp_file) + )) + ?out "12\n27\n" + ) + + (@assertion + (let ( ( tmp_file (@mktemp) ) + ) + (unwindProtect + (progn + (@write_file tmp_file "12\n27\n") + (@write_file tmp_file "42\n") + (@read_file tmp_file) + ) + (deleteFile tmp_file) + )) + ?out "42\n" + ) + + (@assertion + (let ( ( tmp_file (@mktemp) ) + ) + (unwindProtect + (progn + (@write_file tmp_file "12\n27\n") + (@write_file tmp_file "42\n" "a") + (@read_file tmp_file) + ) + (deleteFile tmp_file) + )) + ?out "12\n27\n42\n" + ) + ) ;; ======================================================= ;; Predicates ;; ======================================================= +(@test + ?fun '@nonblankstring? + + (@assertion + ?doc "Return nil for anything that is not a string." + (@nonblankstring? 12) + ?out nil + ) + + (@assertion + ?doc "Return nil for an empty string." + (@nonblankstring? "") + ?out nil + ) + + (@assertion + ?doc "Return nil for a whitespace string." + (@nonblankstring? " \t") + ?out nil + ) + + (@assertion + ?doc "Return the provided string otherwise." + (@nonblankstring? " abc ") + ?out " abc " + ) + + ) ;; ======================================================= ;; Universal getter ;; ======================================================= +(@test + ?fun '@get + ?doc "`@get` can retrieve several properties in one statement." + + (@assertion + (setq dpl '( nil prop0 12 prop1 ( nil a "a" b "b" c "c" ) prop2 42 )) + ?out '(nil prop0 12 prop1 (nil a "a" b "b" c "c") prop2 42) + ) + + (@assertion + (@get dpl 'prop1 'a) + ?out "a" + ) + + (@assertion + (setf (@get dpl 'prop1 'a) 27) + ?out 27 + ) + + (@assertion + (@get dpl 'prop1 'a) + ?out 27 + ) + ) + +(@test ?fun 'setf_\@get ?inherit '@get) + +;; ======================================================= +;; Dbobjects +;; ======================================================= + +(unless (findClass 'dbobject) + (defclass dbobject () + ( ( libName @initarg libName @initform nil ) + ( cellName @initarg cellName @initform nil ) + ( viewName @initarg viewName @initform nil ) + ( cellViewType @initarg cellViewType @initform nil ) + ) + )) + +(defvar test_db_cv + (makeInstance 'dbobject + ?libName "TEST_LIB" + ?cellName "TEST_CELL" + ?viewName "schematic" + ?cellViewtype "schematic" + )) + +(@test + ?fun '@lcv + ?doc "Return the library, cell and view of input dbobject." + + (@assertion + (@lcv test_db_cv) + ?out '( "TEST_LIB" "TEST_CELL" "schematic") + ) + ) + +(@test + ?fun '@view_type + ?doc "Return the view type whatever the input." + ?skip (not (isCallable 'ddGetObj)) + + (@assertion + (@view_type test_db_cv) + ?out "schematic" + ) + + ;; TODO - test with ddview, list and string as well + ;; TODO - Build read-only & writable test libraries to run when running tests inside Virtuoso + ) + +;; ======================================================= +;; Tech Files +;; ======================================================= + +(@test + ?fun '@tech_libs + ?doc "Return the current tech libraries." + ?skip (not (isCallable 'techGetTechFile)) + + (@assertion + (and (@tech_libs) (forall lib (@tech_libs) (ddIsId lib))) + ?out t + ) + + (@assertion + (car (member "analogLib" (@tech_libs)~>name)) + ?out "analogLib" + ) + + ) + +(@test + ?fun '@tech_files + ?doc "Return the current tech libraries." + ?skip (not (isCallable 'techGetTechFile)) + + (@assertion + (and (@tech_files) (forall tf (@tech_files) (dbobjectp tf))) + ?out t + ) + + ) + +;; ======================================================= +;; Windows +;; ======================================================= + +(@test + ?fun '@window_number + ?doc "Return the window number of any window or session window." + ?skip (not (isCallable 'windowp)) + + (@assertion + (@window_number (@ciw)) + ?out 1 + ) + + ;; TODO - Test for classic windows + ;; TODO - Test for session windows + ) + +;; ======================================================= +;; Menus +;; ======================================================= + +(@test + ?fun '@menu_by_label + ?doc "Return menu by label" + ?skip (not (isCallable 'hiGetBannerMenus)) + + (@assertion + (hiIsMenu (@menu_by_label ?window (@ciw) ?label "tools")) + ?out t + ) + ) + +(@test + ?fun '@menu_item_by_label + ?doc "Return menu item by label" + ?skip (not (isCallable 'hiGetBannerMenus)) + + (@assertion + (type (@menu_item_by_label ?window (@ciw) ?menu_label "tools" ?label "SKILL API Finder")) + ?out 'hiMenuItem + ) + ) + +(@test + ?fun '@menu_replace_item + ?skip t + + (@assertion + ?doc "Replace SKILL API Finder" + (@menu_replace_item + ?window (hiGetCIWindow) + ?menu_label "Tools" + ?item_label "SKILL API Finder" + ?new_item_icon (hiLoadIconData (@realpath "$SKILL_SHARP_ROOT/pictures/icons/sharp.png")) + ?new_item_callback "(if (equal \"TRUE\" (getShellEnvVar \"SKILL_SHARP_KEEP_NATIVE_FINDER\")) (startFinder) (@fnd_gui))" + ) + ?out t + ) + + ) + +(@test + ?fun '@menu_insert_item_before + ?skip t + + (@assertion + ?doc "Add SKILL# API Finder" + (@menu_insert_item_before + ?window (hiGetCIWindow) + ?menu_label "Tools" + ?item_label "SKILL API Finder" + ?new_item_name 'skill_sharp_api_finder_item + ?new_item_label "SKILL# API Finder" + ?new_item_icon (hiLoadIconData (@realpath "$SKILL_SHARP_ROOT/pictures/icons/sharp.png")) + ?new_item_callback "(if (equal \"TRUE\" (getShellEnvVar \"SKILL_SHARP_KEEP_NATIVE_FINDER\")) (startFinder) (@fnd_gui))" + ) + ?out t + ) + + )