From a79311ace366231d9776ad84560a077c103fb928 Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Tue, 12 Aug 2025 13:40:04 +0800 Subject: [PATCH 1/2] Added s7 in many branches add s7 tests add 3 rules for s7 modify analysis/abstract-interpreter.sls --- analysis/abstract-interpreter.sls | 17 +- analysis/dependency/file-linkage.sls | 3 +- analysis/identifier/meta.sls | 452 +++++++++++++++++- analysis/identifier/rules/s7/define*.sls | 188 ++++++++ analysis/identifier/rules/s7/define-macro.sls | 49 ++ analysis/identifier/rules/s7/lambda*.sls | 130 +++++ analysis/util.sls | 5 + analysis/workspace.sls | 1 + .../dependency/rules/test-library-import.sps | 6 + .../analysis/dependency/test-file-linkage.sps | 11 + tests/analysis/test-workspace.sps | 10 +- 11 files changed, 866 insertions(+), 6 deletions(-) create mode 100644 analysis/identifier/rules/s7/define*.sls create mode 100644 analysis/identifier/rules/s7/define-macro.sls create mode 100644 analysis/identifier/rules/s7/lambda*.sls diff --git a/analysis/abstract-interpreter.sls b/analysis/abstract-interpreter.sls index 27c44a97..e98404da 100644 --- a/analysis/abstract-interpreter.sls +++ b/analysis/abstract-interpreter.sls @@ -60,6 +60,10 @@ (scheme-langserver analysis identifier rules r7rs define-library-import) (scheme-langserver analysis identifier rules r7rs define-library-export) + (scheme-langserver analysis identifier rules s7 define-macro) + (scheme-langserver analysis identifier rules s7 define*) + (scheme-langserver analysis identifier rules s7 lambda*) + (scheme-langserver analysis identifier self-defined-rules router) (scheme-langserver virtual-file-system index-node) @@ -171,7 +175,7 @@ (cond [(and (equal? r '(define)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,define-process) . ,identifier))] - [(and (equal? r '(define)) (private:top-env=? 'r7rs top)) + [(and (equal? r '(define)) (or (private:top-env=? 'r7rs top) (private:top-env=? 's7 top))) (private-add-rule rules `((,define-r7rs-process) . ,identifier))] [(equal? r '(define-syntax)) (private-add-rule rules `((,define-syntax-process) . ,identifier))] [(equal? r '(define-record-type)) (private-add-rule rules `((,define-record-type-process) . ,identifier))] @@ -246,8 +250,17 @@ [(equal? r '(begin)) (private-add-rule rules `((,do-nothing . ,begin-process) . ,identifier))] - [(and (equal? r '(define-library)) (private:top-env=? 'r7rs top)) + [(and (equal? r '(define-library)) (or (private:top-env=? 'r7rs top) (private:top-env=? 's7 top))) (private-add-rule rules `((,library-import-process-r7rs . ,export-process-r7rs) . ,identifier))] + + [(and (equal? r '(define*)) (private:top-env=? 's7 top)) + (private-add-rule rules `((,define*-process) . ,identifier))] + + [(and (equal? r '(define*)) (private:top-env=? 's7 top)) + (private-add-rule rules `((,define-macro-process) . ,identifier))] + + [(and (equal? r '(define*)) (private:top-env=? 's7 top)) + (private-add-rule rules `((,lambda*-process) . ,identifier))] [else rules]) (route&add diff --git a/analysis/dependency/file-linkage.sls b/analysis/dependency/file-linkage.sls index 95a303dc..f29b7c0c 100644 --- a/analysis/dependency/file-linkage.sls +++ b/analysis/dependency/file-linkage.sls @@ -248,7 +248,8 @@ [(root-library-node index-node top-environment) (let ([func (case top-environment ['r6rs library-import-process] - ['r7rs library-import-process-r7rs])]) + ['r7rs library-import-process-r7rs] + ['s7 library-import-process-r7rs])]) (apply append (map (lambda (l) (map file-node-path (library-node-file-nodes l))) diff --git a/analysis/identifier/meta.sls b/analysis/identifier/meta.sls index 77c1f172..b7ca283b 100644 --- a/analysis/identifier/meta.sls +++ b/analysis/identifier/meta.sls @@ -86,7 +86,7 @@ [(equal? list-instance '(chezscheme csv7)) chezscheme-csv7] [(equal? list-instance '(scheme csv7)) scheme-csv7] [else '()])] - [(equal? top-environment 'r7rs) + [(or (equal? top-environment 'r7rs) (equal? top-environment 's7)) (cond [(equal? list-instance '(scheme base)) scheme-base] [(equal? list-instance '(scheme case lambda)) scheme-case-lambda] @@ -104,6 +104,7 @@ [(equal? list-instance '(scheme time)) scheme-time] [(equal? list-instance '(scheme write)) scheme-write] [(equal? list-instance '(scheme r5rs)) scheme-r5rs] + [(equal? list-instance '(s7)) s7] [else '()])] [else '()])])) @@ -148,7 +149,7 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7 scheme-base scheme-case-lambda scheme-char scheme-complex scheme-cxr scheme-eval scheme-file scheme-inexact scheme-lazy scheme-load scheme-process-context scheme-read scheme-repl -scheme-time scheme-write scheme-r5rs)) +scheme-time scheme-write scheme-r5rs s7)) ;numeric tower (fold-left (lambda (parent identifier-reference) @@ -5500,4 +5501,451 @@ scheme-time scheme-write scheme-r5rs)) (zero? procedure) ) 'r7rs)) +(define s7 (private-process '(s7) '( +(quote syntax) +(if syntax) +(when syntax) +(unless syntax) +(begin syntax) +(set! syntax) +(cond syntax) +(and syntax) +(or syntax) +(case syntax) +(macroexpand syntax) +(let-temporarily syntax) +(define syntax) +(define* syntax) +(define-constant syntax) +(define-macro syntax) +(define-macro* syntax) +(define-expansion syntax) +(define-expansion* syntax) +(define-bacro syntax) +(define-bacro* syntax) +(let syntax) +(let* syntax) +(letrec syntax) +(letrec* syntax) +(do syntax) +(lambda syntax) +(lambda* syntax) +(macro syntax) +(macro* syntax) +(bacro syntax) +(bacro* syntax) +(with-baffle syntax) +(with-let syntax) +(=> syntax) +(syntax-error syntax) + +(else syntax) +(if syntax) +(display procedure) +(write procedure) +(symbol? procedure) +(syntax? procedure) +(gensym? procedure) +(keyword? procedure) +(let? procedure) +(openlet? procedure) +(iterator? procedure) +(macro? procedure) +(c-pointer? procedure) +(input-port? procedure) +(output-port? procedure) +(eof-object? procedure) +(integer? procedure) +(byte? procedure) +(number? procedure) +(real? procedure) +(float? procedure) +(complex? procedure) +(rational? procedure) +(random-state? procedure) +(char? procedure) +(string? procedure) +(list? procedure) +(pair? procedure) +(vector? procedure) +(float-vector? procedure) +(complex-vector? procedure) +(int-vector? procedure) +(byte-vector? procedure) +(hash-table? procedure) +(continuation? procedure) +(procedure? procedure) +(dilambda? procedure) +(boolean? procedure) +(proper-list? procedure) +(sequence? procedure) +(null? procedure) +(undefined? procedure) +(unspecified? procedure) +(c-object? procedure) +(subvector? procedure) +(weak-hash-table? procedure) +(goto? procedure) +(not procedure) +(integer:real? procedure) +(integer:number? procedure) +(integer:any? procedure) +(values procedure) +(bignum? procedure) +(bignum procedure) +(gensym procedure) +(symbol-table procedure) +(symbol->string procedure) +(string->symbol procedure) +(symbol procedure) +(symbol->value procedure) +(symbol->dynamic-value procedure) +(symbol-initial-value procedure) +(immutable! procedure) +(immutable? procedure) +(constant? procedure) +(string->keyword procedure) +(symbol->keyword procedure) +(keyword->symbol procedure) +(curlet procedure) +(unlet procedure) +(outlet procedure) +(rootlet procedure) +(funclet? procedure) +(sublet procedure) +(varlet procedure) +(cutlet procedure) +(inlet procedure) +(owlet procedure) +(coverlet procedure) +(openlet procedure) +(let-ref procedure) +(let-set! procedure) +(let-ref-fallback procedure) +(let-set-fallback procedure) +(make-iterator procedure) +(iterate procedure) +(iterator-sequence procedure) +(iterator-at-end? procedure) +(provided? procedure) +(provide procedure) +(defined? procedure) +(c-object-type procedure) +(c-object-let procedure) +(c-pointer procedure) +(c-pointer-info procedure) +(c-pointer-type procedure) +(c-pointer-weak1 procedure) +(c-pointer-weak2 procedure) +(c-pointer->list procedure) +(port-string procedure) +(port-file procedure) +(port-position procedure) +(port-line-number procedure) +(port-filename procedure) +(pair-line-number procedure) +(pair-filename procedure) +(port-closed? procedure) +(current-input-port procedure) +(current-output-port procedure) +(current-error-port procedure) +(set-current-error-port procedure) +(let->list procedure) +(set-current-input-port procedure) +(set-current-output-port procedure) +(char-ready? procedure) +(close-input-port procedure) +(close-output-port procedure) +(flush-output-port procedure) +(open-input-file procedure) +(open-output-file procedure) +(open-input-string procedure) +(open-output-string procedure) +(get-output-string procedure) +(open-input-function procedure) +(open-output-function procedure) +(newline procedure) +(write procedure) +(display procedure) +(read-char procedure) +(peek-char procedure) +(write-char procedure) +(write-string procedure) +(read-byte procedure) +(write-byte procedure) +(read-line procedure) +(read-string procedure) +(read procedure) +(call-with-input-string procedure) +(call-with-input-file procedure) +(with-input-from-string procedure) +(with-input-from-file procedure) +(call-with-output-string procedure) +(call-with-output-file procedure) +(with-output-to-string procedure) +(with-output-to-file procedure) +(directory? procedure) +(file-exists? procedure) +(delete-file procedure) +(getenv procedure) +(system procedure) +(directory->list procedure) +(file-mtime procedure) +(real-part procedure) +(imag-part procedure) +(numerator procedure) +(denominator procedure) +(even? procedure) +(odd? procedure) +(zero? procedure) +(positive? procedure) +(negative? procedure) +(infinite? procedure) +(nan? procedure) +(complex procedure) +(+ procedure) +(- procedure) +(* procedure) +(/ procedure) +(min procedure) +(max procedure) +(quotient procedure) +(remainder procedure) +(modulo procedure) +(= procedure) +(< procedure) +(> procedure) +(<= procedure) +(>= procedure) +(gcd procedure) +(lcm procedure) +(rationalize procedure) +(random procedure) +(random-state procedure) +(expt procedure) +(log procedure) +(ash procedure) +(exp procedure) +(abs procedure) +(magnitude procedure) +(angle procedure) +(sin procedure) +(cos procedure) +(tan procedure) +(sinh procedure) +(cosh procedure) +(tanh procedure) +(asin procedure) +(acos procedure) +(atan procedure) +(asinh procedure) +(acosh procedure) +(atanh procedure) +(sqrt procedure) +(floor procedure) +(ceiling procedure) +(truncate procedure) +(round procedure) +(logand procedure) +(logior procedure) +(logxor procedure) +(lognot procedure) +(logbit? procedure) +(integer-decode-float procedure) +(nan procedure) +(nan-payload procedure) +(integer-length procedure) +(inexact->exact procedure) +(exact->inexact procedure) +(exact? procedure) +(inexact? procedure) +(make-polar procedure) +(random-state->list procedure) +(number->string procedure) +(string->number procedure) +(char-upcase procedure) +(char-downcase procedure) +(char->integer procedure) +(integer->char procedure) +(char-upper-case? procedure) +(char-lower-case? procedure) +(char-alphabetic? procedure) +(char-numeric? procedure) +(char-whitespace? procedure) +(char=? procedure) +(char? procedure) +(char<=? procedure) +(char>=? procedure) +(char-position procedure) +(string-position procedure) +(make-string procedure) +(string-ref procedure) +(string-set! procedure) +(string=? procedure) +(string? procedure) +(string<=? procedure) +(string>=? procedure) +(char-ci=? procedure) +(char-ci? procedure) +(char-ci<=? procedure) +(char-ci>=? procedure) +(string-ci=? procedure) +(string-ci? procedure) +(string-ci<=? procedure) +(string-ci>=? procedure) +(string-fill! procedure) +(list->string procedure) +(string-length procedure) +(string->list procedure) +(string-copy procedure) +(string-downcase procedure) +(string-upcase procedure) +(string-append procedure) +(substring procedure) +(substring-uncopied procedure) +(string procedure) +(object->string procedure) +(format procedure) +(object->let procedure) +(cons procedure) +(car procedure) +(cdr procedure) +(set-car! procedure) +(set-cdr! procedure) +(caar procedure) +(cadr procedure) +(cdar procedure) +(cddr procedure) +(caaar procedure) +(caadr procedure) +(cadar procedure) +(cdaar procedure) +(caddr procedure) +(cdddr procedure) +(cdadr procedure) +(cddar procedure) +(caaaar procedure) +(caaadr procedure) +(caadar procedure) +(cadaar procedure) +(caaddr procedure) +(cadddr procedure) +(cadadr procedure) +(caddar procedure) +(cdaaar procedure) +(cdaadr procedure) +(cdadar procedure) +(cddaar procedure) +(cdaddr procedure) +(cddddr procedure) +(cddadr procedure) +(cdddar procedure) +(assq procedure) +(assv procedure) +(assoc procedure) +(memq procedure) +(memv procedure) +(member procedure) +(list procedure) +(list-ref procedure) +(list-set! procedure) +(list-tail procedure) +(make-list procedure) +(length procedure) +(copy procedure) +(fill! procedure) +(reverse procedure) +(reverse! procedure) +(sort! procedure) +(append procedure) +(vector-append procedure) +(list->vector procedure) +(vector-fill! procedure) +(vector-length procedure) +(vector->list procedure) +(vector-ref procedure) +(vector-set! procedure) +(vector-dimension procedure) +(vector-dimensions procedure) +(vector-rank procedure) +(make-vector procedure) +(vector procedure) +(vector-typer procedure) +(subvector procedure) +(subvector-position procedure) +(subvector-vector procedure) +(float-vector procedure) +(make-float-vector procedure) +(float-vector-set! procedure) +(float-vector-ref procedure) +(complex-vector procedure) +(make-complex-vector procedure) +(complex-vector-set! procedure) +(complex-vector-ref procedure) +(int-vector procedure) +(make-int-vector procedure) +(int-vector-set! procedure) +(int-vector-ref procedure) +(byte-vector procedure) +(make-byte-vector procedure) +(byte-vector-ref procedure) +(byte-vector-set! procedure) +(string->byte-vector procedure) +(byte-vector->string procedure) +(hash-table procedure) +(make-hash-table procedure) +(make-weak-hash-table procedure) +(weak-hash-table procedure) +(hash-table-ref procedure) +(hash-table-set! procedure) +(hash-table-entries procedure) +(hash-code procedure) +(hash-table-key-typer procedure) +(hash-table-value-typer procedure) +(cyclic-sequences procedure) +(call/cc procedure) +(call-with-current-continuation procedure) +(call-with-exit procedure) +(load procedure) +(autoload procedure) +(eval procedure) +(eval-string procedure) +(apply procedure) +(for-each procedure) +(map procedure) +(dynamic-wind procedure) +(dynamic-unwind procedure) +(catch procedure) +(throw procedure) +(error procedure) +(stacktrace procedure) +(values procedure) +(unquote syntax) +(apply-values procedure) +(list-values procedure) +(documentation procedure) +(signature procedure) +(help procedure) +(procedure-source procedure) +(procedure-arglist procedure) +(funclet procedure) +(*function* procedure) +(dilambda procedure) +(setter procedure) +(arity procedure) +(aritable? procedure) +(eq? procedure) +(eqv? procedure) +(equal? procedure) +(equivalent? procedure) +(type-of procedure) +(gc procedure) +(emergency-exit procedure) +(exit procedure) +) 's7)) + ) \ No newline at end of file diff --git a/analysis/identifier/rules/s7/define*.sls b/analysis/identifier/rules/s7/define*.sls new file mode 100644 index 00000000..f3f062d2 --- /dev/null +++ b/analysis/identifier/rules/s7/define*.sls @@ -0,0 +1,188 @@ +(library (scheme-langserver analysis identifier rules s7 define*) + (export define*-process) + (import + (chezscheme) + (ufo-match) + + (ufo-try) + + (scheme-langserver analysis identifier util) + (scheme-langserver analysis identifier reference) + + (scheme-langserver virtual-file-system index-node) + (scheme-langserver virtual-file-system library-node) + (scheme-langserver virtual-file-system document) + (scheme-langserver virtual-file-system file-node)) + +; reference-identifier-type include +; procedure parameter variable +(define (define*-process root-file-node root-library-node document index-node) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (try + (match expression + [(_ ((? symbol? identifier) dummy0 ... ) dummy1 ... ) + (let* ([omg-index-node (cadr (index-node-children index-node))] + [key-index-nodes (index-node-children omg-index-node)] + [reference (make-identifier-reference + identifier + document + (car key-index-nodes) + index-node + '() + 'procedure + '() + '())] + [dummies (cdr key-index-nodes)]) + (index-node-references-export-to-other-node-set! + (identifier-reference-index-node reference) + (append + (index-node-references-export-to-other-node (identifier-reference-index-node reference)) + `(,reference))) + (append-references-into-ordered-references-for document (index-node-parent index-node) `(,reference)) + (map + (lambda (dummy-index-node) + (let* ([dummy-ann (index-node-datum/annotations dummy-index-node)] + [dummy-expression (annotation-stripped dummy-ann)]) + (match dummy-expression + [(? symbol? dummy-identifier) + (let ([dummy-reference + (make-identifier-reference + dummy-expression + document + dummy-index-node + index-node + '() + 'parameter + '() + '())]) + (index-node-references-export-to-other-node-set! + (identifier-reference-index-node dummy-reference) + (append + (index-node-references-export-to-other-node (identifier-reference-index-node dummy-reference)) + `(,dummy-reference))) + (index-node-references-import-in-this-node-set! + index-node + (sort-identifier-references + (append + (index-node-references-import-in-this-node index-node) + `(,dummy-reference)))) + (index-node-references-import-in-this-node-set! + index-node + (sort-identifier-references + (append + (index-node-references-import-in-this-node index-node) + `(,dummy-reference)))) + (index-node-excluded-references-set! + omg-index-node + (append + (index-node-excluded-references omg-index-node) + `(,dummy-reference))))] + [((? symbol? dummy-identifier) _) + (let ([dummy-reference + (make-identifier-reference + (car dummy-expression) + document + dummy-index-node + index-node + '() + 'parameter + '() + '())]) + (index-node-references-export-to-other-node-set! + (identifier-reference-index-node dummy-reference) + (append + (index-node-references-export-to-other-node (identifier-reference-index-node dummy-reference)) + `(,dummy-reference))) + (index-node-references-import-in-this-node-set! + index-node + (sort-identifier-references + (append + (index-node-references-import-in-this-node index-node) + `(,dummy-reference)))) + (index-node-references-import-in-this-node-set! + index-node + (sort-identifier-references + (append + (index-node-references-import-in-this-node index-node) + `(,dummy-reference)))) + (index-node-excluded-references-set! + omg-index-node + (append + (index-node-excluded-references omg-index-node) + `(,dummy-reference))))] + [else '()]))) + dummies))] + [(_ ((? symbol? identifier) . dummy0) dummy1 ... ) + (let* ([omg-index-node (cadr (index-node-children index-node))] + [reference (make-identifier-reference + identifier + document + omg-index-node + index-node + '() + 'procedure + '() + '())]) + (index-node-references-export-to-other-node-set! + (identifier-reference-index-node reference) + (append + (index-node-references-export-to-other-node (identifier-reference-index-node reference)) + `(,reference))) + (append-references-into-ordered-references-for document (index-node-parent index-node) `(,reference)) + (let loop ([rest dummy0]) + (cond + [(pair? rest) + (let ([reference (make-identifier-reference + (car rest) + document + omg-index-node + index-node + '() + 'parameter + '() + '())]) + (index-node-references-export-to-other-node-set! + (identifier-reference-index-node reference) + (append + (index-node-references-export-to-other-node (identifier-reference-index-node reference)) + `(,reference))) + (append-references-into-ordered-references-for document index-node `(,reference))) + (loop (cdr rest))] + [(not (null? rest)) + (let ([reference (make-identifier-reference + rest + document + omg-index-node + index-node + '() + 'parameter + '() + '())]) + (index-node-references-export-to-other-node-set! + (identifier-reference-index-node reference) + (append + (index-node-references-export-to-other-node (identifier-reference-index-node reference)) + `(,reference))) + (append-references-into-ordered-references-for document index-node `(,reference)))] + [else '()])))] + [(_ (? symbol? identifier) dummy ... ) + (let ([reference (make-identifier-reference + (car* identifier) + document + (cadr (index-node-children index-node)) + index-node + '() + 'variable + '() + '())]) + (index-node-references-export-to-other-node-set! + (identifier-reference-index-node reference) + (append + (index-node-references-export-to-other-node (identifier-reference-index-node reference)) + `(,reference))) + (append-references-into-ordered-references-for document (index-node-parent index-node) `(,reference)))] + [else '()]) + (except c + [else '()])))) +) diff --git a/analysis/identifier/rules/s7/define-macro.sls b/analysis/identifier/rules/s7/define-macro.sls new file mode 100644 index 00000000..edcae26a --- /dev/null +++ b/analysis/identifier/rules/s7/define-macro.sls @@ -0,0 +1,49 @@ +(library (scheme-langserver analysis identifier rules s7 define-macro) + (export define-macro-process) + (import + (chezscheme) + (ufo-match) + + (ufo-try) + (scheme-langserver util contain) + (scheme-langserver util dedupe) + + (scheme-langserver analysis identifier reference) + (scheme-langserver analysis identifier rules syntax-case) + + (scheme-langserver virtual-file-system index-node) + (scheme-langserver virtual-file-system library-node) + (scheme-langserver virtual-file-system document) + (scheme-langserver virtual-file-system file-node)) + +; reference-identifier-type include +; syntax-parameter +;https://www.zenlife.tk/scheme-hygiene-macro.md +(define (define-macro-process root-file-node root-library-node document index-node) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (try + (match expression + [(_ ((? symbol? identifier) dummy0 ... ) dummy1 ... ) + (let* ([omg-index-node (cadr (index-node-children index-node))] + [key-index-nodes (index-node-children omg-index-node)] + [reference (make-identifier-reference + identifier + document + (car key-index-nodes) + index-node + '() + 'syntax-parameter + '() + '())]) + (index-node-references-export-to-other-node-set! + (identifier-reference-index-node reference) + (append + (index-node-references-export-to-other-node (identifier-reference-index-node reference)) + `(,reference))) + (append-references-into-ordered-references-for document (index-node-parent index-node) `(,reference)))] + [else '()]) + (except c + [else '()])))) + +) diff --git a/analysis/identifier/rules/s7/lambda*.sls b/analysis/identifier/rules/s7/lambda*.sls new file mode 100644 index 00000000..d79ce948 --- /dev/null +++ b/analysis/identifier/rules/s7/lambda*.sls @@ -0,0 +1,130 @@ +(library (scheme-langserver analysis identifier rules s7 lambda*) + (export + lambda*-process + parameter*-process) + (import + (chezscheme) + (ufo-match) + + (ufo-try) + + (scheme-langserver analysis identifier reference) + + (scheme-langserver virtual-file-system index-node) + (scheme-langserver virtual-file-system library-node) + (scheme-langserver virtual-file-system document) + (scheme-langserver virtual-file-system file-node)) + +; reference-identifier-type include +; parameter +(define (lambda*-process root-file-node root-library-node document index-node) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (try + (match expression + [(_ (identifier **1) fuzzy ... ) + (let loop ([rest (index-node-children (cadr (index-node-children index-node)))]) + (if (not (null? rest)) + (let* ([identifier-index-node (car rest)] + [identifier-index-node-parent (index-node-parent identifier-index-node)]) + (parameter*-process index-node identifier-index-node index-node '() document) + (loop (cdr rest)))))] + [(_ (? symbol? identifier) fuzzy ... ) + (parameter*-process index-node (cadr (index-node-children index-node)) index-node '() document)] + [(_ (identifier . rest) fuzzy ... ) + (let* ([omg-index-node (cadr (index-node-children index-node))] + [reference (make-identifier-reference + identifier + document + omg-index-node + index-node + '() + 'parameter + '() + '())]) + (index-node-references-export-to-other-node-set! + (identifier-reference-index-node reference) + (append + (index-node-references-export-to-other-node (identifier-reference-index-node reference)) + `(,reference))) + (append-references-into-ordered-references-for document index-node `(,reference)) + (let loop ([rest rest]) + (cond + [(pair? rest) + (let ([reference (make-identifier-reference + (car rest) + document + omg-index-node + index-node + '() + 'parameter + '() + '())]) + (index-node-references-export-to-other-node-set! + (identifier-reference-index-node reference) + (append + (index-node-references-export-to-other-node (identifier-reference-index-node reference)) + `(,reference))) + (append-references-into-ordered-references-for document index-node `(,reference))) + (loop (cdr rest))] + [(not (null? rest)) + (let ([reference (make-identifier-reference + rest + document + omg-index-node + index-node + '() + 'parameter + '() + '())]) + (index-node-references-export-to-other-node-set! + (identifier-reference-index-node reference) + (append + (index-node-references-export-to-other-node (identifier-reference-index-node reference)) + `(,reference))) + (append-references-into-ordered-references-for document index-node `(,reference)))] + [else '()])))] + [else '()]) + (except c + [else '()])))) + +(define (parameter*-process initialization-index-node index-node lambda-node exclude document ) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)] + [identifier (cond + [(symbol? expression) expression] + [(pair? expression) (car expression)] + [else #f])]) + (if identifier + (let ([reference + (make-identifier-reference + identifier + document + index-node + initialization-index-node + '() + 'parameter + '() + '())]) + (index-node-references-export-to-other-node-set! + index-node + (append + (index-node-references-export-to-other-node index-node) + `(,reference))) + + (index-node-references-import-in-this-node-set! + lambda-node + (sort-identifier-references + (append + (index-node-references-import-in-this-node lambda-node) + `(,reference)))) + + (index-node-excluded-references-set! + (index-node-parent index-node) + (append + (index-node-excluded-references index-node) + exclude + `(,reference))) + `(,reference)) + '()))) +) diff --git a/analysis/util.sls b/analysis/util.sls index 4274b089..b47d2c56 100644 --- a/analysis/util.sls +++ b/analysis/util.sls @@ -28,6 +28,11 @@ [('library (name **1) _ ... ) name] [else '()]))] ['r7rs + (lambda (index-node) + (match (annotation-stripped (index-node-datum/annotations index-node)) + [('define-library (name **1) _ ... ) name] + [else '()]))] + ['s7 (lambda (index-node) (match (annotation-stripped (index-node-datum/annotations index-node)) [('define-library (name **1) _ ... ) name] diff --git a/analysis/workspace.sls b/analysis/workspace.sls index 0eb9aa66..3c900f38 100644 --- a/analysis/workspace.sls +++ b/analysis/workspace.sls @@ -298,6 +298,7 @@ [s (read-string path)] [meta-lib (case top-environment ['r7rs '(scheme base)] + ['s7 '(s7)] [else '(chezscheme)])]) (try (cond diff --git a/tests/analysis/dependency/rules/test-library-import.sps b/tests/analysis/dependency/rules/test-library-import.sps index 743e05ab..a51b07e5 100755 --- a/tests/analysis/dependency/rules/test-library-import.sps +++ b/tests/analysis/dependency/rules/test-library-import.sps @@ -41,4 +41,10 @@ (test-equal '((srfi srfi-216)) (car (map library-import-process-r7rs root-index-nodes)))) (test-end) +(test-begin "library-import-process for s7") + (let* ([root-file-node (init-virtual-file-system "./tests/resources/r7rs/srfi/sicp.scm.txt" '() (lambda (fuzzy) #t) 's7)] + [root-index-nodes (document-index-node-list (file-node-document root-file-node))]) + (test-equal '((srfi srfi-216)) (car (map library-import-process-r7rs root-index-nodes)))) +(test-end) + (exit (if (zero? (test-runner-fail-count (test-runner-get))) 0 1)) diff --git a/tests/analysis/dependency/test-file-linkage.sps b/tests/analysis/dependency/test-file-linkage.sps index 271a62c0..f933e7f4 100755 --- a/tests/analysis/dependency/test-file-linkage.sps +++ b/tests/analysis/dependency/test-file-linkage.sps @@ -71,4 +71,15 @@ (car paths))) (test-end) +(test-begin "file-linkage-to-s7") + (let* ([root-file-node (init-virtual-file-system (current-directory) '() (generate-txt-file-filter) 's7)] + [root-library-node (init-library-node root-file-node 's7)] + [file-linkage (init-file-linkage root-file-node root-library-node 's7)] + [to-path (string-append (current-directory) "/tests/resources/r7rs/srfi/srfi-8.scm.txt")] + [paths (file-linkage-to file-linkage to-path)]) + (test-equal + (string-append (current-directory) "/tests/resources/r7rs/liii/rich-vector.scm.txt") + (car paths))) +(test-end) + (exit (if (zero? (test-runner-fail-count (test-runner-get))) 0 1)) diff --git a/tests/analysis/test-workspace.sps b/tests/analysis/test-workspace.sps index 5364ee48..d883f0b5 100755 --- a/tests/analysis/test-workspace.sps +++ b/tests/analysis/test-workspace.sps @@ -75,7 +75,7 @@ (map identifier-reference-identifier (document-ordered-reference-list document))))) (test-end) -(test-begin "init-workspace-basic-test") +(test-begin "init-workspace-basic-test-r7rs") (let* ([workspace (init-workspace (string-append (current-directory) "/tests/resources/r7rs") 'txt 'r7rs #f #f)] [root-file-node (workspace-file-node workspace)] [root-library-node (workspace-library-node workspace)]) @@ -83,4 +83,12 @@ (test-equal #f (null? root-library-node))) (test-end) +(test-begin "init-workspace-basic-test-s7") +(let* ([workspace (init-workspace (string-append (current-directory) "/tests/resources/r7rs") 'txt 's7 #f #f)] + [root-file-node (workspace-file-node workspace)] + [root-library-node (workspace-library-node workspace)]) + (test-equal #f (null? root-file-node)) + (test-equal #f (null? root-library-node))) +(test-end) + (exit (if (zero? (test-runner-fail-count (test-runner-get))) 0 1)) From c7c56a3a3090174b177b06a211af69b411cdcd62 Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Wed, 13 Aug 2025 16:22:21 +0800 Subject: [PATCH 2/2] add test for define* rule --- analysis/abstract-interpreter.sls | 4 +- .../identifier/rules/test-define*.sps | 39 +++++++++++++++++++ 2 files changed, 41 insertions(+), 2 deletions(-) create mode 100644 tests/analysis/identifier/rules/test-define*.sps diff --git a/analysis/abstract-interpreter.sls b/analysis/abstract-interpreter.sls index e98404da..f05a3700 100644 --- a/analysis/abstract-interpreter.sls +++ b/analysis/abstract-interpreter.sls @@ -256,10 +256,10 @@ [(and (equal? r '(define*)) (private:top-env=? 's7 top)) (private-add-rule rules `((,define*-process) . ,identifier))] - [(and (equal? r '(define*)) (private:top-env=? 's7 top)) + [(and (equal? r '(define-macro)) (private:top-env=? 's7 top)) (private-add-rule rules `((,define-macro-process) . ,identifier))] - [(and (equal? r '(define*)) (private:top-env=? 's7 top)) + [(and (equal? r '(lambda*)) (private:top-env=? 's7 top)) (private-add-rule rules `((,lambda*-process) . ,identifier))] [else rules]) diff --git a/tests/analysis/identifier/rules/test-define*.sps b/tests/analysis/identifier/rules/test-define*.sps new file mode 100644 index 00000000..125c00f1 --- /dev/null +++ b/tests/analysis/identifier/rules/test-define*.sps @@ -0,0 +1,39 @@ +#!/usr/bin/env scheme-script +;; -*- mode: scheme; coding: utf-8 -*- !# +;; Copyright (c) 2022 WANG Zheng +;; SPDX-License-Identifier: MIT +#!r6rs + +(import (rnrs (6)) (srfi :64 testing) + (scheme-langserver analysis workspace) + (scheme-langserver analysis identifier rules s7 define*) + (scheme-langserver analysis identifier rules define) + (scheme-langserver analysis identifier reference) + (scheme-langserver analysis package-manager akku) + + (scheme-langserver virtual-file-system index-node) + (scheme-langserver virtual-file-system file-node) + (scheme-langserver virtual-file-system document)) + + +(test-begin "define*-process") + (let* ( [root-file-node (init-virtual-file-system "./tests/resources/r7rs" '() (lambda (fuzzy) #t) 's7)] + [root-library-node '()] + [target-file-node (walk-file root-file-node "./tests/resources/r7rs/scheme/base.scm.txt")] + [document (file-node-document target-file-node)] + [index-node (car (document-index-node-list document))] + [begin-index-node (car (last-pair (index-node-children index-node)))]) + + (map (lambda (node) (define*-process root-file-node root-library-node document node)) (index-node-children (car (last-pair (index-node-children index-node))))) + + (test-equal #f + (not (find + (lambda (reference) + (equal? 'bytevector-advance-u8 + (annotation-stripped + (index-node-datum/annotations + (identifier-reference-index-node reference))))) + (index-node-references-import-in-this-node begin-index-node))))) +(test-end) + +(exit (if (zero? (test-runner-fail-count (test-runner-get))) 0 1))