From 00f64536ba9cd3cf5d1f7f58ca0938a8098cce30 Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Sun, 24 Aug 2025 14:57:10 +0800 Subject: [PATCH 1/2] add test for typed lambda in s7 --- analysis/identifier/rules/s7/typed-lambda.sls | 135 ++++++++++++++++++ .../identifier/rules/s7/test-typed-lambda | 38 +++++ tests/resources/r7rs/liii/base64.scm.txt | 135 ++++++++++++++++++ 3 files changed, 308 insertions(+) create mode 100644 analysis/identifier/rules/s7/typed-lambda.sls create mode 100644 tests/analysis/identifier/rules/s7/test-typed-lambda create mode 100644 tests/resources/r7rs/liii/base64.scm.txt diff --git a/analysis/identifier/rules/s7/typed-lambda.sls b/analysis/identifier/rules/s7/typed-lambda.sls new file mode 100644 index 0000000..366d1a3 --- /dev/null +++ b/analysis/identifier/rules/s7/typed-lambda.sls @@ -0,0 +1,135 @@ +(library (scheme-langserver analysis identifier rules s7 typed-lambda) + (export + typed-lambda-process + typed-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 (typed-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)]) + (let* ([ann (index-node-datum/annotations identifier-index-node)] + [expression (annotation-stripped ann)]) + (match expression + [(? symbol? x) + (typed-parameter-process index-node identifier-index-node index-node '() document)] + [(? pair? y) + (let* ([sub-identifier-index-node (car (index-node-children identifier-index-node))] + [sub-identifier-index-node-parent (index-node-parent sub-identifier-index-node)]) + (typed-parameter-process index-node sub-identifier-index-node index-node '() document))])) + (loop (cdr rest)))))] + + [(_ (? symbol? identifier) fuzzy ... ) + (typed-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 (typed-parameter-process initialization-index-node index-node lambda-node exclude document ) + (let* ([ann (index-node-datum/annotations index-node)] + [expression (annotation-stripped ann)]) + (if (symbol? expression) + (let ([reference + (make-identifier-reference + expression + 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)) + '()))) +) \ No newline at end of file diff --git a/tests/analysis/identifier/rules/s7/test-typed-lambda b/tests/analysis/identifier/rules/s7/test-typed-lambda new file mode 100644 index 0000000..6190d42 --- /dev/null +++ b/tests/analysis/identifier/rules/s7/test-typed-lambda @@ -0,0 +1,38 @@ +#!/usr/bin/env scheme-script +;; -*- mode: scheme; coding: utf-8 -*- !# +;; Copyright (c) 2025 WANG Zheng, HUANG zengqian +;; SPDX-License-Identifier: MIT +#!r6rs + +(import (rnrs (6)) (srfi :64 testing) + (scheme-langserver analysis workspace) + (scheme-langserver analysis identifier reference) + (scheme-langserver analysis identifier rules s7 typed-lambda) + (scheme-langserver analysis package-manager akku) + + (scheme-langserver util text) + (scheme-langserver protocol alist-access-object) + + (scheme-langserver virtual-file-system index-node) + (scheme-langserver virtual-file-system file-node) + (scheme-langserver virtual-file-system document)) + +(test-begin "typed-lambda-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/liii/base64.scm.txt")] + [document (file-node-document target-file-node)] + [root-index-node (car (document-index-node-list document))] + [target-index-node (pick-index-node-from `(,root-index-node) (text+position->int (document-text document) 122 6))]) + + (typed-lambda-process root-file-node root-library-node document target-index-node) + (test-equal #f + (not + (find + (lambda (reference) + (equal? 'str (identifier-reference-identifier reference))) + (index-node-references-import-in-this-node target-index-node))))) + +(test-end) + +(exit (if (zero? (test-runner-fail-count (test-runner-get))) 0 1)) \ No newline at end of file diff --git a/tests/resources/r7rs/liii/base64.scm.txt b/tests/resources/r7rs/liii/base64.scm.txt new file mode 100644 index 0000000..5c71400 --- /dev/null +++ b/tests/resources/r7rs/liii/base64.scm.txt @@ -0,0 +1,135 @@ +; +; Copyright (C) 2024 The Goldfish Scheme Authors +; +; Licensed under the Apache License, Version 2.0 (the "License"); +; you may not use this file except in compliance with the License. +; You may obtain a copy of the License at +; +; http://www.apache.org/licenses/LICENSE-2.0 +; +; Unless required by applicable law or agreed to in writing, software +; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT +; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +; License for the specific language governing permissions and limitations +; under the License. +; + +(define-library (liii base64) + (import (liii base) + (liii bitwise)) + (export + string-base64-encode bytevector-base64-encode base64-encode + string-base64-decode bytevector-base64-decode base64-decode + ) + (begin + (define-constant BYTE2BASE64_BV + (string->utf8 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")) + + (define-constant BASE64_PAD_BYTE + (char->integer #\=)) + + (define bytevector-base64-encode + (typed-lambda ((bv bytevector?)) + (define (encode b1 b2 b3) + (let* ((p1 b1) + (p2 (if b2 b2 0)) + (p3 (if b3 b3 0)) + (combined (bitwise-ior (ash p1 16) (ash p2 8) p3)) + (c1 (bitwise-and (ash combined -18) #x3F)) + (c2 (bitwise-and (ash combined -12) #x3F)) + (c3 (bitwise-and (ash combined -6) #x3F)) + (c4 (bitwise-and combined #x3F))) + (values + (BYTE2BASE64_BV c1) + (BYTE2BASE64_BV c2) + (if b2 (BYTE2BASE64_BV c3) BASE64_PAD_BYTE) + (if b3 (BYTE2BASE64_BV c4) BASE64_PAD_BYTE)))) + + (let* ((input-N (bytevector-length bv)) + (output-N (* 4 (ceiling (/ input-N 3)))) + (output (make-bytevector output-N))) + (let loop ((i 0) (j 0)) + (when (< i input-N) + (let* ((b1 (bv i)) + (b2 (if (< (+ i 1) input-N) (bv (+ i 1)) #f)) + (b3 (if (< (+ i 2) input-N) (bv (+ i 2)) #f))) + (receive (r1 r2 r3 r4) (encode b1 b2 b3) + (bytevector-u8-set! output j r1) + (bytevector-u8-set! output (+ j 1) r2) + (bytevector-u8-set! output (+ j 2) r3) + (bytevector-u8-set! output (+ j 3) r4) + (loop (+ i 3) (+ j 4)))))) + output))) + + (define string-base64-encode + (typed-lambda ((str string?)) + (utf8->string (bytevector-base64-encode (string->utf8 str))))) + + (define (base64-encode x) + (cond ((string? x) + (string-base64-encode x)) + ((bytevector? x) + (bytevector-base64-encode x)) + (else + (type-error "input must be string or bytevector")))) + + (define-constant BASE64_TO_BYTE_V + (let1 byte2base64-N (bytevector-length BYTE2BASE64_BV) + (let loop ((i 0) (v (make-vector 256 -1))) + (if (< i byte2base64-N) + (begin + (vector-set! v (BYTE2BASE64_BV i) i) + (loop (+ i 1) v)) + v)))) + + (define (bytevector-base64-decode bv) + (define (decode c1 c2 c3 c4) + (let* ((b1 (BASE64_TO_BYTE_V c1)) + (b2 (BASE64_TO_BYTE_V c2)) + (b3 (BASE64_TO_BYTE_V c3)) + (b4 (BASE64_TO_BYTE_V c4))) + (if (or (negative? b1) (negative? b2) + (and (negative? b3) (not (equal? c3 BASE64_PAD_BYTE))) + (and (negative? b4) (not (equal? c4 BASE64_PAD_BYTE)))) + (value-error "Invalid base64 input") + (values + (bitwise-ior (ash b1 2) (ash b2 -4)) + (bitwise-and (bitwise-ior (ash b2 4) (ash b3 -2)) #xFF) + (bitwise-and (bitwise-ior (ash b3 6) b4) #xFF) + (if (negative? b3) 1 (if (negative? b4) 2 3)))))) + + (let* ((input-N (bytevector-length bv)) + (output-N (* input-N 3/4)) + (output (make-bytevector output-N))) + + (unless (zero? (modulo input-N 4)) + (value-error "length of the input bytevector must be 4X")) + + (let loop ((i 0) (j 0)) + (if (< i input-N) + (receive (r1 r2 r3 cnt) + (decode (bv i) (bv (+ i 1)) (bv (+ i 2)) (bv (+ i 3))) + (bytevector-u8-set! output j r1) + (when (>= cnt 2) + (bytevector-u8-set! output (+ j 1) r2)) + (when (>= cnt 3) + (bytevector-u8-set! output (+ j 2) r3)) + (loop (+ i 4) (+ j cnt))) + (let ((final (make-bytevector j))) + (vector-copy! final 0 output 0 j) + final))))) + + (define string-base64-decode + (typed-lambda ((str string?)) + (utf8->string (bytevector-base64-decode (string->utf8 str))))) + + (define (base64-decode x) + (cond ((string? x) + (string-base64-decode x)) + ((bytevector? x) + (bytevector-base64-decode x)) + (else + (type-error "input must be string or bytevector")))) + + ) ; end of begin + ) ; end of define-library From 63ce9d11287514e47d2d8384512afad9e50a255e Mon Sep 17 00:00:00 2001 From: VSteveHL Date: Sun, 24 Aug 2025 20:52:04 +0800 Subject: [PATCH 2/2] add define-macro test for r7rs --- analysis/abstract-interpreter.sls | 4 ++ analysis/identifier/rules/s7/define-macro.sls | 61 +++++++++++++++---- .../identifier/rules/s7/test-define-macro.sps | 38 ++++++++++++ ...est-typed-lambda => test-typed-lambda.sps} | 0 4 files changed, 90 insertions(+), 13 deletions(-) create mode 100644 tests/analysis/identifier/rules/s7/test-define-macro.sps rename tests/analysis/identifier/rules/s7/{test-typed-lambda => test-typed-lambda.sps} (100%) diff --git a/analysis/abstract-interpreter.sls b/analysis/abstract-interpreter.sls index f05a370..099fa1a 100644 --- a/analysis/abstract-interpreter.sls +++ b/analysis/abstract-interpreter.sls @@ -63,6 +63,7 @@ (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 rules s7 typed-lambda) (scheme-langserver analysis identifier self-defined-rules router) @@ -261,6 +262,9 @@ [(and (equal? r '(lambda*)) (private:top-env=? 's7 top)) (private-add-rule rules `((,lambda*-process) . ,identifier))] + + [(and (equal? r '(typed-lambda)) (private:top-env=? 's7 top)) + (private-add-rule rules `((,typed-lambda-process) . ,identifier))] [else rules]) (route&add diff --git a/analysis/identifier/rules/s7/define-macro.sls b/analysis/identifier/rules/s7/define-macro.sls index edcae26..41b6cfd 100644 --- a/analysis/identifier/rules/s7/define-macro.sls +++ b/analysis/identifier/rules/s7/define-macro.sls @@ -17,31 +17,66 @@ (scheme-langserver virtual-file-system file-node)) ; reference-identifier-type include -; syntax-parameter +; procedure 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 ... ) + [(_ ((? 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 - '() - '())]) + [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)))] + (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 '()])))) diff --git a/tests/analysis/identifier/rules/s7/test-define-macro.sps b/tests/analysis/identifier/rules/s7/test-define-macro.sps new file mode 100644 index 0000000..8e2b92f --- /dev/null +++ b/tests/analysis/identifier/rules/s7/test-define-macro.sps @@ -0,0 +1,38 @@ +#!/usr/bin/env scheme-script +;; -*- mode: scheme; coding: utf-8 -*- !# +;; Copyright (c) 2025 WANG Zheng, HUANG zengqian +;; SPDX-License-Identifier: MIT +#!r6rs + +(import (rnrs (6)) (srfi :64 testing) + (scheme-langserver analysis workspace) + (scheme-langserver analysis identifier reference) + (scheme-langserver analysis identifier rules s7 define-macro) + (scheme-langserver analysis package-manager akku) + + (scheme-langserver util text) + (scheme-langserver protocol alist-access-object) + + (scheme-langserver virtual-file-system index-node) + (scheme-langserver virtual-file-system file-node) + (scheme-langserver virtual-file-system document)) + +(test-begin "define-macro-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/boot.scm.txt")] + [document (file-node-document target-file-node)] + [target-index-node (caddr (document-index-node-list document))]) + + (define-macro-process root-file-node root-library-node document target-index-node) + + (test-equal #f + (not + (find + (lambda (reference) + (equal? 'libname (identifier-reference-identifier reference))) + (index-node-references-import-in-this-node target-index-node))))) + +(test-end) + +(exit (if (zero? (test-runner-fail-count (test-runner-get))) 0 1)) \ No newline at end of file diff --git a/tests/analysis/identifier/rules/s7/test-typed-lambda b/tests/analysis/identifier/rules/s7/test-typed-lambda.sps similarity index 100% rename from tests/analysis/identifier/rules/s7/test-typed-lambda rename to tests/analysis/identifier/rules/s7/test-typed-lambda.sps