Add QuickBASIC with samples

.gitmodules

@@ -1253,6 +1253,9 @@
 [submodule "vendor/grammars/vsc-fennel"]
 	path = vendor/grammars/vsc-fennel
 	url = https://github.com/kongeor/vsc-fennel
+[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

@@ -1120,6 +1120,8 @@ vendor/grammars/vsc-ember-syntax:
 - text.html.ember-handlebars
 vendor/grammars/vsc-fennel:
 - source.fnl
+vendor/grammars/vscode:
+- source.QB64
 vendor/grammars/vscode-TalonScript:
 - markdown.talon.codeblock
 - source.talon

lib/linguist/heuristics.yml

@@ -94,6 +94,18 @@ disambiguations:
     pattern: '^[ \t]*#(?i)(?:define|endif|endmacro|ifn?def|include|lang|macro)(?:$|\s)'
   - language: BASIC
     pattern: '\A\s*\d'
+  - language: QuickBASIC
+    pattern:
+    - '#?lang:?\s*"?qb"?'
+    - '^[ ]*CLS[ ]*(:|$)'
+    - '^[ ]*OPTION _EXPLICIT'
+    - ' As _(Byte|Offset|MEM)'
+    - '^[ ]*_(DISPLAY|DEST|CONSOLE|SOURCE|FREEIMAGE|PALETTECOLOR|PRINTSTRING|LOADFONT|PUTIMAGE)'
+    - '^[ ]*_(TITLE|PLAYMOD) "'
+    - '^[ ]*_(LIMIT|SCREEN|DELAY) \.?\d+'
+    - '\b_(MOUSEBUTTON|NEWIMAGE|KEYDOWN|WIDTH|HEIGHT)\('
+    - '^[ ]*\$(CONSOLE|CHECKING):'
+    - '^[ ]*\$(FULLSCREEN|RESIZE|STATIC|DYNAMIC|NOPREFIX|SCREENSHOW|SCREENHIDE|EXEICON)\b'
   - language: VBA
     and:
     - named_pattern: vb-module

lib/linguist/languages.yml

@@ -5835,6 +5835,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
+

test/test_heuristics.rb

@@ -279,7 +279,8 @@ def test_bas_by_heuristics
       "FreeBasic" => all_fixtures("FreeBasic", "*.bas"),
       "BASIC" => all_fixtures("BASIC", "*.bas"),
       "VBA" => all_fixtures("VBA", "*.bas"),
-      "Visual Basic 6.0" => all_fixtures("Visual Basic 6.0", "*.bas")
+      "Visual Basic 6.0" => all_fixtures("Visual Basic 6.0", "*.bas"),
+      "QuickBASIC" => all_fixtures("QuickBASIC", "*.bas")
     })
   end
 

vendor/README.md

@@ -469,6 +469,7 @@ This is a list of grammars that Linguist selects to provide syntax highlighting
 - **QMake:** [textmate/cpp-qt.tmbundle](https://github.com/textmate/cpp-qt.tmbundle)
 - **Qt Script:** [atom/language-javascript](https://github.com/atom/language-javascript)
 - **Quake:** [newgrammars/quake](https://github.com/newgrammars/quake)
+- **QuickBASIC:** [QB64Official/vscode](https://github.com/QB64Official/vscode)
 - **R:** [textmate/r.tmbundle](https://github.com/textmate/r.tmbundle)
 - **RAML:** [atom/language-yaml](https://github.com/atom/language-yaml)
 - **RBS:** [soutaro/vscode-rbs-syntax](https://github.com/soutaro/vscode-rbs-syntax)