added r6rs grammar

Author: mkatychev

lib/linguist/heuristics.yml

@@ -718,8 +718,8 @@ disambiguations:
   rules:
   - language: Scheme
     pattern:
-    - '(?:''[\(\*#]|\w->\w|\.\.\.[\s\)]|\([+\-:<>\/=~\)]|~>|\s:\w|#\()'
-    - '^\s*\((?:define|import|library|let|set)'
+    - '(?:''[\(\*#]|\w->\w|\.\.\.[\s\)]|\([+\-:<>\/=~\)]|~>|\s:\w|#\()|#:\w'
+    - '^\s*\((?:define|import|library|lambda)'
     negative_pattern:
     - '\(#[\w-]+[!\?]'
     - '[\)\]"_]\s+[\*\+\?@]'

samples/Scheme/r6rs.scm

@@ -0,0 +1,38 @@
+(define-module (statprof)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (ice-9 format)
+  #:export (statprof-active?
+            statprof-start
+            statprof-stop
+            statprof
+            gcprof))
+
+
+(define (sample-stack-procs state stack)
+  (set-sample-count! state (+ (sample-count state) 1))
+
+  (let lp ((frame (stack-ref stack 0))
+           (len (stack-length stack))
+           (buffer (buffer state))
+           (pos (buffer-pos state)))
+    (define (write-sample sample)
+      (vector-set! buffer pos sample))
+    (define (continue pos)
+      (lp (frame-previous frame) (1- len) buffer pos))
+    (define (write-sample-and-continue sample)
+      (write-sample sample)
+      (continue (1+ pos)))
+    (cond
+     ((= pos (vector-length buffer))
+      (lp frame len (expand-buffer buffer) pos))
+     ((or (zero? len) (not frame))
+      (write-sample #f)
+      (set-buffer! state buffer)
+      (set-buffer-pos! state (1+ pos)))
+     (else
+      (write-sample-and-continue (frame-instruction-pointer frame))))))
+
+(define* (statprof-display-anomalies #:optional (state
+                                                 (existing-profiler-state)))

samples/Scheme/r7rs.scm

@@ -0,0 +1,114 @@
+(import (scheme base)
+        (scheme read)
+        (scheme write)
+        (srfi 18)
+        )
+
+(thread-start!
+  (make-thread
+    (lambda ()
+      (thread-sleep! 1.2)
+      (display "started thread, this should be written to console")
+      (newline)
+      (display "thread done")
+      (newline)
+      (flush-output-port (current-output-port)))))
+
+(thread-sleep! 1) ;; Prevent race condition replacing stdout before thread is spawned
+(write `(1 2 3))
+(define fp (open-output-file "tmp.txt"))
+(parameterize
+  ((current-output-port fp))
+  (write `(4 5 6))
+  (thread-sleep! 3)
+)
+(close-port fp)
+(write `(7 8 9))
+
+;;; The game of life example from r7rs.
+;;; Main program
+
+(import (scheme base)
+        (only (example life) life)
+        (rename (prefix (example grid) grid-)
+                (grid-make make-grid)))
+;; Initialize a grid with a glider.
+(define grid (make-grid 24 24))
+(grid-put! grid 1 1 #t)
+(grid-put! grid 2 2 #t)
+(grid-put! grid 3 0 #t)
+(grid-put! grid 3 1 #t)
+(grid-put! grid 3 2 #t)
+;; Run for x iterations.
+(life grid 80)
+
+
+(define-library (example life)
+  (import (except (scheme base) set!))
+  (cond-expand
+    (cyclone
+     (import (scheme write))
+     (import (example grid))
+
+     ))
+
+  (cond-expand
+    (cyclone
+  (export life)
+  ))
+
+  (cond-expand
+    (cyclone
+    (begin
+    (define (life-count grid i j)
+      (define (count i j)
+        (if (ref grid i j) 1 0))
+      (+ (count (- i 1) (- j 1))
+         (count (- i 1) j)
+         (count (- i 1) (+ j 1))
+         (count i (- j 1))
+         (count i (+ j 1))
+         (count (+ i 1) (- j 1))
+         (count (+ i 1) j)
+         (count (+ i 1) (+ j 1))))
+    )
+    (begin
+    (define (life-alive? grid i j)
+      (case (life-count grid i j)
+            ((3) #t)
+            ((2) (ref grid i j))
+            (else #f)))
+)
+
+    )
+  )
+  (begin
+    (define (clear-vt100)
+        (display
+            (string
+                (integer->char #x1B)
+                #\[
+                #\H
+                (integer->char #x1B)
+                #\[
+                #\J)))
+    (define (life-print grid)
+      (clear-vt100)
+      (each grid
+        (lambda (i j v)
+          (display (if v "*" " "))
+          (if (= j (- (cols grid) 1))
+          ;(when (= j (- (cols grid) 1))
+            (newline)))))
+    (define (life grid iterations)
+      (do ((i 0 (+ i 1))
+           (grid0 grid grid1)
+           (grid1 (make (rows grid) (cols grid))
+                  grid0))
+          ((= i iterations))
+        (each grid0
+          (lambda (j k v)
+            (let ((a (life-alive? grid0 j k)))
+              (put! grid1 j k a))))
+              ;(set! grid1 j k a))))
+        (life-print grid1)))))

samples/Tree-sitter Query/injections.scm

@@ -1,9 +1,74 @@
-((macro_invocation
-  (token_tree) @injection.content)
- (#set! injection.language "rust")
- (#set! injection.include-children))
-
-((macro_rule
-  (token_tree) @injection.content)
- (#set! injection.language "rust")
- (#set! injection.include-children))
+((comment) @injection.content
+  (#set! injection.language "comment"))
+
+
+((regex_literal
+  (_) @injection.content)
+  (#set! injection.language "regex"))
+
+(recipe_body
+  !shebang
+  (#set! injection.language "bash")
+  (#set! injection.include-children)) @injection.content
+
+(external_command
+  (command_body) @injection.content
+  (#set! injection.language "bash"))
+
+(source_file
+  (setting "shell" ":=" "[" (string) @_langstr
+    (#match? @_langstr ".*(powershell|pwsh|cmd).*")
+    (#set! injection.language "powershell"))
+  [
+    (recipe
+      (recipe_body
+        !shebang
+        (#set! injection.include-children)) @injection.content)
+
+    (assignment
+      (expression
+        (value
+          (external_command
+            (command_body) @injection.content))))
+  ])
+
+(source_file
+  (setting "shell" ":=" "[" (string) @injection.language
+    (#not-match? @injection.language ".*(powershell|pwsh|cmd).*"))
+  [
+    (recipe
+      (recipe_body
+        !shebang
+        (#set! injection.include-children)) @injection.content)
+
+    (assignment
+      (expression
+        (value
+          (external_command
+            (command_body) @injection.content))))
+  ])
+
+(recipe_body 
+  (shebang 
+    (language) @injection.language)                                                     
+  (#not-any-of? @injection.language "python3" "nodejs" "node" "uv")                     
+  (#set! injection.include-children)) @injection.content                                
+                                                                                        
+(recipe_body                                                                            
+  (shebang                                                                              
+    (language) @_lang)                                                                  
+  (#any-of? @_lang "python3" "uv")                                                      
+  (#set! injection.language "python")                                                   
+  (#set! injection.include-children)) @injection.content                                
+
+(recipe_body                                                                            
+  (shebang                                                                              
+    (language) @_lang)                                                                  
+  (#any-of? @_lang "node" "nodejs")                                                     
+  (#set! injection.language "javascript")                                               
+  (#set! injection.include-children)) @injection.content                                
+
+(recipe_body                                                                            
+  (shebang) @injection.shebang                                                          
+  (#set! injection.include-children)) @injection.content                                
+