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

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)
@@ -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)
+    (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)
 
     (scheme-langserver virtual-file-system index-node)
@@ -160,22 +164,31 @@
       (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 
-            [(equal? r '(define)) (private-add-rule rules `((,define-process) . ,identifier))]
+            [(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))
+              (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!)) (private:top-env=? 'r6rs top))
+              (private-add-rule rules `((,define-top-level-value-process) . ,identifier))]
+            [(and (equal? r '(define-top-level-value)) (private: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!)) (private:top-env=? 'r6rs top))
+              (private-add-rule rules `((,define-top-level-syntax-process) . ,identifier))]
+            [(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))]
             [(equal? r '(let*)) (private-add-rule rules `((,let*-process) . ,identifier))]
@@ -185,16 +198,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)) (private:top-env=? 'r6rs top))
+              (private-add-rule rules `((,fluid-let-process) . ,identifier))]
+            [(and (equal? r '(fluid-let-syntax)) (private: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)) (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))]
-            [(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)) (private:top-env=? 'r6rs top))
+              (private-add-rule rules `((,identifier-syntax-process) . ,identifier))]
+            [(and (equal? r '(with-syntax)) (private: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)) (private:top-env=? 'r6rs top))
+              (private-add-rule rules `((,library-import-process . ,export-process) . ,identifier))]
+            [(and (equal? r '(invoke-library)) (private: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 +239,15 @@
                 (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)) (private:top-env=? 'r6rs top))
+              (private-add-rule rules `((,load-program-process) . ,identifier))]
+            [(and (equal? r '(load-library)) (private:top-env=? 'r6rs top))
+              (private-add-rule rules `((,load-library-process) . ,identifier))]
+
+            [(equal? r '(begin)) (private-add-rule rules `((,do-nothing . ,begin-process) . ,identifier))]
 
-            [(equal? r '(body)) (private-add-rule rules `((,do-nothing . ,body-process) . ,identifier))]
+            [(and (equal? r '(define-library)) (private:top-env=? 'r7rs top))
+              (private-add-rule rules `((,library-import-process-r7rs . ,export-process-r7rs) . ,identifier))]
 
             [else rules])
           (route&add 
@@ -236,8 +261,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 +277,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 (private:top-env=? standard top)
+  (not (null? (find (lambda (top-environment) (equal? standard top-environment))
+                (map identifier-reference-top-environment top)))))
 )

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 
@@ -138,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)
@@ -4884,7 +4894,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 +5134,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 +5163,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 +5172,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 +5199,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 +5217,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,48 +5232,48 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7))
 (sin procedure)
 (sqrt procedure)
 (tan procedure)
-)))
+) 'r7rs))
 
 (define scheme-lazy (private-process '(scheme lazy) '( 
 (delay syntax)
 (delay-force syntax)
 (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)
 (emergency-exit procedure)
 (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 +5498,6 @@ rnrs-records-inspection chezscheme-csv7 scheme-csv7))
 (write procedure)
 (write-char procedure)
 (zero? procedure)
-)))
+) 'r7rs))
 
 )

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/body.sls → 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