Add r6rs standard branch judgment in analysis/abstract-interpreter.sls

analysis/abstract-interpreter.sls

@@ -56,6 +56,10 @@
     (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 self-defined-rules router)
 
     (scheme-langserver virtual-file-system index-node)
@@ -163,19 +167,26 @@
           [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))]
             [(equal? r '(case-lambda)) (private-add-rule rules `((,case-lambda-process) . ,identifier))]
             [(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 +196,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 +237,16 @@
                 (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))]
+
+            [(and (equal? r '(body)) (find-top-env? 'r6rs top))
+              (private-add-rule rules `((,do-nothing . ,body-process) . ,identifier))]
 
-            [(equal? r '(body)) (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 
@@ -236,8 +260,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 +276,8 @@
         (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)
+  (not (null? (find (lambda (top-environment) (equal? standard top-environment))
+                (map identifier-reference-top-environment top)))))
 )

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?
 

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 '()])))
+)