From be67b0edcbe4ebbf2933231c523938daef62409e Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Thu, 24 Jul 2025 19:49:50 +0800 Subject: [PATCH 1/5] Add r6rs standard branch judgment in analysis/abstract-interpreter.sls --- analysis/abstract-interpreter.sls | 58 +++++--- analysis/identifier/reference.sls | 1 + .../identifier/rules/r7rs/define-r7rs.sls | 134 ++++++++++++++++++ 3 files changed, 177 insertions(+), 16 deletions(-) create mode 100644 analysis/identifier/rules/r7rs/define-r7rs.sls diff --git a/analysis/abstract-interpreter.sls b/analysis/abstract-interpreter.sls index 72e29709..9c94db3a 100644 --- a/analysis/abstract-interpreter.sls +++ b/analysis/abstract-interpreter.sls @@ -56,6 +56,8 @@ (scheme-langserver analysis identifier rules with-syntax) (scheme-langserver analysis identifier rules identifier-syntax) + (scheme-langserver analysis identifier rules r7rs define-r7rs) + (scheme-langserver analysis identifier self-defined-rules router) (scheme-langserver virtual-file-system index-node) @@ -163,7 +165,10 @@ [is (map identifier-reference-library-identifier top)]) (if (find meta-library? is) (cond - [(equal? r '(define)) (private-add-rule rules `((,define-process) . ,identifier))] + [(and (equal? r '(define)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,define-process) . ,identifier))] + [(and (equal? r '(define)) (find-top-env? 'r7rs 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))] [(equal? r '(do)) (private-add-rule rules `((,do-process) . ,identifier))] @@ -171,11 +176,15 @@ [(equal? r '(lambda)) (private-add-rule rules `((,lambda-process) . ,identifier))] [(equal? r '(set!)) (private-add-rule rules `((,define-top-level-value-process) . ,identifier))] - [(equal? r '(set-top-level-value!)) (private-add-rule rules `((,define-top-level-value-process) . ,identifier))] - [(equal? r '(define-top-level-value)) (private-add-rule rules `((,define-top-level-value-process) . ,identifier))] + [(and (equal? r '(set-top-level-value!)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,define-top-level-value-process) . ,identifier))] + [(and (equal? r '(define-top-level-value)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,define-top-level-value-process) . ,identifier))] - [(equal? r '(set-top-level-syntax!)) (private-add-rule rules `((,define-top-level-syntax-process) . ,identifier))] - [(equal? r '(define-top-level-syntax)) (private-add-rule rules `((,define-top-level-syntax-process) . ,identifier))] + [(and (equal? r '(set-top-level-syntax!)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,define-top-level-syntax-process) . ,identifier))] + [(and (equal? r '(define-top-level-syntax)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,define-top-level-syntax-process) . ,identifier))] [(equal? r '(let)) (private-add-rule rules `((,let-process) . ,identifier))] [(equal? r '(let*)) (private-add-rule rules `((,let*-process) . ,identifier))] @@ -185,16 +194,23 @@ [(equal? r '(letrec)) (private-add-rule rules `((,letrec-process) . ,identifier))] [(equal? r '(letrec*)) (private-add-rule rules `((,letrec*-process) . ,identifier))] [(equal? r '(letrec-syntax)) (private-add-rule rules `((,letrec-syntax-process) . ,identifier))] - [(equal? r '(fluid-let)) (private-add-rule rules `((,fluid-let-process) . ,identifier))] - [(equal? r '(fluid-let-syntax)) (private-add-rule rules `((,fluid-let-syntax-process) . ,identifier))] + [(and (equal? r '(fluid-let)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,fluid-let-process) . ,identifier))] + [(and (equal? r '(fluid-let-syntax)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,fluid-let-syntax-process) . ,identifier))] - [(equal? r '(syntax-case)) (private-add-rule rules `((,syntax-case-process) . ,identifier))] + [(and (equal? r '(syntax-case)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,syntax-case-process) . ,identifier))] [(equal? r '(syntax-rules)) (private-add-rule rules `((,syntax-rules-process) . ,identifier))] - [(equal? r '(identifier-syntax)) (private-add-rule rules `((,identifier-syntax-process) . ,identifier))] - [(equal? r '(with-syntax)) (private-add-rule rules `((,with-syntax-process) . ,identifier))] + [(and (equal? r '(identifier-syntax)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,identifier-syntax-process) . ,identifier))] + [(and (equal? r '(with-syntax)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,with-syntax-process) . ,identifier))] - [(equal? r '(library)) (private-add-rule rules `((,library-import-process . ,export-process) . ,identifier))] - [(equal? r '(invoke-library)) (private-add-rule rules `((,invoke-library-process) . ,identifier))] + [(and (equal? r '(library)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,library-import-process . ,export-process) . ,identifier))] + [(and (equal? r '(invoke-library)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,invoke-library-process) . ,identifier))] [(equal? r '(import)) (let ([special (lambda (root-file-node root-library-node document index-node) @@ -219,10 +235,13 @@ (private-add-rule rules `((,special) . ,identifier)))] [(equal? r '(load)) (private-add-rule rules `((,load-process) . ,identifier))] - [(equal? r '(load-program)) (private-add-rule rules `((,load-program-process) . ,identifier))] - [(equal? r '(load-library)) (private-add-rule rules `((,load-library-process) . ,identifier))] + [(and (equal? r '(load-program)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,load-program-process) . ,identifier))] + [(and (equal? r '(load-library)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,load-library-process) . ,identifier))] - [(equal? r '(body)) (private-add-rule rules `((,do-nothing . ,body-process) . ,identifier))] + [(and (equal? r '(body)) (find-top-env? 'r6rs top)) + (private-add-rule rules `((,do-nothing . ,body-process) . ,identifier))] [else rules]) (route&add @@ -236,8 +255,10 @@ (or (equal? 'parameter (identifier-reference-type identifier)) (equal? 'syntax-parameter (identifier-reference-type identifier)) - (equal? 'procedure (identifier-reference-type identifier))))) + (equal? 'procedure (identifier-reference-type identifier)) + (equal? 'variable (identifier-reference-type identifier))))) identifier-list))) + (define private:find-available-references-for (case-lambda [(expanded+callee-list current-document current-index-node) @@ -250,4 +271,9 @@ (if result (private:find-available-references-for expanded+callee-list current-document (cdr result) expression) (find-available-references-for current-document current-index-node expression)))])) + +(define (find-top-env? standard top) + (find (lambda (top-environment) (equal? standard top-environment)) + (map identifier-reference-top-environment top))) + ) \ No newline at end of file diff --git a/analysis/identifier/reference.sls b/analysis/identifier/reference.sls index 8f81100e..441f405d 100644 --- a/analysis/identifier/reference.sls +++ b/analysis/identifier/reference.sls @@ -18,6 +18,7 @@ identifier-reference-type-expressions-set! identifier-reference-index-node identifier-reference-initialization-index-node + identifier-reference-top-environment identifier-compare? diff --git a/analysis/identifier/rules/r7rs/define-r7rs.sls b/analysis/identifier/rules/r7rs/define-r7rs.sls new file mode 100644 index 00000000..5196a0ce --- /dev/null +++ b/analysis/identifier/rules/r7rs/define-r7rs.sls @@ -0,0 +1,134 @@ +(library (scheme-langserver analysis identifier rules r7rs define-r7rs) + (export define-r7rs-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-r7rs-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)] + [dummy-reference + (make-identifier-reference + dummy-expression + document + dummy-index-node + index-node + '() + 'parameter + '() + '())]) + (match dummy-expression + [(? symbol? dummy-identifier) + (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-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 '()])))] + [else '()]) + (except c + [else '()])))) +) From 7b250e594fb90024443a91bcd2df677f52fcf1f2 Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Mon, 28 Jul 2025 20:12:25 +0800 Subject: [PATCH 2/5] add r7rs standard define-library --- analysis/abstract-interpreter.sls | 10 +- .../rules/r7rs/define-library-export-r7rs.sls | 101 +++++ .../rules/r7rs/define-library-import-r7rs.sls | 355 ++++++++++++++++++ 3 files changed, 463 insertions(+), 3 deletions(-) create mode 100644 analysis/identifier/rules/r7rs/define-library-export-r7rs.sls create mode 100644 analysis/identifier/rules/r7rs/define-library-import-r7rs.sls diff --git a/analysis/abstract-interpreter.sls b/analysis/abstract-interpreter.sls index 9c94db3a..965f59f4 100644 --- a/analysis/abstract-interpreter.sls +++ b/analysis/abstract-interpreter.sls @@ -57,6 +57,8 @@ (scheme-langserver analysis identifier rules identifier-syntax) (scheme-langserver analysis identifier rules r7rs define-r7rs) + (scheme-langserver analysis identifier rules r7rs define-library-import-r7rs) + (scheme-langserver analysis identifier rules r7rs define-library-export-r7rs) (scheme-langserver analysis identifier self-defined-rules router) @@ -243,6 +245,9 @@ [(and (equal? r '(body)) (find-top-env? 'r6rs top)) (private-add-rule rules `((,do-nothing . ,body-process) . ,identifier))] + [(and (equal? r '(define-library)) (find-top-env? 'r7rs top)) + (private-add-rule rules `((,library-import-process-r7rs . ,export-process-r7rs) . ,identifier))] + [else rules]) (route&add rules identifier @@ -273,7 +278,6 @@ (find-available-references-for current-document current-index-node expression)))])) (define (find-top-env? standard top) - (find (lambda (top-environment) (equal? standard top-environment)) - (map identifier-reference-top-environment top))) - + (not (null? (find (lambda (top-environment) (equal? standard top-environment)) + (map identifier-reference-top-environment top))))) ) \ No newline at end of file diff --git a/analysis/identifier/rules/r7rs/define-library-export-r7rs.sls b/analysis/identifier/rules/r7rs/define-library-export-r7rs.sls new file mode 100644 index 00000000..0bf3131f --- /dev/null +++ b/analysis/identifier/rules/r7rs/define-library-export-r7rs.sls @@ -0,0 +1,101 @@ +(library (scheme-langserver analysis identifier rules r7rs define-library-export-r7rs) + (export export-process-r7rs) + (import + (chezscheme) + (ufo-match) + + (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 +; pointer + +; NOTE: the difference between variable and pointer is +; usually variables store the result of tailed s-expression +; like (let ([A a])...) and A is a variable recalled in the fowlling body +; but pointers manipulate the result of previous s-expression +; like (rename (a A)) and A is a pointer recalled outsize this body +(define (export-process-r7rs root-file-node root-library-node document index-node) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (match expression + [(_ (library-identifiers **1) fuzzy **1 ) + (map + (lambda (child-node) (match-export index-node root-file-node document library-identifiers child-node)) + (cddr (index-node-children index-node)))] + ; [('define-library (library-identifiers **1) _ **1 ) + ; (map + ; (lambda (child-node) (match-export index-node root-file-node document library-identifiers child-node)) + ; (index-node-children index-node))] + [else '()]) + index-node)) + +(define (match-export initialization-index-node root-file-node document library-identifiers index-node) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (match expression + [('export dummy **1 ) + (map + (lambda (child-node) (match-clause initialization-index-node root-file-node document library-identifiers child-node)) + (cdr (index-node-children index-node)))] + [else '()]))) + +(define (match-clause initialization-index-node root-file-node document library-identifiers index-node) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (match expression + [('rename ((? symbol? internal-names) (? symbol? external-names)) **1) + (fold-left + (lambda (result current-item) + (let* ([current-children (index-node-children current-item)] + [internal-index-node (car current-children)] + [external-index-node (cadr current-children)] + [references + (find-available-references-for + document + internal-index-node + (annotation-stripped (index-node-datum/annotations internal-index-node)))]) + (append-references-into-ordered-references-for document external-index-node references) + + (index-node-references-export-to-other-node-set! + external-index-node + (append + (index-node-references-export-to-other-node external-index-node) + `(,(make-identifier-reference + (annotation-stripped (index-node-datum/annotations external-index-node)) + document + external-index-node + initialization-index-node + library-identifiers + 'pointer + references + (apply append (map identifier-reference-type-expressions references)))))) + `(,@result ,external-index-node))) + '() + (cdr (index-node-children index-node)))] + [(? symbol? identifier) + (let* ([references (find-available-references-for document index-node identifier)] + [reference-count (length references)]) + (index-node-references-export-to-other-node-set! + index-node + (append + (index-node-references-export-to-other-node index-node) + (if (zero? reference-count) + ;; in srfi 13, library file using a self-made include/revolve procedure + ;; and in this case, replace '() with a special + `(,(make-identifier-reference + expression + document + index-node + initialization-index-node + library-identifiers + 'pointer + references + (apply append (map identifier-reference-type-expressions references)))) + references))))] + [else '()]))) +) \ No newline at end of file diff --git a/analysis/identifier/rules/r7rs/define-library-import-r7rs.sls b/analysis/identifier/rules/r7rs/define-library-import-r7rs.sls new file mode 100644 index 00000000..5f736c26 --- /dev/null +++ b/analysis/identifier/rules/r7rs/define-library-import-r7rs.sls @@ -0,0 +1,355 @@ +(library (scheme-langserver analysis identifier rules r7rs define-library-import-r7rs) + (export + library-import-process-r7rs) + (import + (chezscheme) + (ufo-match) + + (ufo-try) + + (scheme-langserver analysis identifier meta) + (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)) + +; pointer +(define (library-import-process-r7rs root-file-node root-library-node document index-node) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (match expression + [(_ fuzzy import-things **1) + (map + (lambda (child-node) (match-import index-node root-file-node root-library-node document child-node)) + (cddr (index-node-children index-node)))] + ; [('define-library _ **1 ) + ; ; this should not use 'guard', because it follows the r7rs library mechanism(in sld) + ; (map + ; (lambda (child-node) (match-import index-node root-file-node root-library-node document child-node)) + ; (index-node-children index-node))] + [else '()]) + index-node)) + +(define (invoke-library-process root-file-node root-library-node document index-node) + (filter-empty-list + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)] + [parent-index-node (index-node-parent index-node)]) + (match expression + [(_ ('quote (library-identifier **1)) fuzzy ...) + (append-references-into-ordered-references-for + document + parent-index-node + (filter identifier-reference? (import-references root-library-node library-identifier)))] + [else '()])))) + +(define (import-process root-file-node root-library-node document index-node) + (filter-empty-list + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (match expression + [(_ dummy **1 ) + (map + (lambda (child-node) (match-clause index-node root-file-node root-library-node document child-node)) + (cdr (index-node-children index-node)))] + [else '()])))) + +(define process-library-identifier-excluded-references + (case-lambda + [(document) + (map + (lambda (index-node) + (process-library-identifier-excluded-references document index-node 0)) + (document-index-node-list document))] + [(document index-node depth) + (if (library-identifier? document index-node) + (index-node-excluded-references-set! index-node (find-available-references-for document index-node)) + (if (< depth 3) + (map + (lambda (current-index-node) + (process-library-identifier-excluded-references document current-index-node (+ 1 depth))) + (index-node-children index-node)) + '()))])) + +(define (filter-empty-list list-instance) + (filter + (lambda (item) (not (null? item))) + list-instance)) + +(define (match-import initialization-index-node root-file-node root-library-node document index-node) + (filter-empty-list + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (match expression + [('import dummy **1 ) + (map + (lambda (child-node) (match-clause initialization-index-node root-file-node root-library-node document child-node)) + (cdr (index-node-children index-node)))] + [else '()])))) + +(define (match-clause initialization-index-node root-file-node root-library-node document index-node) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)] + [grand-parent-index-node (index-node-parent (index-node-parent index-node))]) + (match expression + [('only (library-identifier **1) (? symbol? identifier) **1) + (let loop ([importion-index-node (cddr (index-node-children index-node))] + [identifiers identifier] + [imported-references + (filter + (lambda (reference) + (if (find (lambda(id) (equal? id (identifier-reference-identifier reference))) identifier) #t #f)) + (import-references root-library-node library-identifier))]) + + (if (not (null? importion-index-node)) + (let* ([current-index-node (car importion-index-node)] + [current-identifier (car identifiers)] + [current-references + (filter + (lambda (reference) + (equal? current-identifier (identifier-reference-identifier reference))) + imported-references)]) + + (append-references-into-ordered-references-for document current-index-node current-references) + + (append-references-into-ordered-references-for document grand-parent-index-node current-references) + + (loop + (cdr importion-index-node) + (cdr identifiers) + (filter + (lambda (reference) + (not (equal? current-identifier (identifier-reference-identifier reference)))) + imported-references)))))] + [('except (library-identifier **1) (? symbol? identifier) **1) + (let ([tmp + (filter + (lambda (reference) + (if (find (lambda(id) (not (equal? id (identifier-reference-identifier reference)))) identifier) #t #f)) + (import-references root-library-node library-identifier))]) + (if (null? grand-parent-index-node) + (document-ordered-reference-list-set! + document + (sort-identifier-references (append (document-ordered-reference-list document) tmp))) + (append-references-into-ordered-references-for document grand-parent-index-node tmp))) + + (let loop ([importion-index-node (cddr (index-node-children index-node))] + [identifiers identifier] + [imported-references + (filter + (lambda (reference) + (if (find (lambda(id) (equal? id (identifier-reference-identifier reference))) identifier) #t #f)) + (import-references root-library-node library-identifier))]) + (if (not (null? importion-index-node)) + (let* ([current-index-node (car importion-index-node)] + [current-identifier (car identifiers)] + [current-references + (filter + (lambda (reference) + (equal? current-identifier (identifier-reference-identifier reference))) + imported-references)]) + + (append-references-into-ordered-references-for document current-index-node current-references) + (loop + (cdr importion-index-node) + (cdr identifiers) + (filter + (lambda (reference) + (not (equal? current-identifier (identifier-reference-identifier reference)))) + imported-references)))))] + [('prefix (library-identifier **1) (? symbol? prefix-id)) + (let* ([imported-references (import-references root-library-node library-identifier)] + [prefixed-references + (map + (lambda (reference) + (make-identifier-reference + (string->symbol (string-append (symbol->string prefix-id) (symbol->string (identifier-reference-identifier reference)))) + (identifier-reference-document reference) + (identifier-reference-index-node reference) + initialization-index-node + (identifier-reference-library-identifier reference) + 'pointer + `(,reference) + (identifier-reference-type-expressions reference))) + imported-references)]) + ;;todo: add something to export-to-other-node for current-index-node? + (append-references-into-ordered-references-for document grand-parent-index-node prefixed-references))] + [('rename (library-identifier **1) ((? symbol? external-name) (? symbol? internal-name)) **1 ) + (let loop ([importion-nodes (cddr (index-node-children index-node))] + [external-names external-name] + [internal-names internal-name] + [imported-references + (filter + (lambda (reference) + (if (find (lambda(id) (equal? id (identifier-reference-identifier reference))) external-name) #t #f)) + (import-references root-library-node library-identifier))]) + (if (not (null? importion-nodes)) + (let* ([current-importion-pair (index-node-children (car importion-nodes))] + [current-external-node (car current-importion-pair)] + [current-internal-node (cadr current-importion-pair)] + [current-external-name (car external-names)] + [current-internal-name (car internal-names)] + [current-references + (filter + (lambda (reference) + (equal? current-external-name (identifier-reference-identifier reference))) + imported-references)] + [renamed-references + (map + (lambda (reference) + (make-identifier-reference + current-internal-name + (identifier-reference-document reference) + (identifier-reference-index-node reference) + initialization-index-node + (identifier-reference-library-identifier reference) + 'pointer + `(,reference) + (identifier-reference-type-expressions reference))) + current-references)]) + + (append-references-into-ordered-references-for document current-internal-node current-references) + (append-references-into-ordered-references-for document grand-parent-index-node renamed-references) + + (index-node-references-export-to-other-node-set! + current-external-node + (append + (index-node-references-import-in-this-node current-external-node) + renamed-references)) + (loop + (cdr importion-nodes) + (cdr external-names) + (cdr internal-names) + (filter + (lambda (reference) + (not (equal? current-external-name (identifier-reference-identifier reference)))) + imported-references)))))] + [('alias (library-identifier **1) ((? symbol? external-name) (? symbol? internal-name)) **1 ) + (let loop ([importion-nodes (cddr (index-node-children index-node))] + [external-names external-name] + [internal-names internal-name] + [imported-references + (filter + (lambda (reference) + (if (find (lambda(id) (equal? id (identifier-reference-identifier reference))) external-name) #t #f)) + (import-references root-library-node library-identifier))]) + (if (not (null? importion-nodes)) + (let* ([current-importion-pair (index-node-children (car importion-nodes))] + [current-external-node (car current-importion-pair)] + [current-internal-node (cadr current-importion-pair)] + [current-external-name (car external-names)] + [current-internal-name (car internal-names)] + [current-references + (filter + (lambda (reference) + (equal? current-external-name (identifier-reference-identifier reference))) + imported-references)] + [renamed-references + (map + (lambda (reference) + (make-identifier-reference + current-internal-name + (identifier-reference-document reference) + (identifier-reference-index-node reference) + initialization-index-node + (identifier-reference-library-identifier reference) + 'pointer + `(,reference) + (identifier-reference-type-expressions reference))) + current-references)]) + + (append-references-into-ordered-references-for document current-internal-node current-references) + (append-references-into-ordered-references-for document grand-parent-index-node current-references) + (append-references-into-ordered-references-for document grand-parent-index-node renamed-references) + + (index-node-references-export-to-other-node-set! + current-external-node + (append + (index-node-references-import-in-this-node current-external-node) + renamed-references)) + (loop + (cdr importion-nodes) + (cdr external-names) + (cdr internal-names) + (filter + (lambda (reference) + (not (equal? current-external-name (identifier-reference-identifier reference)))) + imported-references)))))] + [('for (library-identifier **1) import-level) + (if (or + (equal? 'run import-level) + (equal? '(meta 0) import-level) + ; (equal? 'expand import-level) + ; (equal? '(meta 1) import-level) + ) + (let ([tmp (filter identifier-reference? (import-references root-library-node library-identifier))]) + (if (null? grand-parent-index-node) + (document-ordered-reference-list-set! + document + (sort-identifier-references (append (document-ordered-reference-list document) tmp))) + (append-references-into-ordered-references-for document grand-parent-index-node tmp))))] + [(library-identifier **1) + (append-references-into-ordered-references-for + document + grand-parent-index-node + (filter identifier-reference? (import-references root-library-node library-identifier)))] + [else '()]))) + +(define (import-references root-library-node library-identifier) + (let* ([library-node (walk-library library-identifier root-library-node)] + [candidate-file-nodes (if (null? library-node) '() (library-node-file-nodes library-node))] + [candidate-index-node-list (apply append (map document-index-node-list (map file-node-document candidate-file-nodes)))]) + (if (null? candidate-file-nodes) + (find-meta library-identifier) + (apply append + (map import-from-external-index-node + (filter + (lambda (index-node) + (match (annotation-stripped (index-node-datum/annotations index-node)) + (['library (identifier **1) _ ... ] (equal? identifier library-identifier)) + (['define-library (identifier **1) _ ... ] (equal? identifier library-identifier)) + (else #f))) + candidate-index-node-list)))))) + +(define (import-from-external-index-node root-index-node) + (let* ([ann (index-node-datum/annotations root-index-node)] + [expression (annotation-stripped ann)]) + (match expression + [('library _ **1 ) + (apply append (map + (lambda (child-node) (match-export child-node)) + (cddr (index-node-children root-index-node))))] + [('define-library _ **1 ) + (apply append (map + (lambda (child-node) (match-export child-node)) + (cddr (index-node-children root-index-node))))] + [else '()]))) + +(define (match-export index-node) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (match expression + [('export dummy **1 ) + (apply append + (map + (lambda (child-node) (match-export-clause child-node)) + (cdr (index-node-children index-node))))] + [else '()]))) + +(define (match-export-clause index-node) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (match expression + [('rename ((? symbol? internal-names) (? symbol? external-names)) **1) + (let loop ([exportion-nodes (cdr (index-node-children index-node))] + [result '()]) + (if (null? exportion-nodes) + result + (loop + (cdr exportion-nodes) + (append result (index-node-references-export-to-other-node (cadr (index-node-children (car exportion-nodes))))))))] + [(? symbol? identifier) (index-node-references-export-to-other-node index-node)] + [else '()]))) +) \ No newline at end of file From 80b226b14292297e13f650b1a1555aaee20622cb Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Tue, 29 Jul 2025 15:32:59 +0800 Subject: [PATCH 3/5] change private-process in analysis/identifier/meta.sls --- analysis/abstract-interpreter.sls | 48 ++++++++-------- analysis/identifier/meta.sls | 57 +++++++++++-------- ...ort-r7rs.sls => define-library-export.sls} | 2 +- ...ort-r7rs.sls => define-library-import.sls} | 13 +++-- .../r7rs/{define-r7rs.sls => define.sls} | 2 +- 5 files changed, 66 insertions(+), 56 deletions(-) rename analysis/identifier/rules/r7rs/{define-library-export-r7rs.sls => define-library-export.sls} (99%) rename analysis/identifier/rules/r7rs/{define-library-import-r7rs.sls => define-library-import.sls} (97%) rename analysis/identifier/rules/r7rs/{define-r7rs.sls => define.sls} (99%) diff --git a/analysis/abstract-interpreter.sls b/analysis/abstract-interpreter.sls index 965f59f4..5c7b37c2 100644 --- a/analysis/abstract-interpreter.sls +++ b/analysis/abstract-interpreter.sls @@ -56,9 +56,9 @@ (scheme-langserver analysis identifier rules with-syntax) (scheme-langserver analysis identifier rules identifier-syntax) - (scheme-langserver analysis identifier rules r7rs define-r7rs) - (scheme-langserver analysis identifier rules r7rs define-library-import-r7rs) - (scheme-langserver analysis identifier rules r7rs define-library-export-r7rs) + (scheme-langserver analysis identifier rules r7rs define) + (scheme-langserver analysis identifier rules r7rs define-library-import) + (scheme-langserver analysis identifier rules r7rs define-library-export) (scheme-langserver analysis identifier self-defined-rules router) @@ -164,12 +164,14 @@ (let* ([top (root-ancestor identifier)] [r (map identifier-reference-identifier top)] [i (identifier-reference-identifier identifier)] - [is (map identifier-reference-library-identifier top)]) - (if (find meta-library? is) + [is (map identifier-reference-library-identifier top)] + [top-environment (car (map identifier-reference-top-environment top))] + ) + (if (find (lambda (is) (meta-library? is top-environment)) is) (cond - [(and (equal? r '(define)) (find-top-env? 'r6rs top)) + [(and (equal? r '(define)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,define-process) . ,identifier))] - [(and (equal? r '(define)) (find-top-env? 'r7rs top)) + [(and (equal? r '(define)) (private:top-env=? 'r7rs 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))] @@ -178,14 +180,14 @@ [(equal? r '(lambda)) (private-add-rule rules `((,lambda-process) . ,identifier))] [(equal? r '(set!)) (private-add-rule rules `((,define-top-level-value-process) . ,identifier))] - [(and (equal? r '(set-top-level-value!)) (find-top-env? 'r6rs top)) + [(and (equal? r '(set-top-level-value!)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,define-top-level-value-process) . ,identifier))] - [(and (equal? r '(define-top-level-value)) (find-top-env? 'r6rs top)) + [(and (equal? r '(define-top-level-value)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,define-top-level-value-process) . ,identifier))] - [(and (equal? r '(set-top-level-syntax!)) (find-top-env? 'r6rs top)) + [(and (equal? r '(set-top-level-syntax!)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,define-top-level-syntax-process) . ,identifier))] - [(and (equal? r '(define-top-level-syntax)) (find-top-env? 'r6rs top)) + [(and (equal? r '(define-top-level-syntax)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,define-top-level-syntax-process) . ,identifier))] [(equal? r '(let)) (private-add-rule rules `((,let-process) . ,identifier))] @@ -196,22 +198,22 @@ [(equal? r '(letrec)) (private-add-rule rules `((,letrec-process) . ,identifier))] [(equal? r '(letrec*)) (private-add-rule rules `((,letrec*-process) . ,identifier))] [(equal? r '(letrec-syntax)) (private-add-rule rules `((,letrec-syntax-process) . ,identifier))] - [(and (equal? r '(fluid-let)) (find-top-env? 'r6rs top)) + [(and (equal? r '(fluid-let)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,fluid-let-process) . ,identifier))] - [(and (equal? r '(fluid-let-syntax)) (find-top-env? 'r6rs top)) + [(and (equal? r '(fluid-let-syntax)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,fluid-let-syntax-process) . ,identifier))] - [(and (equal? r '(syntax-case)) (find-top-env? 'r6rs top)) + [(and (equal? r '(syntax-case)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,syntax-case-process) . ,identifier))] [(equal? r '(syntax-rules)) (private-add-rule rules `((,syntax-rules-process) . ,identifier))] - [(and (equal? r '(identifier-syntax)) (find-top-env? 'r6rs top)) + [(and (equal? r '(identifier-syntax)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,identifier-syntax-process) . ,identifier))] - [(and (equal? r '(with-syntax)) (find-top-env? 'r6rs top)) + [(and (equal? r '(with-syntax)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,with-syntax-process) . ,identifier))] - [(and (equal? r '(library)) (find-top-env? 'r6rs top)) + [(and (equal? r '(library)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,library-import-process . ,export-process) . ,identifier))] - [(and (equal? r '(invoke-library)) (find-top-env? 'r6rs top)) + [(and (equal? r '(invoke-library)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,invoke-library-process) . ,identifier))] [(equal? r '(import)) (let ([special @@ -237,15 +239,15 @@ (private-add-rule rules `((,special) . ,identifier)))] [(equal? r '(load)) (private-add-rule rules `((,load-process) . ,identifier))] - [(and (equal? r '(load-program)) (find-top-env? 'r6rs top)) + [(and (equal? r '(load-program)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,load-program-process) . ,identifier))] - [(and (equal? r '(load-library)) (find-top-env? 'r6rs top)) + [(and (equal? r '(load-library)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,load-library-process) . ,identifier))] - [(and (equal? r '(body)) (find-top-env? 'r6rs top)) + [(and (equal? r '(body)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,do-nothing . ,body-process) . ,identifier))] - [(and (equal? r '(define-library)) (find-top-env? 'r7rs top)) + [(and (equal? r '(define-library)) (private:top-env=? 'r7rs top)) (private-add-rule rules `((,library-import-process-r7rs . ,export-process-r7rs) . ,identifier))] [else rules]) @@ -277,7 +279,7 @@ (private:find-available-references-for expanded+callee-list current-document (cdr result) expression) (find-available-references-for current-document current-index-node expression)))])) -(define (find-top-env? standard top) +(define (private:top-env=? standard top) (not (null? (find (lambda (top-environment) (equal? standard top-environment)) (map identifier-reference-top-environment top))))) ) \ No newline at end of file diff --git a/analysis/identifier/meta.sls b/analysis/identifier/meta.sls index 34e358bd..13f61355 100644 --- a/analysis/identifier/meta.sls +++ b/analysis/identifier/meta.sls @@ -23,8 +23,11 @@ [root-identifiers (apply append (map root-ancestor identifiers))]) (find (lambda (i) (or (meta-library? (identifier-reference-library-identifier i)) (equal? (identifier-reference-identifier i) target-expression))) root-identifiers))) -(define (meta-library? list-instance) - (not (null? (find-meta list-instance)))) +(define meta-library? + (case-lambda + [(list-instance) (meta-library? list-instance 'r6rs)] + [(list-instance top-environment) + (not (null? (find-meta list-instance top-environment)))])) (define find-meta (case-lambda @@ -104,12 +107,15 @@ [else '()])] [else '()])])) -(define (private-process library-instance list-instance) - (sort-identifier-references - (map - (lambda (identifier-pair) - (make-identifier-reference (car identifier-pair) '() '() '() library-instance (cadr identifier-pair) '() '())) - list-instance))) +(define private-process + (case-lambda + [(library-instance list-instance) (private-process library-instance list-instance 'r6rs)] + [(library-instance list-instance top-environment) + (sort-identifier-references + (map + (lambda (identifier-pair) + (make-identifier-reference (car identifier-pair) '() '() '() library-instance (cadr identifier-pair) '() '() top-environment)) + list-instance))])) (define (init-type-expressions) (map @@ -4884,7 +4890,8 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7)) (record-type-name procedure) (record-type-symbol procedure)))) -(define scheme-base (private-process '(scheme base) '( +(define scheme-base (private-process '(scheme base) '( +(define-library syntax) (* procedure) (+ procedure) (- procedure) @@ -5123,11 +5130,11 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7)) (write-string procedure) (write-u8 procedure) (zero? procedure) -))) +) 'r7rs)) (define scheme-case-lambda (private-process '(scheme case lambda) '( (case-lambda syntax) -))) +) 'r7rs)) (define scheme-char (private-process '(scheme char) '( (char-alphabetic? procedure) @@ -5152,7 +5159,7 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7)) (string-downcase procedure) (string-foldcase procedure) (string-upcase procedure) -))) +) 'r7rs)) (define scheme-complex (private-process '(scheme complex) '( (angle procedure) @@ -5161,7 +5168,7 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7)) (make-polar procedure) (make-rectangular procedure) (real-part procedure) -))) +) 'r7rs)) (define scheme-cxr (private-process '(scheme cxr) '( (caaaar procedure) @@ -5188,12 +5195,12 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7)) (cdddar procedure) (cddddr procedure) (cdddr procedure) -))) +) 'r7rs)) (define scheme-eval (private-process '(scheme eval) '( (environment procedure) (eval procedure) -))) +) 'r7rs)) (define scheme-file (private-process '(scheme file) '( (call-with-input-file procedure) @@ -5206,7 +5213,7 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7)) (open-output-file procedure) (with-input-from-file procedure) (with-output-to-file procedure) -))) +) 'r7rs)) (define scheme-inexact (private-process '(scheme inexact) '( (acos procedure) @@ -5221,7 +5228,7 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7)) (sin procedure) (sqrt procedure) (tan procedure) -))) +) 'r7rs)) (define scheme-lazy (private-process '(scheme lazy) '( (delay syntax) @@ -5229,11 +5236,11 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7)) (force procedure) (make-promise procedure) (promise? procedure) -))) +) 'r7rs)) (define scheme-load (private-process '(scheme load) '( (load procedure) -))) +) 'r7rs)) (define scheme-process-context (private-process '(scheme process context) '( (command-line procedure) @@ -5241,28 +5248,28 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7)) (exit procedure) (get-environment-variable procedure) (get-environment-variables procedure) -))) +) 'r7rs)) (define scheme-read (private-process '(scheme read) '( (read procedure) -))) +) 'r7rs)) (define scheme-repl (private-process '(scheme repl) '( (interaction-environment procedure) -))) +) 'r7rs)) (define scheme-time (private-process '(scheme time) '( (current-jiffy procedure) (current-second procedure) (jiffies-per-second procedure) -))) +) 'r7rs)) (define scheme-write (private-process '(scheme write) '( (display procedure) (write procedure) (write-shared procedure) (write-simple procedure) -))) +) 'r7rs)) (define scheme-r5rs (private-process '(scheme r5rs) '( (* procedure) @@ -5487,6 +5494,6 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7)) (write procedure) (write-char procedure) (zero? procedure) -))) +) 'r7rs)) ) \ No newline at end of file diff --git a/analysis/identifier/rules/r7rs/define-library-export-r7rs.sls b/analysis/identifier/rules/r7rs/define-library-export.sls similarity index 99% rename from analysis/identifier/rules/r7rs/define-library-export-r7rs.sls rename to analysis/identifier/rules/r7rs/define-library-export.sls index 0bf3131f..064e4a2d 100644 --- a/analysis/identifier/rules/r7rs/define-library-export-r7rs.sls +++ b/analysis/identifier/rules/r7rs/define-library-export.sls @@ -1,4 +1,4 @@ -(library (scheme-langserver analysis identifier rules r7rs define-library-export-r7rs) +(library (scheme-langserver analysis identifier rules r7rs define-library-export) (export export-process-r7rs) (import (chezscheme) diff --git a/analysis/identifier/rules/r7rs/define-library-import-r7rs.sls b/analysis/identifier/rules/r7rs/define-library-import.sls similarity index 97% rename from analysis/identifier/rules/r7rs/define-library-import-r7rs.sls rename to analysis/identifier/rules/r7rs/define-library-import.sls index 5f736c26..e20bae8f 100644 --- a/analysis/identifier/rules/r7rs/define-library-import-r7rs.sls +++ b/analysis/identifier/rules/r7rs/define-library-import.sls @@ -1,4 +1,4 @@ -(library (scheme-langserver analysis identifier rules r7rs define-library-import-r7rs) +(library (scheme-langserver analysis identifier rules r7rs define-library-import) (export library-import-process-r7rs) (import @@ -24,11 +24,12 @@ (map (lambda (child-node) (match-import index-node root-file-node root-library-node document child-node)) (cddr (index-node-children index-node)))] - ; [('define-library _ **1 ) - ; ; this should not use 'guard', because it follows the r7rs library mechanism(in sld) - ; (map - ; (lambda (child-node) (match-import index-node root-file-node root-library-node document child-node)) - ; (index-node-children index-node))] + ;; [('define-library _ **1 ) + ;; ; this should not use 'guard', because it follows the r7rs library mechanism(in sld) + ;; ((pretty-print `(DEBUG: match 2))) + ;; (map + ;; (lambda (child-node) (match-import index-node root-file-node root-library-node document child-node)) + ;; (index-node-children index-node))] [else '()]) index-node)) diff --git a/analysis/identifier/rules/r7rs/define-r7rs.sls b/analysis/identifier/rules/r7rs/define.sls similarity index 99% rename from analysis/identifier/rules/r7rs/define-r7rs.sls rename to analysis/identifier/rules/r7rs/define.sls index 5196a0ce..bb7ae1a0 100644 --- a/analysis/identifier/rules/r7rs/define-r7rs.sls +++ b/analysis/identifier/rules/r7rs/define.sls @@ -1,4 +1,4 @@ -(library (scheme-langserver analysis identifier rules r7rs define-r7rs) +(library (scheme-langserver analysis identifier rules r7rs define) (export define-r7rs-process) (import (chezscheme) From 2ef595768cfc1d4ec8e660e913864dabf2463ee6 Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Thu, 31 Jul 2025 14:39:19 +0800 Subject: [PATCH 4/5] rename body-process to begin-process add tests "define-library-import-process-r7rs" --- analysis/abstract-interpreter.sls | 5 ++--- analysis/identifier/meta.sls | 6 +++++- .../identifier/rules/{body.sls => begin.sls} | 6 +++--- .../identifier/self-defined-rules/router.sls | 4 ++-- .../identifier/test-macro-expander.sps | 2 +- tests/analysis/test-abstract-interpreter.sps | 19 +++++++++++++++++++ tests/analysis/test-local-expand.sps | 2 +- 7 files changed, 33 insertions(+), 11 deletions(-) rename analysis/identifier/rules/{body.sls => begin.sls} (85%) diff --git a/analysis/abstract-interpreter.sls b/analysis/abstract-interpreter.sls index 5c7b37c2..27c44a97 100644 --- a/analysis/abstract-interpreter.sls +++ b/analysis/abstract-interpreter.sls @@ -45,7 +45,7 @@ (scheme-langserver analysis identifier rules fluid-let) (scheme-langserver analysis identifier rules fluid-let-syntax) - (scheme-langserver analysis identifier rules body) + (scheme-langserver analysis identifier rules begin) (scheme-langserver analysis identifier rules library-export) (scheme-langserver analysis identifier rules library-import) @@ -244,8 +244,7 @@ [(and (equal? r '(load-library)) (private:top-env=? 'r6rs top)) (private-add-rule rules `((,load-library-process) . ,identifier))] - [(and (equal? r '(body)) (private:top-env=? 'r6rs top)) - (private-add-rule rules `((,do-nothing . ,body-process) . ,identifier))] + [(equal? r '(begin)) (private-add-rule rules `((,do-nothing . ,begin-process) . ,identifier))] [(and (equal? r '(define-library)) (private:top-env=? 'r7rs top)) (private-add-rule rules `((,library-import-process-r7rs . ,export-process-r7rs) . ,identifier))] diff --git a/analysis/identifier/meta.sls b/analysis/identifier/meta.sls index 13f61355..77c1f172 100644 --- a/analysis/identifier/meta.sls +++ b/analysis/identifier/meta.sls @@ -144,7 +144,11 @@ rnrs-programs rnrs-mutable-pairs rnrs-mutable-strings rnrs-io-ports rnrs-io-simple rnrs-arithmetic-flonums rnrs-arithmetic-bitwise rnrs-arithmetic-fixnums rnrs-records-syntactic rnrs-records-procedure -rnrs-records-inspection chezscheme-csv7 scheme-csv7)) +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)) ;numeric tower (fold-left (lambda (parent identifier-reference) diff --git a/analysis/identifier/rules/body.sls b/analysis/identifier/rules/begin.sls similarity index 85% rename from analysis/identifier/rules/body.sls rename to analysis/identifier/rules/begin.sls index 7733add1..5772cf75 100644 --- a/analysis/identifier/rules/body.sls +++ b/analysis/identifier/rules/begin.sls @@ -1,5 +1,5 @@ -(library (scheme-langserver analysis identifier rules body) - (export body-process) +(library (scheme-langserver analysis identifier rules begin) + (export begin-process) (import (chezscheme) (ufo-match) @@ -14,7 +14,7 @@ (scheme-langserver virtual-file-system file-node)) ; reference-identifier-type include -(define (body-process root-file-node root-library-node document index-node) +(define (begin-process root-file-node root-library-node document index-node) (let* ([ann (index-node-datum/annotations index-node)] [expression (annotation-stripped ann)]) (try diff --git a/analysis/identifier/self-defined-rules/router.sls b/analysis/identifier/self-defined-rules/router.sls index d9e7b6d9..4535e735 100644 --- a/analysis/identifier/self-defined-rules/router.sls +++ b/analysis/identifier/self-defined-rules/router.sls @@ -13,7 +13,7 @@ (scheme-langserver analysis dependency file-linkage) (scheme-langserver analysis identifier reference) - (scheme-langserver analysis identifier rules body) + (scheme-langserver analysis identifier rules begin) (scheme-langserver analysis identifier self-defined-rules srfi include-resolve) (scheme-langserver analysis identifier self-defined-rules ufo-match match) @@ -29,7 +29,7 @@ [possible-new-memory `(,@(reverse (cdr (reverse memory))) (,(car (reverse memory)) . ,identifier-list))]) (cond [(and (equal? library-identifiers '((srfi :23 error tricks))) (equal? expressions '(SRFI-23-error->R6RS))) - (add-rule-procedure rules `((,do-nothing . ,body-process) . ,target-identifier))] + (add-rule-procedure rules `((,do-nothing . ,begin-process) . ,target-identifier))] [(and (equal? library-identifiers '((srfi private include))) (equal? expressions '(include/resolve))) (let ([target-lambda (lambda (root-file-node root-library-node document index-node) diff --git a/tests/analysis/identifier/test-macro-expander.sps b/tests/analysis/identifier/test-macro-expander.sps index 00578f6d..5fffbc68 100755 --- a/tests/analysis/identifier/test-macro-expander.sps +++ b/tests/analysis/identifier/test-macro-expander.sps @@ -122,7 +122,7 @@ (test-begin "expand:step-by-step & generate-pair:template+callee & generate-pair:template+expanded for syntax-case") (let* ([workspace-instance (init-workspace (current-directory))] [root-file-node (workspace-file-node workspace-instance)] - [target-file-node (walk-file root-file-node (string-append (current-directory) "/analysis/identifier/rules/body.sls"))] + [target-file-node (walk-file root-file-node (string-append (current-directory) "/analysis/identifier/rules/begin.sls"))] [document (file-node-document target-file-node)] [target-index-node (pick-index-node-from (document-index-node-list document) (text+position->int (document-text document) 19 4))] [identifier-reference (car (find-available-references-for document target-index-node 'try))] diff --git a/tests/analysis/test-abstract-interpreter.sps b/tests/analysis/test-abstract-interpreter.sps index 112d873f..2b58f390 100755 --- a/tests/analysis/test-abstract-interpreter.sps +++ b/tests/analysis/test-abstract-interpreter.sps @@ -39,4 +39,23 @@ (index-node-references-import-in-this-node (car (document-index-node-list document))))))) (test-end) +(test-begin "define-library-import-process-r7rs") + (let* ( [workspace (init-workspace (string-append (current-directory) "/tests/resources/r7rs") 'txt 'r7rs #f #f)] + [root-file-node (workspace-file-node workspace)] + [target-file-node (walk-file root-file-node (string-append (current-directory) "/tests/resources/r7rs/liii/rich-vector.scm.txt"))] + [root-library-node (init-library-node root-file-node 'r7rs)] + [file-linkage (workspace-file-linkage workspace)] + [document (file-node-document target-file-node)]) + + (document-ordered-reference-list-set! document (sort-identifier-references (find-meta '(scheme base) 'r7rs))) + (step root-file-node root-library-node file-linkage document) + + (test-equal + '%index-of + (find + (lambda (identifier) (equal? identifier '%index-of)) + (map identifier-reference-identifier + (index-node-references-import-in-this-node (car (document-index-node-list document))))))) +(test-end) + (exit (if (zero? (test-runner-fail-count (test-runner-get))) 0 1)) diff --git a/tests/analysis/test-local-expand.sps b/tests/analysis/test-local-expand.sps index e917074d..1f5e24c7 100755 --- a/tests/analysis/test-local-expand.sps +++ b/tests/analysis/test-local-expand.sps @@ -40,7 +40,7 @@ (let* ( [workspace (init-workspace (current-directory) #f #f)] [root-file-node (workspace-file-node workspace)] [root-library-node (workspace-library-node workspace)] - [target-file-node (walk-file root-file-node (string-append (current-directory) "/analysis/identifier/rules/body.sls"))] + [target-file-node (walk-file root-file-node (string-append (current-directory) "/analysis/identifier/rules/begin.sls"))] [document (file-node-document target-file-node)] [target-text (document-text document)] [target-index-node (pick-index-node-from (document-index-node-list document) (text+position->int target-text 20 7))] From 7a305919036c88c6036b2800e89cde84b4c21d4e Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Wed, 6 Aug 2025 22:07:26 +0800 Subject: [PATCH 5/5] change test-abstract-interpreter.sps to 'receive --- tests/analysis/test-abstract-interpreter.sps | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/analysis/test-abstract-interpreter.sps b/tests/analysis/test-abstract-interpreter.sps index 2b58f390..43ebc4d0 100755 --- a/tests/analysis/test-abstract-interpreter.sps +++ b/tests/analysis/test-abstract-interpreter.sps @@ -51,9 +51,9 @@ (step root-file-node root-library-node file-linkage document) (test-equal - '%index-of + 'receive (find - (lambda (identifier) (equal? identifier '%index-of)) + (lambda (identifier) (equal? identifier 'receive)) (map identifier-reference-identifier (index-node-references-import-in-this-node (car (document-index-node-list document))))))) (test-end)