Add QuickBASIC (#7080)

* Fix FreeBASIC capitalization

* Add QuickBASIC with samples

* Make regexes case-insensitive + small tweak

* Fix comment after CLS issue

* Include statement and second pass

* Add CONST + VBA second pass

* Improve quickbasic and freebasic heuristics

* del: Remove VBA fallback for now

Author: DecimalTurn

.gitmodules

@@ -1265,6 +1265,9 @@
 [submodule "vendor/grammars/vsc-language-1c-bsl"]
 	path = vendor/grammars/vsc-language-1c-bsl
 	url = https://github.com/1c-syntax/vsc-language-1c-bsl.git
+[submodule "vendor/grammars/vscode"]
+	path = vendor/grammars/vscode
+	url = https://github.com/QB64Official/vscode.git
 [submodule "vendor/grammars/vscode-TalonScript"]
 	path = vendor/grammars/vscode-TalonScript
 	url = https://github.com/mrob95/vscode-TalonScript.git

grammars.yml

@@ -1132,6 +1132,8 @@ vendor/grammars/vsc-fennel:
 vendor/grammars/vsc-language-1c-bsl:
 - source.bsl
 - source.sdbl
+vendor/grammars/vscode:
+- source.QB64
 vendor/grammars/vscode-TalonScript:
 - markdown.talon.codeblock
 - source.talon

lib/linguist/heuristics.yml

@@ -91,9 +91,15 @@ disambiguations:
   - language: B4X
     pattern: '\A\W{0,3}(?:.*(?:\r?\n|\r)){0,9}B4(?:J|A|R|i)=true'
   - language: FreeBASIC
-    pattern: '^[ \t]*#(?i)(?:define|endif|endmacro|ifn?def|include|lang|macro)(?:$|\s)'
+    named_pattern: freebasic
+  - language: FreeBASIC
+    and:
+    - pattern: '(?i)^[ \t]*return '
+    - negative_pattern: '(?i)[ \t]*gosub '
   - language: BASIC
     pattern: '\A\s*\d'
+  - language: QuickBASIC
+    named_pattern: quickbasic
   - language: VBA
     named_pattern: vba
   - language: Visual Basic 6.0
@@ -119,7 +125,11 @@ disambiguations:
 - extensions: ['.bi']
   rules:
   - language: FreeBASIC
-    pattern: '^[ \t]*#(?i)(?:define|endif|endmacro|ifn?def|if|include|lang|macro)(?:$|\s)'
+    named_pattern: freebasic
+  - language: FreeBASIC
+    and:
+    - pattern: '(?i)^[ \t]*return '
+    - negative_pattern: '(?i)[ \t]*gosub '
 - extensions: ['.bs']
   rules:
   - language: Bikeshed
@@ -922,6 +932,10 @@ named_patterns:
   - '^\s*(?:public\s+)?include\s'
   - '^\s*(?:(?:public|export|global)\s+)?(?:atom|constant|enum|function|integer|object|procedure|sequence|type)\s'
   fortran: '^(?i:[c*][^abd-z]|      (subroutine|program|end|data)\s|\s*!)'
+  freebasic:
+  - '(?i)^[ \t]*#(?:define|endif|endmacro|ifn?def|include|lang|macro|pragma)(?:$|\s)'
+  - '(?i)^[ \t]*dim( shared)? [a-z_][a-z0-9_]* as [a-z_][a-z0-9_]* ptr'
+  - '(?i)^[ \t]*dim( shared)? as [a-z_][a-z0-9_]* [a-z_][a-z0-9_]*'
   gsc:
   - '^\s*#\s*(?:using|insert|include|define|namespace)[ \t]+\w'
   - '^\s*(?>(?:autoexec|private)\s+){0,2}function\s+(?>(?:autoexec|private)\s+){0,2}\w+\s*\('
@@ -949,6 +963,24 @@ named_patterns:
   - '^\s*(?:\*|(?:our\s*)?@)EXPORT\s*='
   - '^\s*package\s+[^\W\d]\w*(?:::\w+)*\s*(?:[;{]|\sv?\d)'
   - '[\s$][^\W\d]\w*(?::\w+)*->[a-zA-Z_\[({]'
+  quickbasic:
+  # Uppercase keywords are a good indicator of QuickBASIC (if no FreeBASIC syntax is detected)
+  - '^[ ]*(CONST|DIM|REDIM|DEFINT|PRINT|DECLARE (SUB|FUNCTION)|FUNCTION|SUB) '
+  # Preprocessor statement to set the compiler dialect in QuickBASIC ($lang) and FreeBASIC (#lang)
+  - '(#|$)lang:?\s*"?qb"?'
+  # Other QuickBASIC-specific patterns
+  - '(?i)''\$INCLUDE:'
+  - '(?i)^[ ]*CLS[ ]*(''|:|\r|\n)'
+  - '(?i)^[ ]*OPTION _EXPLICIT'
+  - '(?i)^[ ]*DIM SHARED '
+  - '(?i)^[ ]*PRINT "'
+  - '(?i) As _(Byte|Offset|MEM)'
+  - '(?i)^[ ]*_(DISPLAY|DEST|CONSOLE|SOURCE|FREEIMAGE|PALETTECOLOR|PRINTSTRING|LOADFONT|PUTIMAGE)'
+  - '(?i)^[ ]*_(TITLE|PLAYMOD) "'
+  - '(?i)^[ ]*_(LIMIT|SCREEN|DELAY) \.?\d+'
+  - '(?i)\b_(MOUSEBUTTON|NEWIMAGE|KEYDOWN|WIDTH|HEIGHT)\('
+  - '(?i)^[ ]*\$(CONSOLE|CHECKING):'
+  - '(?i)^[ ]*\$(FULLSCREEN|RESIZE|STATIC|DYNAMIC|NOPREFIX|SCREENSHOW|SCREENHIDE|EXEICON)\b'
   raku: '^\s*(?:use\s+v6\b|\bmodule\b|\b(?:my\s+)?class\b)'
   vb-class: '^[ ]*VERSION [0-9]\.[0-9] CLASS'
   vb-form: '^[ ]*VERSION [0-9]\.[0-9]{2}'

lib/linguist/languages.yml

@@ -5857,6 +5857,22 @@ Quake:
   ace_mode: text
   tm_scope: source.quake
   language_id: 375265331
+QuickBASIC:
+  type: programming
+  color: "#008080"
+  extensions:
+  - ".bas"
+  tm_scope: source.QB64
+  aliases:
+  - qb
+  - qbasic
+  - qb64
+  - classic qbasic
+  - classic quickbasic
+  ace_mode: text
+  codemirror_mode: vb
+  codemirror_mime_type: text/x-vb
+  language_id: 593107205
 R:
   type: programming
   color: "#198CE7"

samples/BASIC/P180.BAS

@@ -0,0 +1,41 @@
+10 PRINT "PROGRAM FILE 180: EXCEPTION - EVALUATION OF NUMERIC"
+20 PRINT "        EXPRESSIONS IN THE ON-GOTO STATEMENT."
+30 PRINT "    ANSI STANDARD 7.5, 10.2, 10.5"
+40 PRINT
+50 PRINT "SECTION 180.1: EXCEPTION - EVALUATION OF NUMERIC"
+60 PRINT "        EXPRESSIONS IN THE ON-GOTO STATEMENT."
+70 PRINT
+80 PRINT "THIS SECTION TESTS THE EFFECT OF USING EXPRESSIONS,"
+90 PRINT "WHICH CAUSE NON-FATAL EXCEPTIONS, TO CONTROL THE ON-GOG."
+100 PRINT
+130 PRINT "TO PASS THIS TEST:"
+140 PRINT
+150 PRINT "     1) TWO EXCEPTIONS MUST BE REPORTED: DIVISION "
+160 PRINT "        BY ZERO AND ON-GOTO OUT OF RANGE, AND"
+170 PRINT
+180 PRINT "     2) EXECUTION MUST TERMINATE."
+190 PRINT
+193 PRINT "                    BEGIN TEST."
+196 PRINT
+200 PRINT "ABOUT TO EXECUTE:"
+210 PRINT "   ON 1E-33 / 0 GOTO ..."
+220 LET A=0
+230 LET C=1E-33
+240 PRINT
+250 ON C/A GOTO 280,300,320
+260 LET I=0
+270 GOTO 340
+280 LET I=1
+290 GOTO 340
+300 LET I=2
+310 GOTO 340
+320 LET I=3
+330 GOTO 340
+340 PRINT
+350 PRINT "    PATH TAKEN FOR CONTROL-EXPRESSION = ";I
+360 PRINT "*** TEST FAILED: EXECUTION DID NOT TERMINATE ***"
+370 PRINT
+380 PRINT "                    END TEST."
+390 PRINT
+400 PRINT "END PROGRAM 180"
+410 END

samples/QuickBASIC/FGETRT.BAS

@@ -0,0 +1,57 @@
+'*********** FGetRT.Bas - demonstrates FGetRT and FPutRT in context
+
+'Copyright (c) 1989 Ethan Winer
+
+
+DEFINT A-Z
+DECLARE SUB FClose (Handle)
+DECLARE SUB FCreate (FileName$)
+DECLARE SUB FGetRT (Handle, Destination AS ANY, RecNumber&, RecLength)
+DECLARE SUB FOpen (FileName$, Handle)
+DECLARE SUB FPutRT (Handle, Source AS ANY, RecNumber&, RecLength)
+DECLARE SUB KillFile (FileName$)
+
+DECLARE FUNCTION DOSError% ()
+DECLARE FUNCTION WhichError% ()
+DECLARE FUNCTION ErrorMsg$ (ErrNumber)
+
+TYPE FTest                      'this is the sample type for the file test
+   FirstName  AS STRING * 15
+   LastName   AS STRING * 15
+   Company    AS STRING * 25
+   AccountNum AS LONG
+   WhatNot    AS DOUBLE
+   WhyNot     AS SINGLE
+END TYPE
+DIM TestRec AS FTest            'TestRec will hold the data to/from the file
+
+CLS
+F$ = "Random.Tst"               'this will be our test file
+RecLength = LEN(TestRec)        'this sets the record length for gets and puts
+
+FCreate F$                      'create the file
+IF DOSError% THEN               'see if an error occurred creating the file
+   PRINT ErrorMsg$(WhichError%)
+   END
+END IF
+
+FOpen F$, Handle                        'open the file for QuickPak Pro Binary
+
+FOR Record& = 1 TO 100                  'create one hundred records
+    TestRec.FirstName = "Testing" + STR$(Record&)
+    TestRec.WhatNot = Record&
+    FPutRT Handle, TestRec, Record&, RecLength
+    IF DOSError% THEN                   'check for possible full disk
+       PRINT ErrorMsg$(WhichError%)
+       END
+    END IF
+NEXT
+
+FOR Record& = 99 TO 1 STEP -10  'read records backwards to prove it all works
+    FGetRT Handle, TestRec, Record&, RecLength
+    PRINT "Record"; Record&, TestRec.FirstName; TestRec.WhatNot
+NEXT
+
+FClose Handle                   'close the file
+KillFile F$                     'why clutter up the disk with this nonsense?
+

samples/QuickBASIC/VLONG.BAS

@@ -0,0 +1,67 @@
+'********** VLong.Bas demos three math functions and eight byte packing
+
+'Copyright (c) 1988 Paul Passarelli
+'Copyright (c) 1988 Crescent Software
+
+
+DEFINT A-Z
+DECLARE SUB VLAdd (Addend1#, Addend2#, Sum#, ErrFlag%)
+DECLARE SUB VLSub (Minuend#, Subtrahend#, Difference#, ErrFlag%)
+DECLARE SUB VLMul (Multiplicand#, Multiplier#, Product#, ErrFlagg%)
+DECLARE SUB VLPack (Number$, Value#, ErrFlag%)
+DECLARE SUB VLUnpack (Value#, Number$, ErrFlag%)
+DECLARE FUNCTION StripZ$ (X$)            'strips leading zeros for the demo
+
+
+CLS
+LINE INPUT "Enter a big number (up to 19 digits): ", Num1$
+LINE INPUT "            Enter another big number: ", Num2$
+PRINT
+
+VLPack Num1$, Num1#, ErrFlag
+IF ErrFlag% GOTO ErrHandler
+
+VLPack Num2$, Num2#, ErrFlag
+IF ErrFlag% GOTO ErrHandler
+
+VLAdd Num1#, Num2#, Sum#, ErrFlag
+UPSum$ = SPACE$(20)
+VLUnpack Sum#, UPSum$, ErrFlag%
+IF ErrFlag% GOTO ErrHandler
+
+PRINT Num1$; " + "; Num2$; " = "; StripZ$(UPSum$)
+
+VLSub Num1#, Num2#, Sum#, ErrFlag
+UPSum$ = SPACE$(20)
+VLUnpack Sum#, UPSum$, ErrFlag%
+IF ErrFlag% GOTO ErrHandler
+
+PRINT Num1$; " - "; Num2$; " = "; StripZ$(UPSum$)
+
+PRINT
+VLPack "2", Num3#, ErrFlag
+VLMul Num1#, Num3#, Prod#, ErrFlag
+IF ErrFlag% GOTO ErrHandler
+VLUnpack Prod#, UPSum$, ErrFlag%
+PRINT Num1$; " * 2 = "; StripZ$(UPSum$)
+
+VLPack "3", Num3#, ErrFlag
+VLMul Num1#, Num3#, Prod#, ErrFlag
+IF ErrFlag% GOTO ErrHandler
+VLUnpack Prod#, UPSum$, ErrFlag%
+PRINT Num1$; " * 3 = "; StripZ$(UPSum$)
+
+END
+
+ErrHandler:
+PRINT "Error - press any key ";
+
+FUNCTION StripZ$ (X$)
+    FOR X = 2 TO LEN(X$)
+        IF MID$(X$, X, 1) <> "0" THEN
+           StripZ$ = LEFT$(X$, 1) + MID$(X$, X)
+           EXIT FUNCTION
+        END IF
+    NEXT
+END FUNCTION
+

samples/QuickBASIC/sponge4.bas

@@ -0,0 +1,115 @@
+' Sponge4: a sponge construction based on RC4
+' Ref: https://nullprogram.com/blog/2020/11/17/
+' This is free and unencumbered software released into the public domain.
+
+TYPE sponge4
+    i AS INTEGER
+    j AS INTEGER
+    k AS INTEGER
+    s(0 TO 255) AS INTEGER
+END TYPE
+
+DECLARE SUB init (r AS sponge4)
+DECLARE SUB absorb (r AS sponge4, b AS INTEGER)
+DECLARE SUB absorbstop (r AS sponge4)
+DECLARE SUB absorbstr (r AS sponge4, x AS STRING)
+
+DECLARE FUNCTION squeeze% (r AS sponge4)
+DECLARE FUNCTION squeeze24& (r AS sponge4)
+DECLARE FUNCTION squeezen% (r AS sponge4, n AS INTEGER)
+
+CONST ntickets = 208
+CONST nresults = 12
+
+DIM tickets(0 TO ntickets - 1) AS INTEGER
+FOR i = 0 TO ntickets - 1
+    tickets(i) = i
+NEXT
+
+DIM sponge AS sponge4
+init sponge
+absorbstr sponge, DATE$
+absorbstr sponge, MKS$(TIMER)
+absorbstr sponge, MKI$(ntickets)
+
+CLS
+PRINT "Press Esc to finish, any other key for entropy..."
+t = TIMER
+DO
+    c& = c& + 1
+    LOCATE 2, 1
+    PRINT "cycles ="; c&; "; keys ="; k%
+
+    FOR i% = ntickets - 1 TO 1 STEP -1
+        j% = squeezen%(sponge, i% + 1)
+        SWAP tickets(i%), tickets(j%)
+    NEXT
+
+    k$ = INKEY$
+    IF k$ = CHR$(27) THEN
+        EXIT DO
+    ELSEIF k$ <> "" THEN
+        k% = k% + 1
+        absorbstr sponge, k$
+    END IF
+    absorbstr sponge, MKS$(TIMER)
+LOOP
+
+FOR i% = 1 TO nresults
+    PRINT tickets(i%)
+NEXT
+
+SUB absorb (r AS sponge4, b AS INTEGER)
+    r.j = (r.j + r.s(r.i) + b) MOD 256
+    SWAP r.s(r.i), r.s(r.j)
+    r.i = (r.i + 1) MOD 256
+    r.k = (r.k + 1) MOD 256
+END SUB
+
+SUB absorbstop (r AS sponge4)
+    r.j = (r.j + 1) MOD 256
+END SUB
+
+SUB absorbstr (r AS sponge4, x AS STRING)
+    FOR i% = 1 TO LEN(x)
+        absorb r, ASC(MID$(x, i%))
+    NEXT
+END SUB
+
+SUB init (r AS sponge4)
+    r.i = 0
+    r.j = 0
+    r.k = 0
+    FOR i% = 0 TO 255
+        r.s(i%) = i%
+    NEXT
+END SUB
+
+FUNCTION squeeze% (r AS sponge4)
+    IF r.k > 0 THEN
+        absorbstop r
+        DO WHILE r.k > 0
+            absorb r, r.k
+        LOOP
+    END IF
+
+    r.j = (r.j + r.i) MOD 256
+    r.i = (r.i + 1) MOD 256
+    SWAP r.s(r.i), r.s(r.j)
+    squeeze% = r.s((r.s(r.i) + r.s(r.j)) MOD 256)
+END FUNCTION
+
+FUNCTION squeeze24& (r AS sponge4)
+    b0& = squeeze%(r)
+    b1& = squeeze%(r)
+    b2& = squeeze%(r)
+    squeeze24& = b2& * &H10000 + b1& * &H100 + b0&
+END FUNCTION
+
+FUNCTION squeezen% (r AS sponge4, n AS INTEGER)
+    DO
+       x& = squeeze24&(r) - &H1000000 MOD n
+    LOOP WHILE x& < 0
+    squeezen% = x& MOD n
+END FUNCTION
+