├── CompilerSuite.md ├── MCompiler.md ├── MExamples ├── bignum.m ├── jpeg.m └── readme.md ├── MFeatures.md ├── Modules24.md ├── QBenchmarks.md ├── QExamples ├── fib.q ├── hello.q ├── qq_run.m ├── qq_runlab.m └── qu.c ├── README.md ├── backups ├── aap.ma ├── ccp.ma ├── mmp.ma ├── pcp.ma ├── qqp.ma ├── readme.md └── runmx.ma ├── pclchart.md ├── qq.c └── runmx.c /CompilerSuite.md: -------------------------------------------------------------------------------- 1 | ## 'M' Compiler Suite 2 | 3 | All tools run on and for x64 with Windows. 4 | 5 | **'MM' M Systems Compiler (MM7)** 6 | ```` 7 | .m/.ma ────┬─> [mm.exe] ─┬────> .exe/.dll Files (+ M/Q Interface module for DLL/ML) 8 | .ml/.dll ──┘ ├────> .ml/.mx Files 9 | ├────> .obj File 10 | ├────> Run (native code in memory) 11 | ├────> .asm File (syntax for my AA assembler) 12 | ├────> .nasm File (NASM syntax, if configured) 13 | ├────> .pcl IL File 14 | ├────> Interpret (IL code in memory) 15 | ├────> .ma File (create single amalgamated source file) 16 | ├────> .c File via PCL (available via 'MC' config; see below) 17 | └────> .list/.proj Files (info for my IDE) 18 | ```` 19 | 20 | **'PC' PCL Processor** 21 | ```` 22 | .pcl ──────┬─> [pc.exe] ─┬────> .exe/.dll Files 23 | .ml/.dll ──┘ ├────> .ml/.mx Files 24 | ├────> .obj File 25 | ├────> Run native code in memory 26 | ├────> .asm File 27 | ├────> .nasm File (if configured) 28 | ├────> .pcl IL File (uses .pct extension) 29 | ├────> .c File (if configured) 30 | └────> Interpret IL code 31 | ```` 32 | **'AA' x64 Assembler/linker (AA7)** 33 | ```` 34 | .asm ──────┬─> [aa.exe] ─┬────> .exe/.dll Files 35 | .ml/.dll ──┘ ├────> .ml/.mx Files 36 | ├────> .obj File 37 | ├────> Run (native code in memory) 38 | ├────> .asm File (syntax for my AA assembler) (uses .aa extension) 39 | └────> .nasm File (NASM syntax) 40 | ```` 41 | 42 | **'QQ' Q Interpreter (QQ7)** 43 | ```` 44 | .q/.qa ───> [qq.exe] ──┬────> Run (compile to internal bytecode and immediately interpret) 45 | ↑ └────> .qa File (create single amalgamated source file) 46 | .ml/.dll ─────┘ 47 | 48 | ```` 49 | **'RUNMX' Launch MX Programs** 50 | ```` 51 | .mx ───────┬─> [runmx.exe] ───> Run (Load, fix up, and execute the MX-format executable) 52 | .ml/.dll ──┘ 53 | ```` 54 | **'MC' M to C Transpiler (MC7)** 55 | ```` 56 | .m/.ma ──────> [mm.exe] ──────> .c File (linear, stripped C generated via PCL/IL) 57 | 58 | ```` 59 | 60 | ### Packaging 61 | 62 | All the above programs are single-file, self-contained executables, and all are under 1MB. The current set of programs are: 63 | ```` 64 | mm.exe 403 KB Includes std library sources 65 | aa.exe 121 KB 66 | qq.exe 508 KB Includes std lib sources 67 | pc.exe 184 KB Fully loaded (smaller configurations can be done, eg. interpret only) 68 | runmx.exe 57 KB (Includes diagnostic display) 69 | ```` 70 | 71 | ### Implementation 72 | 73 | All products are written in my M language and built with **MM**. Single-file source amalgamations (MA files) can be generated for any project. 74 | 75 | Building all of the above executables from source takes about 1/3 second in total. 76 | 77 | ### Versions 78 | 79 | All products will share the same major version number 7. This ensures that can all work together. 80 | -------------------------------------------------------------------------------- /MCompiler.md: -------------------------------------------------------------------------------- 1 | ## M Compiler Structure 2 | 3 | 'M' is my lower level systems language. 4 | 5 | The name of the compiler is `MM` or `mm.exe`. It is a whole-program compiler, written in M, that converts M programs to x64 native code running under Windows ABI. 6 | ```` 7 | Inputs Intermediates Outputs 8 | 9 | Ext Libs ───>───────────────────────────┐ 10 | Source File ─┬─> AST1 ─> AST2 ─┬─> AST3 ─┬─┴──> PCL ─┬─> MCL ─┬─> SS ─┬─> EXE Image ──┬───> EXE File 11 | Include Files ─┘ │ │ │ │ │ └───> DLL File 12 | Strinclude ───>───────────────┘ │ │ │ ├───────────────────> OBJ File 13 | │ │ │ └─> MCU ─┬─> MCB ───> ML/MX Files 14 | │ │ │ └─> MCX ───> (RUN native code) 15 | │ │ ├───────────────────────────> ASM File 16 | │ │ └───────────────────────────> NASM File (Config option) 17 | │ ├────────────────────────────────────> (RUNP Interpret PCL) 18 | │ ├────────────────────────────────────> PCL Source File 19 | │ └────────────────────────────────────> C Source File (Config option) 20 | ├────────────────────────────────────────────────> MA File 21 | └────────────────────────────────────────────────> LIST/PROJ Files 22 | ```` 23 | 24 | #### Inputs 25 | ```` 26 | Source Files: There is only ever one `.m` source file submitted to MM. This will usually be the lead module, 27 | that also lists other modules of the project. 28 | Sometimes, that one input it will be a `.ma` file that contains all source and support files. 29 | 30 | Include Files These are discovered only when parsing all the source files. They are handled by the lexer. 31 | 32 | Strinclude Files: (Text files which become string constants.) These are loaded during type analysis. 33 | 34 | External Libs: Any DLL and ML libraries required by the program are listed in the lead module with other project info. 35 | These are always dynamically linked, never statically (there is no linker anyway). 36 | ```` 37 | #### Intermediates 38 | ```` 39 | AST1 Plus Symbol Table ST, and type tables TT, are generated by the Parser 40 | 41 | AST2 Has all name references resolved (language allows out of order definitions so needs this extra pass) 42 | 43 | AST3 Has type info filled in, any conversions applied, and constant expressions reduced 44 | 45 | PCL The generated IL (sometimes called IR) instructions from the AST. PCL uses a separate library that provides 46 | an API to generate internal PCL representation, which can then be processed in multiple different ways. 47 | 48 | MCL A representation of the generated native code, in this case it is for x64. 49 | 50 | SS A set of data structures containing binary native code and data, organised into code and data 51 | segments and with reloc info 52 | 53 | EXE Image An internal representation of what will go into the EXE file. 54 | 55 | MCU The binary code/data/import/reloc info for my private executable format 56 | 57 | MCB MCU rendered to a flat data block, written out as an ML/MX file 58 | 59 | MCX MCU with allocations, imports and fixups done to make it ready to run 60 | in-memory. 61 | ```` 62 | #### Outputs 63 | ```` 64 | EXE The Windows executable file format (PE+) 65 | 66 | DLL The Windows shared library format. 67 | 68 | ML My private shared library format which had taken over DLL tasks for a while. 69 | 70 | MX The same format, used to write a complete executable. (Needs RUNMX app to load and run. 71 | In this form it is believed to attract less attention from AV software) 72 | 73 | EXP Export files. These are under review, but when generating ML (it was done for DLL too), it also generated an 74 | import module, which I plan to do for both M and Q languages, which simplify using the library from an M or 75 | Q application. Just import that generated module. 76 | 77 | ASM x64 assembly source code, in a syntax used by my own assembler 'AA'. 78 | 79 | NASM NASM format x64 assembly source code. 80 | 81 | OBJ The single OBJ file produced represents the whole program. OBJ files allow M code to be statically linked with other 82 | languages, but require an external linker. 83 | 84 | RUN Not an output, the program is run immediately in memory without generating any executable file. This allows M to be used 85 | like a scripting language, running programs directly from source code. 86 | 87 | RUNP This interprets the PCL intermediate representation in memory without translation to native code. 88 | 89 | PCL A dump of the IL as textual source code. This can be processed by the separate PC application. 90 | 91 | C (Proposed config option, replaces dated separate C transpiler) 92 | Single C source file represents the entire program. No headers are generated. No headers are used in the file. 93 | Not all M programs can be transpiled as some features are not supported. Requires 64-bit C compiler; some features need gcc extensions. 94 | 95 | MA A single-file amalgamation of all source and support files needed to build a program. 96 | It can be directly built by MM to make for a tidy way of distributing and building M applications from source. 97 | 98 | LIST A dump of the top-level symbols (functions, variables, types, macros, enums) used across the project. These and 99 | the PROJ option are used by my IDE 100 | 101 | PROJ A summary of modules and subprograms used by the project 102 | 103 | ```` 104 | 105 | #### Compiler Size and Presentation 106 | 107 | The compiler is a single 300KB to 400KB EXE file depending on configuration. It is self-contained, and contains the sources for the language's standard library. So the whole installation is a single file, `mm.exe`. 108 | 109 | It translates M source code to binary at speeds of at least 500K lines per seconds, generating code at around 5MB per second. 110 | 111 | The smallest M compiler, minus std library, and with only an IL interpreter is about 220KB. 112 | 113 | #### ML and MX Files 114 | 115 | These were a by-product of problems I'd had with generating DLL files. They were due to be dropped but are being kept on as they have some interesting properties that could turn out to be useful. Basically they are much simpler (and I believe portable) versions of DLL and EXE files. 116 | -------------------------------------------------------------------------------- /MExamples/bignum.m: -------------------------------------------------------------------------------- 1 | !(Decimal 'bignumber' library for integers and floats) 2 | 3 | const digitwidth = 9 4 | const digitbase = 1'000'000'000 5 | const digitfmt = "%09d" 6 | const mdigitfmt = "z9" 7 | 8 | const digitmax = digitbase-1 9 | 10 | export type bignum = ref bignumrec 11 | type elemtype = int32 12 | const elemsize = elemtype.bytes 13 | 14 | export record bignumrec = 15 | ref[0:]elemtype num 16 | int length 17 | int expon 18 | int32 neg 19 | int32 numtype 20 | end 21 | 22 | record constrec = 23 | int64 value 24 | bignum bnvalue 25 | ref constrec nextconst 26 | end 27 | 28 | !special values for bignum types 29 | export enumdata [0:]ichar fpnames = 30 | (zero_type = 0, $), 31 | (normal_type, $), 32 | (inf_type, $), 33 | (nan_type, $), 34 | end 35 | 36 | !recognised combinations of bignum types (bintypes) 37 | enumdata = 38 | nn_types, ! both numbers (non-zero) 39 | zz_types, ! both zero 40 | ii_types, ! both infinity 41 | xx_types, ! one or both is nan 42 | 43 | nz_types, ! number/zero 44 | ni_types, ! number/infinity 45 | 46 | zn_types, ! zero/number 47 | in_types, ! infinity/number 48 | 49 | zi_types, ! zero/infinity 50 | iz_types ! infinity/zero 51 | end 52 | 53 | const maxprec = 10 million 54 | !int currprec = 100/digitwidth 55 | int currprec = 300/digitwidth 56 | 57 | int stblz !global set by smalltobig 58 | 59 | ref constrec constlist=nil !use linked list of constant values 60 | 61 | export func bn_init()bignum= 62 | bignum a 63 | 64 | a:=makebignum(0) 65 | return a 66 | end 67 | 68 | func readexpon(ichar s)int= 69 | !s points just after 'e' or 'E' 70 | int neg, expon 71 | neg:=expon:=0 72 | 73 | case s^ 74 | when '+' then ++s 75 | when '-' then neg:=1; ++s 76 | esac 77 | 78 | doswitch s^ 79 | when '0'..'9' then 80 | expon:=expon*10+(s^-'0') 81 | ++s 82 | when '_', '\'', '`', ' ' then 83 | ++s 84 | when 0 then 85 | exit 86 | else 87 | bn_error("make expon?") 88 | end doswitch 89 | 90 | return (neg|-expon|expon) 91 | end 92 | 93 | export proc bn_print(bignum a,int format=0)= 94 | ichar s 95 | 96 | s:=bn_tostring(a,format) 97 | print s 98 | ! free(s) 99 | end 100 | 101 | export proc bn_println(bignum a, int format=0)= 102 | bn_print(a,format) 103 | println 104 | end 105 | 106 | func getbintype(bignum a,b)int= 107 | !return bintype code for combination of a and b 108 | int atype:=a.numtype, btype:=b.numtype 109 | 110 | if atype=nan_type or btype=nan_type then 111 | return xx_types 112 | fi 113 | 114 | case atype 115 | when normal_type then 116 | case btype 117 | when normal_type then 118 | return nn_types 119 | when zero_type then 120 | return nz_types 121 | else 122 | return ni_types 123 | esac 124 | when zero_type then 125 | case btype 126 | when normal_type then 127 | return zn_types 128 | when zero_type then 129 | return zz_types 130 | else 131 | return zi_types 132 | esac 133 | else 134 | case btype 135 | when normal_type then 136 | return in_types 137 | when zero_type then 138 | return iz_types 139 | else 140 | return ii_types 141 | esac 142 | esac 143 | 144 | end 145 | 146 | func makebignum(int length)bignum= 147 | !ndigits=0 to create a zero value 148 | !these are wide digits 149 | bignum a 150 | 151 | a:=bn_alloc(bignumrec.bytes) 152 | if length then 153 | a.num:=bn_alloc(length*elemsize) 154 | a.numtype:=normal_type 155 | else 156 | a.num:=nil 157 | a.numtype:=zero_type 158 | fi 159 | a.length:=length 160 | a.expon:=0 161 | a.neg:=0 162 | 163 | return a 164 | end 165 | 166 | func makesmallnum(int length)ref elemtype= 167 | return bn_alloc(length*elemsize) 168 | end 169 | 170 | func smalltobig(bignum c, ref elemtype a, int length,alloc,offset=0)bignum = 171 | !copy numeric data from smallnum into new bignum 172 | !also normalises by removing trailing zeros and leading zeros 173 | !sets up expon with assumption that sequence represents an int 174 | !will also free alloc elemente of a, provided memory is not reused 175 | !offset is to be added to a, when a doesn't point to original allocation 176 | 177 | ref elemtype p 178 | int leadingzeros, trailingzeros, nonzeros, newlength 179 | 180 | bn_setzero(c) 181 | 182 | p:=a 183 | leadingzeros:=trailingzeros:=nonzeros:=0 184 | to length do 185 | if p++^ then 186 | nonzeros:=1 187 | trailingzeros:=0 188 | else 189 | if nonzeros then 190 | ++trailingzeros 191 | else 192 | ++leadingzeros 193 | fi 194 | fi 195 | od 196 | 197 | stblz:=leadingzeros 198 | 199 | if nonzeros then 200 | 201 | newlength:=length-trailingzeros-leadingzeros 202 | 203 | if newlength=length=alloc then !can use data in a directly 204 | c.num:=cast(a) 205 | else 206 | c.num:=cast(makesmallnum(newlength)) 207 | memcpy(c.num,a+leadingzeros,newlength*elemsize) 208 | freesmall(a+offset,alloc) 209 | fi 210 | c.length:=newlength 211 | c.numtype:=normal_type 212 | c.expon:=length-1-leadingzeros !include trailing zeros, but not leading ones? 213 | elsif alloc then !result stays at zero 214 | freesmall(a+offset,alloc) 215 | fi 216 | 217 | return c 218 | end 219 | 220 | proc freesmall(ref elemtype p, int length)= 221 | freemem(p,length*elemsize) 222 | end 223 | 224 | export func bn_alloc(int size)ref void= 225 | ref void p 226 | 227 | p:=pcm_alloc(size) 228 | if p=nil then 229 | abortprogram("bignum:out of memory") 230 | fi 231 | 232 | return p 233 | end 234 | 235 | func checkedmalloc(int size)ref void= 236 | ref void p 237 | 238 | p:=malloc(size) 239 | if p=nil then 240 | abortprogram("CM:Out of memory") 241 | fi 242 | 243 | return p 244 | end 245 | 246 | export proc bn_free(bignum a)= 247 | !free digit memory and descriptor 248 | if a then 249 | bn_setzero(a) 250 | freemem(a,bignumrec.bytes) 251 | fi 252 | end 253 | 254 | proc freemem(ref void p, int size)= 255 | !(my own deallocator needs the size; C's free() doesn't) 256 | ! free(p) 257 | pcm_free(p,size) 258 | end 259 | 260 | export proc bn_setzero(bignum a)= 261 | !clear digit memory only; clear descriptor to a zero number 262 | if a then 263 | if a.num then 264 | freesmall(cast(a.num),a.length) 265 | fi 266 | a.num:=nil 267 | a.length:=0 268 | a.neg:=0 269 | a.expon:=0 270 | a.numtype:=zero_type 271 | fi 272 | end 273 | 274 | export proc bn_move(bignum a,b)= 275 | !move contents of b to a. Original value of a is cleared; b becomes zero 276 | 277 | bn_setzero(a) 278 | a^:=b^ 279 | memset(b,0,bignumrec.bytes) 280 | end 281 | 282 | export proc bn_dupl(bignum a,b)= 283 | !copy contents of b to a. Each copy is independent 284 | bignum c 285 | int size 286 | 287 | ! if a=b then 288 | c:=bn_init() 289 | c^:=b^ 290 | if c.length then 291 | c.num:=cast(makesmallnum(size:=c.length)) 292 | memcpy(c.num,b.num, size*elemsize) 293 | fi 294 | bn_move(a,c) 295 | bn_free(c) 296 | ! fi 297 | 298 | ! bn_setzero(a) 299 | ! a^:=b^ 300 | ! if a.length then 301 | ! a.num:=bn_alloc(a.length*elemtype.bytes) 302 | ! fi 303 | end 304 | 305 | export proc bn_setinf(bignum dest) = 306 | bn_setzero(dest) 307 | dest.numtype:=inf_type 308 | end 309 | 310 | export proc bn_setnan(bignum dest) = 311 | bn_setzero(dest) 312 | dest.numtype:=nan_type 313 | end 314 | 315 | proc bn_error(ichar mess) = 316 | print "BN:" 317 | abortprogram(mess) 318 | end 319 | 320 | export func bn_iszero(bignum a)int= 321 | return a.numtype=zero_type 322 | end 323 | 324 | export proc bn_negto(bignum a)= 325 | if not bn_iszero(a) then 326 | a.neg:=not a.neg 327 | fi 328 | end 329 | 330 | export proc bn_absto(bignum a)= 331 | a.neg:=0 332 | end 333 | 334 | export func bn_isint(bignum a)int = 335 | return a.length<=a.expon+1 336 | end 337 | 338 | export func bn_getprec(bignum a)int= 339 | return a.length*digitwidth 340 | end 341 | 342 | export proc bn_setprec(bignum a,int prec)= 343 | int oldlength,newlength 344 | bignum c 345 | 346 | if a.numtype<>normal_type then 347 | return 348 | fi 349 | 350 | if prec<1 or prec>maxprec then 351 | return 352 | fi 353 | 354 | !prec is digit count, not words 355 | prec:=((prec-1)/digitwidth+1)*digitwidth !must be multiple of digitwidth 356 | 357 | !prec should be rounded up as needed to next multiple of digitwith 358 | newlength:=prec/digitwidth !no. words 359 | 360 | oldlength:=a.length 361 | 362 | if oldlength<=newlength then 363 | return 364 | fi 365 | 366 | c:=makebignum(newlength) 367 | c.neg:=a.neg 368 | c.expon:=a.expon 369 | 370 | for i:=0 to newlength-1 do 371 | if i=q, and plen>=qlen 453 | ref elemtype pp,qq 454 | int carry,diff,z 455 | 456 | pp:=p+plen-1 457 | qq:=q+qlen-1 458 | carry:=0 459 | z:=0 !leading zeros 460 | 461 | to plen do 462 | if qq>=q then 463 | diff:=pp^-qq^-carry 464 | --qq 465 | else 466 | diff:=pp^-carry 467 | fi 468 | 469 | if diff<0 then 470 | carry:=1 471 | pp^:=diff+digitbase 472 | else 473 | pp^:=diff 474 | carry:=0 475 | fi 476 | if pp^ then 477 | z:=0 478 | else 479 | ++z 480 | fi 481 | --pp 482 | od 483 | if carry then bn_error("SSUBTO/CARRY?") fi 484 | 485 | if z=plen then --z fi !result is zero, needs at least one digit 486 | 487 | if z then 488 | plen-:=z 489 | pp:=p 490 | qq:=p+z 491 | to plen do 492 | pp++^:=qq++^ 493 | od 494 | fi 495 | 496 | return plen 497 | end 498 | 499 | func smallmulto(ref elemtype p,q, int plen, m)int= 500 | !multiply bignum sequence p inplace, by single digit m 501 | !return new length (will be plen or plen+1, unless result is zero) 502 | !p must be long enough to store the extra digit 503 | 504 | ref elemtype pp,qq 505 | int carry,d 506 | 507 | case m 508 | when 0 then 509 | p^:=0 510 | return 1 511 | when 1 then 512 | memcpy(p,q,plen*elemsize) 513 | return plen 514 | esac 515 | 516 | pp:=p+plen-1 517 | qq:=q+plen-1 518 | carry:=0 519 | 520 | to plen do 521 | d:=int64(qq^)*m+carry 522 | pp^:=d rem digitbase 523 | 524 | carry:=d/digitbase 525 | ! carry:=divbydbase(d) 526 | --qq 527 | --pp 528 | od 529 | 530 | if carry then !need extra digit 531 | pp:=p+plen 532 | to plen do 533 | pp^:=(pp-1)^ 534 | --pp 535 | od 536 | pp^:=carry 537 | ++plen 538 | fi 539 | 540 | return plen 541 | end 542 | 543 | !func divbydbase(int d)int= 544 | ! assem 545 | ! mov rdx,[d] 546 | ! mov rcx, 19342813113834067 547 | ! shr rdx,9 548 | ! mov rax,rdx 549 | ! mul rcx 550 | ! xor eax,eax 551 | ! shr rdx,11 552 | ! mov rax,rdx 553 | ! end 554 | !end 555 | 556 | export func bn_equal(bignum a,b)int= 557 | if a.length<>b.length or \ 558 | a.numtype<>b.numtype or \ 559 | a.neg<>b.neg or \ 560 | a.expon<>b.expon then 561 | return 0 562 | fi 563 | 564 | if a.length=0 then return 1 fi 565 | 566 | return eqbytes(a.num,b.num,a.length*elemsize) 567 | end 568 | 569 | export proc bn_addu(bignum dest,a,b)= 570 | ref[0:]elemtype pa,pb 571 | int dc, i, offset, carry 572 | word j 573 | 574 | int preca, precb, precc 575 | int uppera,upperb,upperc, expona,exponb 576 | ref elemtype pax,pbx 577 | ref elemtype c,c2 578 | 579 | if a.expon(upperb+offset) then !A defines overall precision; B contained within A 593 | upperc:=uppera 594 | else !B extends overall precision 595 | upperc:=upperb+offset 596 | fi 597 | precc:=upperc+1 598 | 599 | c:=makesmallnum(precc) !no space for carry 600 | carry:=0 601 | pa:=a.num 602 | pb:=b.num 603 | 604 | for i:=upperc downto 0 do !do the add, starting from ls digit 605 | 606 | j:=i-offset !index of A/C in terms of B 607 | if i<=uppera and j<=word(upperb) then 608 | dc:=pa[i]+pb[j]+carry 609 | elsif i<=uppera then 610 | dc:=pa[i]+carry 611 | elsif j<=word(upperb) then 612 | dc:=pb[j]+carry 613 | else 614 | dc:=carry 615 | fi 616 | 617 | if dc>=digitbase then 618 | carry:=1 619 | (c+i)^:=dc-digitbase 620 | else 621 | (c+i)^:=dc 622 | carry:=0 623 | fi 624 | od 625 | 626 | if carry then 627 | c2:=makesmallnum(precc+1) 628 | c2^:=carry 629 | memcpy(c2+1,c,precc*elemsize) 630 | freesmall(c,precc) 631 | c:=c2 632 | ++precc 633 | fi 634 | 635 | smalltobig(dest,c,precc,precc) 636 | 637 | dest.expon:=expona+carry 638 | end 639 | 640 | proc bn_subu(bignum dest,a,b)= 641 | ref[0:]elemtype pa,pb 642 | int i, offset, diff, carry 643 | word j 644 | 645 | int preca, precb, precc 646 | int uppera,upperb,upperc, expona 647 | int da,db,dc, isneg, z, newprec 648 | ref elemtype c 649 | 650 | !can only do subtract when a>=b; do some basic checks 651 | isneg:=0 652 | if a.expon=b, and that isneg might be true 658 | retry: 659 | expona:=a.expon 660 | preca:=a.length 661 | precb:=b.length 662 | 663 | offset:=expona-b.expon !for indexing B elements shift to match A 664 | uppera:=preca-1 665 | upperb:=precb-1 666 | 667 | if uppera>(upperb+offset) then !A defines overall precision; B contained within A 668 | upperc:=uppera 669 | else !B extends overall precision 670 | upperc:=upperb+offset 671 | fi 672 | precc:=upperc+1 673 | 674 | c:=makesmallnum(precc) 675 | carry:=0 676 | pa:=a.num 677 | pb:=b.num 678 | 679 | for i:=upperc downto 0 do !do the add, starting from ls digit 680 | j:=i-offset !index of A/C in terms of B 681 | if i<=uppera and j<=word(upperb) then 682 | 683 | diff:=pa[i]-pb[j]-carry 684 | elsif i<=uppera then 685 | diff:=pa[i]-carry 686 | elsif j<=word(upperb) then 687 | diff:=-pb[j]-carry 688 | else 689 | diff:=-carry 690 | fi 691 | 692 | if diff<0 then 693 | carry:=1 694 | (c+i)^:=diff+digitbase 695 | else 696 | (c+i)^:=diff 697 | carry:=0 698 | fi 699 | 700 | od 701 | 702 | if carry then 703 | if isneg then !already swapped 704 | bn_error("SUBU/CARRY") 705 | fi 706 | swap(a,b) 707 | isneg:=1 708 | freesmall(c,precc) 709 | goto retry 710 | fi 711 | 712 | smalltobig(dest,c,precc,precc) 713 | dest.neg:=isneg 714 | dest.expon:=expona-stblz 715 | 716 | end 717 | 718 | proc bn_mulu(bignum dest, a,b) = 719 | !unsigned multiply, c:=a*b 720 | !general scheme A1/B1 are least significant words 721 | !x is total overflows (product overflow and carry) from previous column 722 | 723 | !(A4 A3 A2 A1) * (B3 B2 B1) 724 | ! 725 | !0 0 x A4.B1 A3.B1 A2.B1 A1.B1 726 | !0 x A4.B2 A3.B2 A2.B2 A1.B2 0 727 | !x A4.B3 A3.B3 A2.B3 A1.B3 0 0 728 | 729 | int pd, pr 730 | i64 p, x, carry 731 | int ax 732 | 733 | int uppera, upperb, upperc 734 | int precc,expona,exponb 735 | int bx,cx !indices within a,b,c 736 | int i,cx1, nc2 737 | bignum d 738 | ref elemtype c 739 | i64 pdquot,pdrem 740 | 741 | expona:=a.expon 742 | exponb:=b.expon 743 | uppera:=a.length-1 744 | upperb:=b.length-1 745 | 746 | precc:=uppera+upperb+2 747 | nc2:=precc 748 | 749 | c:=makesmallnum(nc2) 750 | memset(c,0,precc*elemsize) 751 | ! c.expon:=a.expon+b.expon+1 752 | cx:=precc-1 753 | 754 | for bx:=upperb downto 0 do 755 | carry:=0 756 | 757 | cx1:=cx 758 | for ax:=uppera downto 0 do 759 | p:=i64((a.num[ax]))*i64((b.num[bx]))+carry 760 | 761 | pd:=p/digitbase 762 | ! pd:=divbydbase(p) 763 | pr:=p-pd*digitbase 764 | 765 | x:=int64((c+cx1)^)+pr 766 | 767 | if x>digitmax then 768 | carry := pd+1 769 | (c+cx1--)^ := x-digitbase 770 | else 771 | carry:=pd 772 | (c+cx1--)^:=x 773 | fi 774 | 775 | od 776 | (c+cx1)^:=carry 777 | --cx !for next row, start at next column in dest 778 | od 779 | 780 | smalltobig(dest,c,precc,nc2) 781 | dest.expon:=expona+exponb+1-stblz 782 | end 783 | 784 | func smalldiv(ref elemtype x, b, int &xlen, nb)int = 785 | !x,b are smallnums: arrays of elements, of the exact lengths given 786 | !x is same length as b, or at most one element longer 787 | !(x can also be smaller, but then result is just 0) 788 | !return integer x/b as machine word type 0..digitmax 789 | !when digits are 0..9, then result of x/b is always going to be 0 to 9. 790 | 791 | int i 792 | int64 xx,y 793 | elemtype xi,bi 794 | int k,count 795 | ref elemtype e 796 | int esize,ne,nx 797 | 798 | nx:=xlen 799 | k:=0 800 | count:=0 801 | e:=makesmallnum(esize:=(nb+1)) 802 | 803 | do 804 | if nxnb then !x will be at most 1 digit wider than b 807 | xx:=int64(x^)*digitbase+int64((x+1)^) 808 | y:=xx/(b^+1) 809 | else !x,b are same length 810 | if x^>=(b^+1) then 811 | y:=x^/(b^+1) 812 | else 813 | y:=1 814 | for i:=0 to nb-1 do 815 | xi:=(x+i)^ 816 | bi:=(b+i)^ 817 | if xibi then 821 | exit 822 | fi 823 | od 824 | 825 | fi 826 | fi 827 | k+:=y 828 | if y>1 then 829 | ne:=smallmulto(e,b,nb,y) 830 | nx:=smallsubto(x,e,nx,ne) 831 | elsif y then 832 | nx:=smallsubto(x,b,nx,nb) 833 | else 834 | BN_ERROR("smalldiv:Y=0") 835 | fi 836 | od 837 | 838 | freesmall(e,esize) 839 | xlen:=nx !return modified x, and new length of x 840 | return k 841 | end 842 | 843 | export proc bn_idivu(bignum dest,a,b,rm=nil)= 844 | !neither a nor b are zero; both are positive 845 | !integer divide 846 | 847 | ref elemtype c,x,e 848 | int expona, exponb, badjust, exponc 849 | int na,nb,nc,nx,ne,nx2,ne2, cx,nupper 850 | int uppera, upperb, upperc 851 | int n, k, nexta 852 | int64 xx,y 853 | ref elemtype pa,pb 854 | 855 | na:=a.length 856 | nb:=b.length 857 | expona:=a.expon 858 | exponb:=b.expon 859 | badjust:=exponb+1-nb 860 | 861 | if na>expona+1 or nb>exponb+1 then 862 | bn_error("idivu:a or b not int") 863 | fi 864 | nc:=expona+1 865 | 866 | if expona=nupper then !finished with A 903 | exit 904 | fi 905 | 906 | nexta:=(n>uppera|0|(pa+n)^) 907 | ++n 908 | if nx=1 and x^=0 then 909 | x^:=nexta !x is 1 digit long 910 | else 911 | (x+nx)^:=nexta !next digit from a 912 | ++nx 913 | fi 914 | od 915 | 916 | if rm and exponb=2 then !leading zero (may not need cx check) 932 | smalltobig(dest,c+1,cx-1,nc,-1) 933 | else 934 | smalltobig(dest,c,cx,nc) 935 | fi 936 | ! freesmall(c,nc) 937 | 938 | if rm and exponb>=nb then !has trailing zeros so natural rem doesn't work 939 | bignum d 940 | d:=bn_init() 941 | bn_mulu(d,b,dest) 942 | bn_subu(rm,a,d) 943 | bn_free(d) 944 | fi 945 | 946 | end 947 | 948 | func strvaln(ref char s,int n)int= !STRVALN 949 | !convert first n chars of s to int value and return result will fit into 32 bits 950 | int a 951 | 952 | a:=0 953 | to n do 954 | if s^<>'_' then 955 | a:=a*10+s^-'0' 956 | fi 957 | ++s 958 | od 959 | return a 960 | end 961 | 962 | export func bn_makestr(ichar s, int length=0)bignum= 963 | ichar t,u 964 | int neg,dpindex,expon,nonzeros,talloc,dpseen 965 | int leadingzeros, trailingzeros,zerosafterdp 966 | int d,n,wd,dp,wdp,w,d2,na,nb 967 | bignum a 968 | 969 | if length=0 then 970 | length:=strlen(s) 971 | fi 972 | if length<=0 then 973 | return badnumber() 974 | fi 975 | talloc:=length+1+10 !allow for extending last wdigit group 976 | 977 | neg:=0 978 | case s^ 979 | when '+' then ++s 980 | when '-' then neg:=1; ++s 981 | esac 982 | 983 | t:=u:=bn_alloc(talloc) !accummulate sig digits into t 984 | dpindex:=-1 985 | dpseen:=zerosafterdp:=0 986 | nonzeros:=0 987 | leadingzeros:=trailingzeros:=0 988 | expon:=0 989 | 990 | doswitch s^ 991 | when '1'..'9' then 992 | u++^:=s++^ 993 | trailingzeros:=0 994 | nonzeros:=1 995 | when '0' then 996 | if nonzeros then 997 | ++trailingzeros 998 | u++^:=s++^ 999 | else 1000 | ++leadingzeros 1001 | if dpseen then 1002 | ++zerosafterdp 1003 | fi 1004 | ++s 1005 | fi 1006 | when '_', '\'', '`', ' ',13,10 then 1007 | ++s 1008 | when '.' then 1009 | if dpseen or dpindex>=0 then return badnumber() fi 1010 | if nonzeros then 1011 | dpindex:=u-t 1012 | else 1013 | dpseen:=1 1014 | fi 1015 | ! trailingzeros:=0 1016 | ++s 1017 | when 0 then 1018 | exit 1019 | when 'e','E' then 1020 | expon:=readexpon(s+1) 1021 | exit 1022 | else 1023 | return badnumber() 1024 | end doswitch 1025 | 1026 | u^:=0 1027 | length:=u-t !new length of extracted digits 1028 | if dpindex<0 then 1029 | if dpseen then 1030 | dpindex:=-zerosafterdp 1031 | else 1032 | dpindex:=length 1033 | fi 1034 | fi 1035 | length-:=trailingzeros !adjust precision to ignore trailing zeros 1036 | (t+length)^:=0 1037 | 1038 | if length=0 then 1039 | return bn_makeint(0) 1040 | fi 1041 | 1042 | d:=dpindex-1+expon 1043 | n:=length 1044 | dp:=0 1045 | na:=1 1046 | nb:=n-na 1047 | 1048 | w:=digitwidth 1049 | 1050 | if d>=0 then 1051 | wd:=d/w 1052 | wdp:=d rem w 1053 | else 1054 | d2:=abs(d+1) 1055 | wd:=-(d2/w+1) 1056 | wdp:=w-1-(d2 rem w) 1057 | fi 1058 | 1059 | na:=wdp+1 1060 | nb:=max(n-na,0) 1061 | while nb rem w do ++nb od 1062 | length:=nb/w+1 1063 | u:=t+n 1064 | to na+nb-n do 1065 | u++^:='0' 1066 | od 1067 | n:=na+nb 1068 | (t+n)^:=0 1069 | 1070 | a:=makebignum(length) 1071 | a.neg:=neg 1072 | a.expon:=wd 1073 | u:=t 1074 | a.num[0]:=strvaln(u,na) 1075 | u+:=na 1076 | 1077 | for i:=1 to length-1 do 1078 | a.num[i]:=strvaln(u,w) 1079 | u+:=w 1080 | od 1081 | 1082 | freemem(t,talloc) 1083 | 1084 | return a 1085 | end 1086 | 1087 | proc bn_fdivu(bignum dest,a,b,int precision)= 1088 | !neither a nor b are zero; both are positive 1089 | !integer divide 1090 | 1091 | ref elemtype c,x,e 1092 | int expona, exponb, badjust, exponc 1093 | int na,nb,nc,nx,ne,nx2,ne2, cx,nupper,nc2 1094 | int uppera, upperb, upperc 1095 | int n, k, nexta 1096 | int64 xx,y 1097 | ref elemtype pa,pb 1098 | 1099 | na:=a.length 1100 | nb:=b.length 1101 | expona:=a.expon 1102 | exponb:=b.expon 1103 | 1104 | if precision then 1105 | precision:=((precision-1)/digitwidth+1) !must be multiple of digitwidth 1106 | else 1107 | precision:=currprec 1108 | fi 1109 | nc:=precision 1110 | 1111 | uppera:=na-1 1112 | upperb:=nb-1 1113 | upperc:=nc-1 1114 | pa:=cast(a.num) 1115 | pb:=cast(b.num) !p is not zero, and all digits of interest are present 1116 | 1117 | !x is the moving and changing window into a that b is divided into get next digit of result 1118 | !use a permanently allocated smallnum, 1 digit wider than b 1119 | n:=nb !n is also how many digits of a we're into so far 1120 | x:=makesmallnum(nx2:=n+1) !allow one extra digit 1121 | nx:=n !current x size 1122 | 1123 | for i:=0 to upperb do 1124 | if i<=uppera then 1125 | (x+i)^:=(pa+i)^ 1126 | else 1127 | (x+i)^:=0 1128 | fi 1129 | od 1130 | 1131 | c:=makesmallnum(nc2:=nc+1) 1132 | cx:=0 1133 | 1134 | do 1135 | k:=smalldiv(x,pb,nx,nb) 1136 | 1137 | (c+cx++)^:=k 1138 | 1139 | if cx>nc then !reached given precision 1140 | exit 1141 | fi 1142 | 1143 | nexta:=(n>uppera|0|(pa+n)^) 1144 | ++n 1145 | if nx=1 and x^=0 then 1146 | x^:=nexta !x is 1 digit long 1147 | else 1148 | (x+nx)^:=nexta !next digit from a 1149 | ++nx 1150 | fi 1151 | od 1152 | 1153 | freesmall(x,nx2) 1154 | 1155 | if cx=1 and c^=0 then 1156 | freesmall(c,nc2) 1157 | bn_setzero(dest) 1158 | return 1159 | fi 1160 | 1161 | if c^=0 and cx>=2 then !leading zero (may not need cx check) 1162 | smalltobig(dest,c+1,cx-1,nc2,-1) 1163 | dest.expon:=expona-exponb-1 1164 | else 1165 | smalltobig(dest,c,cx,nc2) 1166 | dest.expon:=expona-exponb 1167 | fi 1168 | ! freesmall(c,nc2) 1169 | end 1170 | 1171 | func tostring_float(bignum a,int fmt)ichar= 1172 | !a is an actual number (not zero, infinity etc) 1173 | int expon,upper,nchars,w,prel,n,showdot 1174 | ichar s,t 1175 | 1176 | expon:=a.expon 1177 | upper:=a.length-1 1178 | 1179 | if fmt='I' and bn_isint(a) then 1180 | showdot:=0 1181 | else 1182 | showdot:=1 1183 | fi 1184 | 1185 | w:=digitwidth 1186 | nchars:=3 !sign and trailing .0 1187 | if expon<0 then 1188 | nchars+:=abs(expon-1)*w 1189 | fi 1190 | nchars+:=a.length*w 1191 | if expon-upper>0 then 1192 | nchars+:=(expon-upper)*w 1193 | fi 1194 | nchars+:=8 !margin 1195 | 1196 | ! s:=t:=bn_alloc(nchars) 1197 | s:=t:=checkedmalloc(nchars) 1198 | 1199 | if a.neg then 1200 | t++^:='-' 1201 | fi 1202 | 1203 | prel:=0 1204 | if expon<0 then 1205 | prel:=1 1206 | t++^:='0' 1207 | t++^:='.' 1208 | to abs(expon)-1 do 1209 | to digitwidth do 1210 | t++^:='0' 1211 | od 1212 | od 1213 | fi 1214 | 1215 | for i:=0 to upper do 1216 | ! t++^:='*' 1217 | n:=sprintf(t,(i>0 or prel|digitfmt|"%d"),a.num[i]) 1218 | t+:=n 1219 | ! print a.num[i] 1220 | if expon=i and i=upper and showdot then 1232 | t++^:='.' 1233 | t++^:='0' 1234 | fi 1235 | 1236 | t^:=0 1237 | return s 1238 | end 1239 | 1240 | export func bn_tostring(bignum a,int fmt=0)ichar= 1241 | int expon,upper 1242 | ichar s,t 1243 | 1244 | t:=nil 1245 | if a=nil then 1246 | t:="" 1247 | else 1248 | case a.numtype 1249 | when zero_type then t:=(fmt='E' or fmt='F'|"0.0"|"0") 1250 | when inf_type then t:="" 1251 | when nan_type then t:="" 1252 | esac 1253 | fi 1254 | 1255 | if t then 1256 | s:=checkedmalloc(strlen(t)+1) 1257 | strcpy(s,t) 1258 | return s 1259 | fi 1260 | 1261 | if fmt=0 or fmt='A' then 1262 | if bn_isint(a) and (a.expon-a.length)*digitwidth<60 then 1263 | fmt:='I' 1264 | elsif abs(a.expon*digitwidth)<60 then 1265 | fmt:='F' 1266 | else 1267 | fmt:='E' 1268 | fi 1269 | fi 1270 | 1271 | if fmt='E' then 1272 | s:=tostring_scient(a) 1273 | else 1274 | s:=tostring_float(a,fmt) 1275 | fi 1276 | return s 1277 | end 1278 | 1279 | func tostring_scient(bignum a)ichar= 1280 | !a is an actual number 1281 | ichar s,t 1282 | int expon,nchars,n,shift 1283 | int64 x,scale 1284 | 1285 | nchars:=3 1286 | 1287 | expon:=a.expon*digitwidth 1288 | 1289 | x:=a.num[0] 1290 | scale:=1 1291 | shift:=0 1292 | while x>=10 do 1293 | x:=x/10 1294 | scale*:=10 1295 | ++expon 1296 | ++shift 1297 | od 1298 | 1299 | nchars:=a.length*digitwidth+16 !allow for 1., and exponent 1300 | 1301 | s:=t:=checkedmalloc(nchars) 1302 | 1303 | if a.neg then 1304 | t++^:='-' 1305 | fi 1306 | 1307 | ! n:=sprintf(t,"%d.",x) 1308 | print @t,x,,"." 1309 | t+:=strlen(t) 1310 | 1311 | if shift then 1312 | ! n:=sprintf(t,"%0*d", shift, a.num[0]-x*scale) 1313 | print @t, shift:"v",,a.num[0]-x*scale:"z*" 1314 | t+:=strlen(t) 1315 | fi 1316 | 1317 | for i to a.length-1 do 1318 | ! n:=sprintf(t,digitfmt, a.num[i]) 1319 | ! fprint @t,digitfmt, a.num[i] 1320 | print @t,a.num[i]:mdigitfmt 1321 | t+:=strlen(t) 1322 | od 1323 | 1324 | while (t-1)^='0' and (t-2)^<>'.' do 1325 | --t 1326 | od 1327 | 1328 | ! n:=sprintf(t,"e%d", expon) 1329 | print @t,"e",,expon 1330 | t+:=strlen(t) 1331 | t^:=0 1332 | 1333 | return s 1334 | end 1335 | 1336 | export func bn_add(bignum dest,a,b)int= 1337 | int nega,negb 1338 | 1339 | switch getbintype(a,b) 1340 | when nn_types then 1341 | when zz_types then 1342 | bn_setzero(dest) 1343 | return 1 1344 | when nz_types then 1345 | bn_dupl(dest,a) 1346 | return 1 1347 | when zn_types then 1348 | bn_dupl(dest,b) 1349 | return 1 1350 | else 1351 | bn_setnan(dest) 1352 | return 0 1353 | end switch 1354 | 1355 | nega:=a.neg 1356 | negb:=b.neg 1357 | 1358 | if not nega and not negb then !both positive 1359 | bn_addu(dest,a,b) 1360 | elsif nega and negb then !both negative 1361 | bn_addu(dest,a,b) 1362 | bn_negto(dest) 1363 | elsif not nega and negb then !a positive, b negative 1364 | bn_subu(dest,a,b) 1365 | else 1366 | bn_subu(dest,b,a) !a negative, b positive 1367 | fi 1368 | 1369 | return 1 1370 | end 1371 | 1372 | export func bn_sub(bignum dest,a,b)int= 1373 | int nega,negb 1374 | 1375 | switch getbintype(a,b) 1376 | when nn_types then 1377 | when zz_types then 1378 | bn_setzero(dest) 1379 | return 1 1380 | when nz_types then 1381 | bn_dupl(dest,a) 1382 | return 1 1383 | when zn_types then 1384 | bn_dupl(dest,b) 1385 | bn_negto(dest) 1386 | return 1 1387 | else 1388 | bn_setnan(dest) 1389 | return 0 1390 | end switch 1391 | 1392 | nega:=a.neg 1393 | negb:=b.neg 1394 | 1395 | if not nega and not negb then !both positive 1396 | bn_subu(dest,a,b) 1397 | elsif nega and negb then !both negative 1398 | bn_subu(dest,b,a) 1399 | elsif not nega and negb then !a positive, b negative 1400 | bn_addu(dest,a,b) 1401 | else !a negative, b positive 1402 | bn_subu(dest,b,a) 1403 | fi 1404 | 1405 | return 1 1406 | end 1407 | 1408 | export func bn_mul(bignum dest,a,b)int= 1409 | int neg 1410 | 1411 | switch getbintype(a,b) 1412 | when nn_types then 1413 | when zz_types,nz_types,zn_types then 1414 | bn_setzero(dest) 1415 | return 1 1416 | else 1417 | bn_setnan(dest) 1418 | return 0 1419 | end switch 1420 | 1421 | neg:=a.neg<>b.neg 1422 | bn_mulu(dest,a,b) 1423 | if neg then !different signs 1424 | bn_negto(dest) 1425 | fi 1426 | return 1 1427 | end 1428 | 1429 | export func bn_mulp(bignum dest,a,b, int prec)int= 1430 | int res:=bn_mul(dest,a,b) 1431 | if res then 1432 | bn_setprec(dest,(prec=0|currprec|prec)) 1433 | fi 1434 | return res 1435 | end 1436 | 1437 | export func bn_div(bignum dest,a,b,int prec=0)int= 1438 | int neg 1439 | 1440 | switch getbintype(a,b) 1441 | when nn_types then 1442 | when zn_types then 1443 | bn_setzero(dest) 1444 | return 1 1445 | when zz_types,nz_types then 1446 | bn_setinf(dest) 1447 | return 0 1448 | else 1449 | bn_setnan(dest) 1450 | return 0 1451 | end switch 1452 | 1453 | neg:=a.neg<>b.neg 1454 | 1455 | bn_fdivu(dest,a,b,prec) 1456 | ! bn_idivu(dest,a,b) 1457 | 1458 | if neg then 1459 | bn_negto(dest) 1460 | fi 1461 | return 1 1462 | end 1463 | 1464 | export func bn_idiv(bignum dest,a,b)int= 1465 | int neg 1466 | switch getbintype(a,b) 1467 | when nn_types then 1468 | when zn_types then 1469 | bn_setzero(dest) 1470 | return 1 1471 | when zz_types,nz_types then 1472 | bn_setinf(dest) 1473 | return 0 1474 | else 1475 | bn_setnan(dest) 1476 | return 0 1477 | end switch 1478 | 1479 | neg:=a.neg<>b.neg 1480 | bn_idivu(dest,a,b) 1481 | if neg then 1482 | bn_negto(dest) 1483 | fi 1484 | return 1 1485 | end 1486 | 1487 | export func bn_idivrem(bignum dest,rm,a,b)int= 1488 | int nega,negb 1489 | 1490 | switch getbintype(a,b) 1491 | when nn_types then 1492 | when zn_types then 1493 | bn_setzero(dest) 1494 | bn_setzero(rm) 1495 | return 1 1496 | when zz_types,nz_types then 1497 | bn_setinf(dest) 1498 | bn_setzero(rm) 1499 | return 0 1500 | else 1501 | bn_setnan(dest) 1502 | return 0 1503 | end switch 1504 | 1505 | nega:=a.neg 1506 | negb:=b.neg 1507 | bn_idivu(dest,a,b,rm) 1508 | if nega<>negb then !different signs 1509 | bn_negto(dest) 1510 | fi 1511 | if nega then bn_negto(rm) fi 1512 | return 1 1513 | end 1514 | 1515 | export func bn_irem(bignum dest,a,b)int= 1516 | bignum rm,d 1517 | int nega 1518 | 1519 | switch getbintype(a,b) 1520 | when nn_types then 1521 | when zn_types then 1522 | bn_dupl(dest,b) 1523 | return 1 1524 | when zz_types,nz_types then 1525 | bn_setinf(dest) 1526 | bn_setzero(dest) 1527 | return 0 1528 | else 1529 | bn_setnan(dest) 1530 | return 0 1531 | end switch 1532 | 1533 | nega:=a.neg 1534 | d:=bn_init() 1535 | bn_idivu(d,a,b,dest) 1536 | if nega then bn_negto(dest) fi 1537 | bn_free(d) 1538 | return 1 1539 | end 1540 | 1541 | export func bn_cmp(bignum a,b)int= 1542 | bignum d 1543 | int neg 1544 | 1545 | if bn_equal(a,b) then 1546 | return 0 1547 | fi 1548 | 1549 | d:=bn_init() 1550 | bn_sub(d,a,b) 1551 | neg:=d.neg 1552 | bn_free(d) 1553 | return (neg|-1|1) 1554 | end 1555 | 1556 | export func bn_const(int value)bignum = 1557 | ref constrec p 1558 | bignum c 1559 | 1560 | p:=constlist 1561 | 1562 | while p do 1563 | if p.value=value then 1564 | return p.bnvalue 1565 | fi 1566 | p:=p.nextconst 1567 | od 1568 | 1569 | !not encountered before 1570 | p:=bn_alloc(constrec.bytes) 1571 | p.bnvalue:=bn_makeint(value) 1572 | p.value:=value 1573 | p.nextconst:=constlist 1574 | constlist:=p 1575 | return p.bnvalue 1576 | end 1577 | 1578 | export func bn_sign(bignum a)int= 1579 | if bn_iszero(a) then 1580 | return 0 1581 | elsif a.neg then 1582 | return -1 1583 | else 1584 | return 0 1585 | fi 1586 | end 1587 | 1588 | func badnumber:bignum= 1589 | bignum c 1590 | c:=makebignum(0) 1591 | c.numtype:=nan_type 1592 | return c 1593 | end 1594 | 1595 | export func bn_digits(bignum a)int= 1596 | !return number of digits in integer a 1597 | int n 1598 | [32]char str 1599 | 1600 | if not bn_isint(a) then 1601 | return 0 1602 | fi 1603 | if bn_iszero(a) then 1604 | return 1 1605 | fi 1606 | 1607 | n:=sprintf(&.str,"%d",a.num[0]) 1608 | return n+a.expon*digitwidth 1609 | end 1610 | 1611 | export func bn_toint(bignum a)int64= 1612 | int64 x 1613 | if not bn_isint(a) then 1614 | return 0 1615 | fi 1616 | if bn_iszero(a) then 1617 | return 0 1618 | fi 1619 | 1620 | x:=0 1621 | for i:=0 to a.length-1 do 1622 | x:=x*digitbase+a.num[i] 1623 | od 1624 | 1625 | if a.neg then 1626 | return -x 1627 | else 1628 | return x 1629 | fi 1630 | end 1631 | 1632 | export func bn_tofloat(bignum a)real64= 1633 | real64 x 1634 | ichar s 1635 | 1636 | if bn_iszero(a) then 1637 | return 0.0 1638 | fi 1639 | 1640 | s:=bn_tostring(a,'E') 1641 | 1642 | sscanf(s,"%lf", &x) 1643 | return x 1644 | end 1645 | 1646 | export proc bn_fix(bignum c, a) = 1647 | if bn_iszero(a) or a.expon<0 then 1648 | bn_setzero(c) 1649 | return 1650 | fi 1651 | 1652 | bn_dupl(c,a) 1653 | if not bn_isint(c) then 1654 | bn_setprec(c,(c.expon+1)*digitwidth) 1655 | fi 1656 | end 1657 | -------------------------------------------------------------------------------- /MExamples/jpeg.m: -------------------------------------------------------------------------------- 1 | !simple jpeg decoder for colour images 2 | !supports 2x2, 2x1, 1x1 sub-sampling 3 | !Some algorithms derived from the C code in the book: 4 | ! 'Basic Algorithms' by Malcolm McLean 5 | 6 | const jpegerror=10 7 | int debug=0 8 | 9 | record stream = 10 | ref byte ptr 11 | ref byte ptrend 12 | ref byte ptrstart 13 | ref byte data 14 | 15 | int currbyte 16 | int currbit !usually 0x80,0x40..0, bit which has just been read 17 | end 18 | 19 | record huffnode = 20 | ref huffnode child0, child1 21 | int symbol 22 | int suppbits 23 | end 24 | 25 | record jpeginforec = 26 | int width,height !pixel size 27 | int ncomponents !1..4 components (eg r,g,b) 28 | int framebytes !width*height*framebytes 29 | [4,64]int qtable ![1..4,1..64] quantisation table 30 | [4]int comptype ![1..4]int 1=Y, 2=Cb, 3=Cr, 4=I, 5=Q 31 | [4]int vsample, hsample ![1..4]int sampling rate 32 | [4]int usedc ![1..4]int dc huffman index 33 | [4]int useac ![1..4]int ac huffman index 34 | [4]int useq ![1..4]int qtable index 35 | [4]ref huffnode dctable ![1..4]table 36 | [4]ref huffnode actable ![1..4]table 37 | int dri 38 | end 39 | 40 | jpeginforec hdr 41 | 42 | proc main= 43 | ref byte data 44 | ichar file 45 | int64 width,height 46 | 47 | if nsysparams>=2 then 48 | file:=sysparams[2] 49 | else 50 | println "Usage:",sysparams[1],"" 51 | stop 52 | fi 53 | 54 | data:=loadjpeg(file,&width,&height) 55 | 56 | if data=nil then 57 | println "Couldn't load",file 58 | stop 59 | fi 60 | 61 | println "Image data:",data 62 | println =width,=height 63 | 64 | writeppm(file, data, width, height) 65 | 66 | end 67 | 68 | proc writeppm(ichar file,ref byte data,int width,height)= 69 | filehandle f 70 | ref byte p, q 71 | int linebytes 72 | 73 | f:=fopen(file:=changeext(file,"ppm"),"wb") 74 | if not f then return fi 75 | 76 | println "Writing",file 77 | 78 | print @f,"P6",,chr(10) 79 | print @f,width,height,,chr(10) 80 | print @f,255,,chr(10) 81 | 82 | q:=data 83 | linebytes:=width*3 84 | 85 | to height do 86 | p:=q !convert to bgr 87 | to width do 88 | swap(p^,(p+2)^) 89 | p:=p+3 90 | od 91 | 92 | q+:=linebytes 93 | od 94 | 95 | writerandom(f,data,getfilepos(f),width*height*3) 96 | fclose(f) 97 | end 98 | 99 | global function loadjpeg(ichar file, ref int64 width, height)ref byte = 100 | !Load jpeg file into a memory buffer 101 | !return a pointer to the image 102 | !width/height info is returned via references in the parameter list 103 | ref byte p 104 | 105 | width^:=height^:=-1 106 | 107 | p:=loadjpegfile(file) 108 | 109 | width^:=hdr.width 110 | height^:=hdr.height 111 | 112 | return p 113 | end 114 | 115 | !global callback function "DllMain"(int hinst,int reason, reserved)int= 116 | !!println "Jpeg decode 3",hinst, reason 117 | ! return 1 118 | !end 119 | 120 | global proc freejpeg(ref byte p)= 121 | free(p) 122 | end 123 | 124 | proc initdata= 125 | pcm_init() 126 | memset(&hdr,0,jpeginforec.bytes) 127 | end 128 | 129 | proc showtree(ref huffnode tree,int level=0)= 130 | static int seq=0 131 | 132 | if tree=nil then return fi 133 | print ++seq 134 | to level do 135 | print " " 136 | od 137 | println tree^.symbol,tree^.suppbits 138 | showtree(tree^.child0,level+1) 139 | showtree(tree^.child1,level+1) 140 | end 141 | 142 | proc initbitstream(ref stream fs)= 143 | fs^.currbyte:=0 144 | fs^.currbit:=1 !force new byte read on next nextbit 145 | end 146 | 147 | function nextbit(ref stream fs)int= 148 | 149 | if fs^.currbit=1 then 150 | fs^.currbyte:=nextdatabyte(fs) 151 | fs^.currbit:=0x100 !pick up .[7] below 152 | fi 153 | 154 | fs^.currbit>>:=1 155 | return (fs^.currbyte iand fs^.currbit|1|0) 156 | end 157 | 158 | function nextdatabyte(ref stream fs)int= 159 | int c 160 | do 161 | if (c:=nextbyte(fs))<>0xFF then 162 | return c 163 | fi 164 | repeat 165 | c:=nextbyte(fs) 166 | until c<>0xFF 167 | if c=0 then return 0xFF fi 168 | od 169 | return 0 170 | end 171 | 172 | function getstream(ichar filename)ref stream= 173 | ref stream fs 174 | fs:=jalloc(stream.bytes) 175 | fs^.data:=readfile(filename) 176 | if fs^.data=nil then 177 | println "JPEGDLL:Can't open",filename 178 | return nil 179 | fi 180 | fs^.ptr:=fs^.data 181 | fs^.ptrend:=fs^.ptr+rfsize 182 | fs^.ptrstart:=fs^.ptr 183 | return fs 184 | end 185 | 186 | function nextbyte(ref stream fs)int= 187 | int c 188 | 189 | if fs^.ptr0 do 224 | t:=nextbyte(fs) 225 | tabno:=t iand 15 226 | tabtype:=(t>>4) iand 15 227 | 228 | !Read how many symbols of each length 229 | tot:=0 230 | for i:=1 to 16 do 231 | codeswithlength[i] :=nextbyte(fs) 232 | tot+:=codeswithlength[i] 233 | od 234 | 235 | for i:=1 to tot do 236 | symbol[i]:=nextbyte(fs) 237 | od 238 | 239 | tree:=buildhufftree(cast(&codeswithlength),cast(&symbol)) 240 | 241 | if tabtype=0 then 242 | hdr.dctable[tabno+1]:=tree 243 | else 244 | hdr.actable[tabno+1]:=tree 245 | fi 246 | 247 | length -:=(tot+16+1) 248 | od 249 | end 250 | 251 | function buildhufftree(ref[]int codelength,symbols)ref huffnode= 252 | ref[]huffnode nodes 253 | ref[]ichar codes 254 | int tot,i 255 | 256 | tot:=0 257 | for i:=1 to 16 do 258 | tot+:=codelength^[i] 259 | od 260 | 261 | nodes:=jallocz(huffnode.bytes*(tot*2-1)) 262 | 263 | codes:=buildcanonical(codelength) 264 | 265 | buildtreerec(cast(nodes),cast(&codes^[1]),cast(&symbols^[1]),tot,0) 266 | return cast(nodes) 267 | end 268 | 269 | proc buildtreerec(ref[]huffnode nodes,ref[]ref[]char code,ref[]int symbol, int n, bitx,level=0)= 270 | ref huffnode first 271 | int i,k 272 | 273 | if n=0 then 274 | return 275 | fi 276 | 277 | first:=&nodes^[1] 278 | 279 | if n=1 then 280 | first^.child0:=nil 281 | first^.child1:=nil 282 | first^.symbol:=symbol^[1] 283 | first^.suppbits:=0 284 | k:=strlen(cast(code^[1]))-bitx 285 | if k>0 then 286 | first^.suppbits:=k 287 | bitx+:=k 288 | fi 289 | return 290 | fi 291 | 292 | for i2:=1 to n do 293 | if code^[i2]^[bitx+1]='1' then 294 | i:=i2 295 | exit 296 | fi 297 | i:=i2 298 | od 299 | first^.child0:=&nodes^[2] 300 | first^.child1:=&nodes^[2*i-1] 301 | first^.symbol:=-1 302 | first^.suppbits:=0 303 | 304 | buildtreerec(cast(&nodes^[2]),code,symbol,i-1,bitx+1, level+1) 305 | buildtreerec(cast(&nodes^[2*i-1]),cast(&code^[i]),cast(&symbol^[i]),n-i+1,bitx+1,level+1) 306 | end 307 | 308 | function buildcanonical(ref[]int codelengths)ref[]ichar= 309 | int i,j,n,code,length 310 | ref[]ichar a 311 | 312 | n:=0 313 | for i:=1 to 16 do 314 | n+:=codelengths^[i] 315 | od 316 | 317 | a:=jallocz(n*ichar.bytes) 318 | 319 | j:=1 320 | code:=0 321 | length:=1 322 | for i:=1 to 16 do 323 | to codelengths^[i] do 324 | a^[j]:=pcm_copyheapstring(tostrbin(code,length)) 325 | ++j 326 | code++ 327 | od 328 | code <<:=1 329 | ++length 330 | od 331 | 332 | return a 333 | end 334 | 335 | function tostrbin(int a,length)ichar= 336 | !convert a to a binary string, right-justified in a field of n characters, with 337 | !leading zeros 338 | !return pointer to static buffer containing result 339 | static [65]char result 340 | 341 | result[length+1]:=0 342 | for i:=length downto 1 do 343 | result[i]:='0'+(a iand 1) 344 | a >>:=1 345 | od 346 | return &.result 347 | end 348 | 349 | proc read_dqt(ref stream fs)= 350 | int lq,i,pq,tq 351 | 352 | lq:=readword(fs)-2 353 | while lq>0 do 354 | tq:=nextbyte(fs) 355 | pq:=tq>>4 356 | tq iand:=15 357 | ++tq !make one-based 358 | --lq 359 | 360 | if pq=0 then 361 | for i:=1 to 64 do 362 | hdr.qtable[tq,i]:=nextbyte(fs) 363 | od 364 | else 365 | for i:=1 to 64 do 366 | hdr.qtable[tq,i]:=readword(fs) 367 | od 368 | fi 369 | lq-:=64 370 | od 371 | end 372 | 373 | proc read_sof(ref stream fs)= 374 | int precision,sampling 375 | 376 | readword(fs) 377 | precision:=nextbyte(fs) 378 | if precision<>8 then 379 | abortjpeg("PRECISION") 380 | fi 381 | 382 | hdr.height:=readword(fs) 383 | hdr.width:=readword(fs) 384 | hdr.ncomponents:=nextbyte(fs) 385 | hdr.framebytes:=hdr.width*hdr.height*hdr.ncomponents 386 | 387 | for i:=1 to hdr.ncomponents do 388 | hdr.comptype[i]:=nextbyte(fs) 389 | sampling:=nextbyte(fs) 390 | hdr.vsample[i]:=sampling iand 15 391 | hdr.hsample[i]:=sampling>>4 392 | hdr.useq[i]:=nextbyte(fs)+1 393 | od 394 | end 395 | 396 | proc read_sos(ref stream fs)= 397 | int length,ns,i,t 398 | 399 | length:=readword(fs)-2 400 | ns:=nextbyte(fs) 401 | if ns<>hdr.ncomponents then 402 | abortjpeg("NCOMPS<>NS") 403 | fi 404 | 405 | for i:=1 to ns do 406 | hdr.comptype[i]:=nextbyte(fs) 407 | t:=nextbyte(fs) 408 | hdr.usedc[i]:=t>>4+1 409 | hdr.useac[i]:=(t iand 15)+1 410 | od 411 | 412 | length -:=ns*2+1 413 | 414 | while length-- do 415 | nextbyte(fs) 416 | od 417 | end 418 | 419 | proc read_eoi(ref stream fs)= 420 | int c 421 | 422 | if nextbyte(fs)<>0xFF then 423 | abortjpeg("EOI FF") 424 | fi 425 | 426 | repeat 427 | c:=nextbyte(fs) 428 | until c<>0xFF 429 | 430 | if c<>0xD9 then 431 | abortjpeg("EOI D9") 432 | fi 433 | end 434 | 435 | proc readmarker(ref stream fs)= 436 | nextbyte(fs) 437 | nextbyte(fs) 438 | initbitstream(fs) 439 | end 440 | 441 | function loadjpegfile(ichar file)ref byte= 442 | !returns pointer to memory block, or 0 if file couldn't be opened. 443 | !info about the image is in the hdr global 444 | !read/data errors in the file generate a 'jpegerror' exception 445 | ref stream fs 446 | ref byte pimage 447 | int c,offset 448 | 449 | initdata() 450 | pimage:=nil 451 | 452 | fs:=getstream(file) 453 | if not fs then 454 | return nil 455 | fi 456 | 457 | do 458 | c:=nextbyte(fs) 459 | if c=0xFF then !marker 460 | c:=nextbyte(fs) 461 | switch c 462 | when 0xD8 then 463 | ! println offset,"FFD8 SOI" 464 | when 0xE0 then 465 | ! println offset,"FFE0 APP0" 466 | when 0xE1..0xED,0xEF then 467 | ! println offset,"FFEx APPx" 468 | readapp(fs,c-0xE0) 469 | when 0xC0 then 470 | ! println offset,"FFC0 SOF0 baseline" 471 | read_sof(fs) 472 | when 0xC2 then 473 | ! println offset,"FFC2 SOF2 progressive" 474 | when 0xC4 then 475 | ! println offset,"FFC4 DHT" 476 | read_dht(fs) 477 | when 0xDB then 478 | ! println offset,"FFDB DQT" 479 | read_dqt(fs) 480 | when 0xDD then 481 | ! println offset,"FFDD DRI RST interval" 482 | readword(fs) !skip length 483 | hdr.dri:=readword(fs) 484 | when 0xEE then 485 | ! println offset,"FFEE COM comment" 486 | when 0xDA then 487 | ! println offset,"FFDA SOS" 488 | read_sos(fs) 489 | pimage:=loadscan(fs) 490 | exit 491 | when 0xD9 then 492 | ! println offset,"FFD9 EOI" 493 | when 0x0 then 494 | ! println offset,"FF00 " 495 | when 0xFF then 496 | ! println offset,"FFFF padding" 497 | else 498 | ! println offset,"FF",,c:"2zh","Unknown marker" 499 | end 500 | ! else 501 | fi 502 | od 503 | return pimage 504 | end 505 | 506 | function loadscan(ref stream fs)ref byte= 507 | !Read image data following sos, from filestream handle fs, 508 | !and using image params in hdr 509 | !return a memory pointer to the image data 510 | ref byte pimage 511 | 512 | initbitstream(fs) 513 | 514 | pimage:=nil 515 | case hdr.ncomponents 516 | when 1 then 517 | abortjpeg("loadmono") 518 | when 3 then 519 | if hdr.comptype[1]<>1 or hdr.comptype[2]<>2 or hdr.comptype[3]<>3 then 520 | abortjpeg("comptype?") 521 | fi 522 | if hdr.hsample[2]=hdr.vsample[2]=hdr.hsample[3]=hdr.vsample[3] and \ 523 | (hdr.hsample[1]<=2 and hdr.vsample[1]<=2) then 524 | pimage:=loadcolour(fs,hdr.hsample[1],hdr.vsample[1]) 525 | else 526 | println hdr.hsample[1],hdr.vsample[1],hdr.hsample[2],hdr.vsample[2],hdr.hsample[3],hdr.vsample[3] 527 | abortjpeg("LOAD COLOUR/Unknown sampling") 528 | fi 529 | else 530 | abortjpeg("ncomp") 531 | esac 532 | 533 | return pimage 534 | end 535 | 536 | function tree_getsymbol(ref stream fs,ref huffnode node)int= 537 | 538 | while node^.child0 do 539 | if nextbit(fs) then 540 | node := node^.child1 541 | else 542 | node := node^.child0 543 | fi 544 | od 545 | 546 | to node^.suppbits do 547 | nextbit(fs) 548 | od 549 | 550 | return node^.symbol 551 | end 552 | 553 | function getsymbol(ref stream fs,int nbits)int= 554 | int a,b 555 | 556 | if nbits = 0 then 557 | return 0 558 | fi 559 | 560 | a := 0 561 | to nbits do 562 | a <<:= 1 563 | b:=nextbit(fs) 564 | a ior:= b 565 | od 566 | if a iand (1 << (nbits-1)) = 0 then 567 | a -:= (1 << nbits ) -1 568 | fi 569 | 570 | return a 571 | end 572 | 573 | proc unzigzag(ref[64]int block)= 574 | static []int zigzag=( 575 | 1,2,6,7,15,16,28,29, 576 | 3,5,8,14,17,27,30,43, 577 | 4,9,13,18,26,31,42,44, 578 | 10,12,19,25,32,41,45,54, 579 | 11,20,24,33,40,46,53,55, 580 | 21,23,34,39,47,52,56,61, 581 | 22,35,38,48,51,57,60,62, 582 | 36,37,49,50,58,59,63,64) 583 | [64]int temp 584 | 585 | temp:=block^ 586 | 587 | for i:=1 to 64 do 588 | block^[i]:=temp[zigzag[i]] 589 | od 590 | end 591 | 592 | proc idct8x8(ref[]int block)= 593 | int j 594 | for i:=0 to 7 do 595 | j:=i*8+1 596 | fastidct8( 597 | block^[j], 598 | block^[j+1], 599 | block^[j+2], 600 | block^[j+3], 601 | block^[j+4], 602 | block^[j+5], 603 | block^[j+6], 604 | block^[j+7]) 605 | od 606 | 607 | for i:=1 to 64 do 608 | block^[i] >>:= 3 609 | od 610 | 611 | for i:=1 to 8 do 612 | fastidct8( 613 | block^[i], 614 | block^[i+8], 615 | block^[i+16], 616 | block^[i+24], 617 | block^[i+32], 618 | block^[i+40], 619 | block^[i+48], 620 | block^[i+56]) 621 | od 622 | end 623 | 624 | proc fastidct8(int &a1,&a2,&a3,&a4,&a5,&a6,&a7,&a8) = ! FASTIDCT8X8 625 | const w1 = 2841 626 | const w2 = 2676 627 | const w3 = 2408 628 | const w5 = 1609 629 | const w6 = 1108 630 | const w7 = 565 631 | int x1,x2,x3,x4,x5,x6,x7,x8,x9 632 | 633 | if (not ((x2 := a5 << 11) ior \ 634 | (x3 := a7) ior \ 635 | (x4 := a3) ior \ 636 | (x5 := a2) ior \ 637 | (x6 := a8) ior \ 638 | (x7 := a6) ior \ 639 | (x8 := a4))) then 640 | a1:=a2:=a3:=a4:=a5:=a6:=a7:=a8:=a1<<3 641 | return 642 | fi 643 | x1 := (a1 << 11) + 128 644 | 645 | x9 := w7 * (x5 + x6) 646 | x5 := x9 + (w1 - w7) * x5 647 | x6 := x9 - (w1 + w7) * x6 648 | x9 := w3 * (x7 + x8) 649 | x7 := x9 - (w3 - w5) * x7 650 | x8 := x9 - (w3 + w5) * x8 651 | 652 | x9 := x1 + x2 653 | x1 -:= x2 654 | x2 := w6 * (x4 + x3) 655 | x3 := x2 - (w2 + w6) * x3 656 | x4 := x2 + (w2 - w6) * x4 657 | x2 := x5 + x7 658 | x5 -:= x7 659 | x7 := x6 + x8 660 | x6 -:= x8 661 | 662 | x8 := x9 + x4 663 | x9 -:= x4 664 | x4 := x1 + x3 665 | x1 -:= x3 666 | x3 := (181 * (x5 + x6) + 128) >> 8 667 | x5 := (181 * (x5 - x6) + 128) >> 8 668 | 669 | a1 := (x8 + x2) >> 8 670 | a2 := (x4 + x3) >> 8 671 | a3 := (x1 + x5) >> 8 672 | a4 := (x9 + x7) >> 8 673 | a5 := (x9 - x7) >> 8 674 | a6 := (x1 - x5) >> 8 675 | a7 := (x4 - x3) >> 8 676 | a8 := (x8 - x2) >> 8 677 | end 678 | 679 | proc getblock(ref stream fs,ref huffnode dctree,actree,ref[]int block)= 680 | int nbits,nread,bb,zeroes 681 | 682 | nbits := tree_getsymbol(fs,dctree) 683 | nread:=0 684 | 685 | ++nread 686 | memset(block,0,64*int.bytes) 687 | 688 | block^[nread] := getsymbol(fs, nbits) 689 | !println =block^[1] 690 | 691 | repeat 692 | bb := tree_getsymbol(fs,actree) 693 | 694 | if bb = 0xF0 then 695 | ! if (nread + 16 > 64) then 696 | if (nread > 48) then 697 | abortjpeg("GETB1") 698 | fi 699 | nread+:=16 700 | fi 701 | 702 | zeroes := bb >> 4 703 | nbits := bb iand 15 704 | 705 | if nbits then 706 | if (nread + zeroes > 63) then 707 | abortjpeg("nzeroes") 708 | fi 709 | nread+:=zeroes 710 | ++nread 711 | block^[nread] := getsymbol(fs, nbits) 712 | if (nread = 64) then 713 | return 714 | fi 715 | fi 716 | until not bb 717 | end 718 | 719 | proc readblock(ref stream fs,ref[]int block, ref huffnode dctable,actable, 720 | ref[]int qtable, ref int dc)= 721 | int u 722 | 723 | getblock(fs,dctable, actable,block) 724 | block^[1]:=block^[1]+dc^ 725 | 726 | dc^:=block^[1] 727 | u:=hdr.useq[2] 728 | 729 | for k:=1 to 64 do 730 | block^[k]*:=qtable^[k] 731 | od 732 | 733 | unzigzag(block) 734 | idct8x8(block) 735 | end 736 | 737 | function loadcolour(ref stream fs,int hoz,vert)ref byte= 738 | !read yuv colour image data 739 | !hoz/vert will be: 740 | ! 2 2 2x2 lum sampling compared with chroma 741 | ! 2 1 2x1 lum sampling compared with chroma 742 | ! 1 1 1x1 lum sampling compared with chroma 743 | !return pointer to memory block containing image, or nil 744 | int x,y,nlum,u,k,count,i,j 745 | int diffdc,dcr,dcb 746 | ref byte data 747 | ref huffnode dctable_lum, actable_lum 748 | ref huffnode dctable_cb, actable_cb 749 | ref huffnode dctable_cr, actable_cr 750 | ref[]int qtable_lum, qtable_cb,qtable_cr 751 | 752 | [64]int cr,cb 753 | [4,64]int lum 754 | 755 | !println "READ COLOUR",hoz,vert 756 | 757 | !data:=jalloc(hdr.framebytes) 758 | data:=jallocz(hdr.framebytes) 759 | 760 | diffdc:=dcb:=dcr:=0 761 | nlum:=hoz*vert !number of lum blocks compared with cb or cr 762 | 763 | dctable_lum := hdr.dctable[hdr.usedc[1]] 764 | actable_lum := hdr.actable[hdr.useac[1]] 765 | qtable_lum := &hdr.qtable[hdr.useq[1]] 766 | 767 | dctable_cb := hdr.dctable[hdr.usedc[2]] 768 | actable_cb := hdr.actable[hdr.useac[2]] 769 | qtable_cb := &hdr.qtable[hdr.useq[2]] 770 | 771 | dctable_cr := hdr.dctable[hdr.usedc[3]] 772 | actable_cr := hdr.actable[hdr.useac[3]] 773 | qtable_cr := &hdr.qtable[hdr.useq[3]] 774 | 775 | count:=0 776 | y:=0 777 | 778 | while y0 then 782 | readmarker(fs) 783 | diffdc:=0 784 | dcb:=dcr:=0 785 | fi 786 | 787 | for j:=1 to nlum do 788 | readblock(fs,&lum[j],dctable_lum, actable_lum, qtable_lum, &diffdc) 789 | od 790 | 791 | readblock(fs,&cb,dctable_cb, actable_cb, qtable_cb, &dcb) 792 | readblock(fs,&cr,dctable_cr, actable_cr, qtable_cr, &dcr) 793 | 794 | reconsblockcolour(&lum[1],&lum[2],&lum[3],&lum[4],&cr,&cb,data,x,y, hoz,vert) 795 | ++count 796 | x+:=hoz*8 797 | od 798 | y+:=vert*8 799 | od 800 | 801 | read_eoi(fs) 802 | return data 803 | end 804 | 805 | proc reconsblockcolour(ref[]int lum1,lum2,lum3,lum4,cr,cb, ref byte data,int x,y, hoz,vert)= 806 | int width,height,ilim,jlim,i,j,yy,ix,rr,bb,luminance 807 | ref byte p 808 | int red,blue,green 809 | int a,b 810 | 811 | width:=hdr.width 812 | height:=hdr.height 813 | 814 | ilim:=vert*8-1 815 | jlim:=hoz*8-1 816 | 817 | for i:=0 to ilim do 818 | if (yy:=y+i)>=height then nextloop fi 819 | p:=data+(yy*width+x)*3 820 | 821 | for j:=0 to jlim do 822 | if x+j>=width then nextloop fi 823 | if i<8 then 824 | if j<8 then 825 | luminance := lum1^[i*8+j+1]/64+128 826 | else 827 | luminance := lum2^[i*8+j-8+1]/64+128 828 | fi 829 | else 830 | if j<8 then 831 | luminance := lum3^[(i-8)*8+j+1]/64+128 832 | else 833 | luminance := lum4^[(i-8)*8+j-8+1]/64+128 834 | fi 835 | fi 836 | 837 | ix:=i/vert*8+j>>1+1 838 | rr := cr^[ix] 839 | bb := cb^[ix] 840 | 841 | p^ := clamp((bb*57/2048)+luminance, 0,255) !blue 842 | ++p 843 | p^ := clamp(luminance - (bb*11 + rr*23)/2048, 0,255) !green 844 | ++p 845 | p^ := clamp(rr*45/2048+luminance, 0,255) !red 846 | ++p 847 | od 848 | od 849 | end 850 | 851 | function jalloc(int n)ref void= 852 | ref void p 853 | p:=malloc(n) 854 | if p=nil then 855 | println "JPEG MALLOC FAILS" 856 | stop 857 | fi 858 | return p 859 | end 860 | 861 | function jallocz(int n)ref void= 862 | ref void p 863 | p:=jalloc(n) 864 | memset(p,0,n) 865 | return p 866 | end 867 | 868 | proc abortjpeg(ichar mess)= 869 | println "Jpeg error:",mess 870 | stop 871 | end 872 | 873 | -------------------------------------------------------------------------------- /MExamples/readme.md: -------------------------------------------------------------------------------- 1 | Some M language examples. 2 | 3 | Files contain hard tabs that should be viewed as 4 spaces 4 | -------------------------------------------------------------------------------- /Modules24.md: -------------------------------------------------------------------------------- 1 | ## Modules 2024 2 | 3 | I created a new Modules scheme a couple of years ago. Based on my experience since, this has been simplified. 4 | 5 | This new version is in use in two languages, one lower-level systems language, one dynamic scripting language, both ahead-of-time compiled. Both are whole-program compilers. Although the comments mostly have the systems one in mind. 6 | 7 | There is quite a lot to explain, but in brief: **all the modules comprising a program are listed at the top of the lead module**; that's pretty much it! 8 | 9 | With this scheme, no separate build system is needed to turn a bunch of sources into an EXE or DLL file. 10 | 11 | ### What is a Module 12 | 13 | A 'module' in this scheme is always one source file. One module cannot be implemented across multiple source files. One source file cannot define multiple modules. Modules cannot contain other modules (those would be more like classes). 14 | 15 | The name of a module must be both a valid identifier in the language, and a valid filename. 16 | 17 | ### Example Project 18 | 19 | I will use an example program P consisting of 4 modules: P (the lead module), A, B and C. All information about the layout of project is given in the lead module. There are two ways do this: 20 | 21 | **(1)** P contains only the list of other modules (it doesn't include itself) and no other code. So it looks like this: 22 | ```` 23 | project = 24 | module A 25 | module B 26 | module C 27 | end 28 | ```` 29 | This is the pattern I use for most projects. This allows the lead module to be easily swapped with another, with a slightly different set of modules to provide an alternate configuration. 30 | 31 | (Putting the list inside a project = ... end block is a recent addition. I will update this document to use that. But it is optional.) 32 | 33 | **(2)** P can also contain code, although here you'd probably dispense with P completely, and put the module info at the start of A: 34 | ```` 35 | project = 36 | module B 37 | module C 38 | end 39 | .... the rest of module A .... 40 | ```` 41 | (Note that the application will now be called A, but of course you can name the modules P, B, C, or you can choose a name at compile-time.) 42 | 43 | There is no project info, no `module` or `import` statements, in any other module. Other module schemes tend to have rag-bag collections of `import` statements at the top of every module, which in my view is unnecessary micro-managing. 44 | 45 | ### The SubProgram 46 | 47 | Modules in my scheme are grouped into SubPrograms. Within that group, any entity exported by any module (using a `global` attribute), is visible to all modules in the group. No specific `import` is needed, so long as all modules are listed in the lead module. My example program contains one subprogram. 48 | 49 | No name-qualifier is needed either: to call a global function `F` defined in `B` from `A`, I can just write `F()`. I only need to write `B.F()` if, for example, `C` also exported a function `F`. 50 | 51 | So all modules in the subprogram group are on familiar terms with each other. There is no hierarchy. There can be cycles: A can import B that can import A. (There is an ordering however; see below.) 52 | 53 | ### Multiple SubPrograms 54 | 55 | Most of my current projects have one subprogram - one group of chummy modules (plus the standard library; see below). Programs can have several subprograms, but each should be a group of modules that could be compiled by themselves, either into an EXE file, or into DLL file (when there is no `main` entry point and the subprogram is a library). 56 | 57 | Suppose there is a 3-module library Q with modules Q, X, Y. Q might contain: 58 | ```` 59 | project = 60 | module X 61 | module Y 62 | end 63 | ```` 64 | To incorporate this into P, so that Q is statically compiled into the same EXE, P is defined like this: 65 | ```` 66 | project = 67 | module A 68 | module B 69 | module C 70 | import Q # read further modules from Q 71 | end 72 | ```` 73 | The resulting program compromises modules P, A, B, C, Q, X, Y, although P and Q contain only module info here. 74 | 75 | ### Visibility between SubPrograms 76 | 77 | Even global entities between the modules of Q, for example, are not visible from P, unless they are specifically exported from Q. This involves using an `export` attribute instead of `global`. (It is not possible to export without also making a name global in that subprogram.) 78 | 79 | So if X exports a function `G`, it can be called from module A using `G()`, you don't need to qualify the name unless there is again a clash. But if you do it will be written as `Q.G()` not `X.G()` or `Q.X.G()`; P knows nothing of the internal modules of Q. (It is not possible to export two different `G` functions from Q.) 80 | 81 | Here there is a hierarchy of dependencies; cycles between subprograms are not allowed. The first subprogram (P in my example) is at the top of the hierarchy. 82 | 83 | Q can't call exports of P, as it needs to work standalone. 84 | 85 | ### The Standard Library 86 | 87 | For my static language, this is a collection of 5 modules, listed in a 6th module called `msyslib`. This would normally require this line in each application: 88 | ```` 89 | import msyslib 90 | ```` 91 | But this module is included automatically, unless specifically excluded. The standard library is anyway special since the source files are expected to be embedded within the compiler, not be files on disk. 92 | 93 | ### NameSpaces 94 | 95 | Each module name creates a namespace within that subprogram. And each subprogram name also creates a namespace visible across the program. Mainly these are used for disambiguation when global or exported names clash. In that case, aliases can be created: 96 | ```` 97 | module longmodulename as lmn 98 | ```` 99 | to keep accesses short. In the dynamic language, module names can be stored in variables and used for name resolving at runtime. 100 | 101 | ### Creating a Library 102 | 103 | Any program can be compiled to a DLL file (Windows dynamic shared library) rather than EXE. Any names with `export` attribute in the top or only subprogram, are also exported from the DLL library. (In this case, the names are unadorned. If `B.F` is exported, it will have the name `F`, so some care needs to be taken to avoid clashes.) 104 | 105 | (Comments about EXE and DLL obviously refer to the systems language.) 106 | 107 | In principle, anything in its own subprogram can be made into a DLL, and the same functions called via the usual FFI methods. If the DLL is created with my compiler, it will automatically produce an exports file to allow its use from my language. So if Q is compiled, it will create a module called Q_LIB. Then P can be revised to be this: 108 | ```` 109 | project = 110 | module A 111 | module B 112 | module C 113 | module Q_LIB # contains FFI module to access exported entities of Q 114 | end 115 | ```` 116 | 117 | ### Library Imports 118 | 119 | One other thing the scheme specifies is any external libraries that are needed to build the application. For example: 120 | ```` 121 | linkdll opengl 122 | ```` 123 | This is only needed (in my language) if there isn't an import module somewhere with an FFI block that explicitly names the library. 124 | (Often there is no clean link: an FFI block might named 100 functions which exist in three separate DLLs, or the exact DLL name depends on version which I want in one place. Sometimes multiple FFIs declare names from the same DLL.) 125 | 126 | Names imported via FFI are given a global attribute. So I can have a module (say SDL) that imports a bunch of functions from SDL2 for example, those same functions are then visible to all other modules in the group. I just need `module SDL` in the lead module. 127 | 128 | ### The File System 129 | 130 | The module scheme tries to be independent of the file system. But it can't always manage that. 131 | 132 | There is currently a weak spot: unless all input modules are in the same directory of the lead module, it needs to be told where to look. But as it's done now, that info is hardcoded within the project info, which is undesirable. (In general I will not know for sure where some arbitrary subprogram resides, or it cou;ld change.) See the real example below. 133 | 134 | So this needs a better solution. Otherwise with that first example starting module P: 135 | ```` 136 | project = 137 | module A 138 | module B 139 | module C 140 | end 141 | ```` 142 | This represents 4 source files, `P.m A.m B.m C.m` (assuming my systems language). The location of `P.m` depends on what path was provided to the compiler, so if invoked like this: 143 | ```` 144 | mm \abc\def\p # note both file system and language are case-insensitive, and extensions are optional 145 | ```` 146 | Then `P.m` is in directory `/abc/def/`, and the other modules are looked for there unless the path is overwridden as shown below. 147 | 148 | In the case of the standard library modules, those source files are embedded inside the compiler. (There is an option to load them from disk, but it then looks somewhere that is only meaningful on my own machine as developer.) 149 | 150 | In this scheme, the compiler will always look in exactly one place for a source file. It will never look in a range of places (that can lead to inadvertently mixing versions, or even loading an unrelated file of the same name). 151 | 152 | ### Module Evaluation Order 153 | A feature of my languages is that there is an optional special function `start` in each module. If present, this is automatically called when the program starts. (In the dynamic one, there can also be file-scope variables initialised with runtime expressions.) 154 | 155 | This can be used to initialise various data and data structures. However, behaviour may rely on the order each function/each module is invoked. With a scheme using `import` everywhere, this can be unpredictable. Here, it is strictly in the order the modules are listed in the lead module, except the module containing the entry point (which must be near the start) is done last. 156 | 157 | ### Program Entry Point 158 | This is the function called `main` in the main subprogram, and specifically in the first module or the second. Other `main` functions in other modules are ignored. 159 | 160 | (In the dynamic language, individual modules can be run directly. If there is a `main` function in the lead module submitted, it will call it. This is sometimes used for test code for that module.) 161 | 162 | ### Real Example 163 | 164 | This is the lead module from a C compiler project, which contains only project info. This version is for a production version. It uses backend library which has its own lead module, 'pclp', that lists the modules it uses: 165 | ```` 166 | project = 167 | module cc_cli 168 | 169 | !Global Data and Tables 170 | 171 | module cc_decls 172 | module cc_tables 173 | 174 | !Lexing and Parsing 175 | module cc_lex 176 | module cc_parse 177 | 178 | !Generate PCL 179 | module cc_genpcl 180 | module cc_blockpcl 181 | module cc_libpcl 182 | 183 | !General 184 | 185 | module cc_lib 186 | module cc_support 187 | 188 | !Bundled headers 189 | 190 | module cc_headers 191 | 192 | !Diagnostics 193 | module cc_showdummy 194 | 195 | !IL Backend 196 | $sourcepath "c:/px/" 197 | import pclp 198 | end 199 | ```` 200 | 201 | ### Directives 202 | They are: 203 | ```` 204 | module name [as name] 205 | import name 206 | $sourcepath string # (temporary feature until sorted) 207 | linkdll name 208 | ```` 209 | 210 | The list can optionally be inside a `project ... end` block as shown in the examples. Possibly that can be used to define a name for executable, which otherwise will be based on the name of this module. 211 | 212 | 213 | -------------------------------------------------------------------------------- /QBenchmarks.md: -------------------------------------------------------------------------------- 1 | ## Q Interpreter Benchmarks 2 | 3 | This is testing old and new versions of my Q interpreter 'A' and 'B': 4 | 5 | ### The Benchmarks 6 | 7 | The following benchmarks were tested, mostly integer or float based: 8 | 9 | ```` 10 | ack Ackermann function (ack(3,9) 3 times) 11 | basic Simple BASIC interpreter running a loop 12 | bigint Simple big-integer library (implemented in Q; not built-in bignums) 13 | binary Binary trees (N=15) 14 | bitops Count '1' bits in 256 bit-patterns, 10.5K times 15 | blur Blurring 1x20Mpix linear greyscale image (adapted from image library) 16 | bubble Bubble sort (N=25, 50K times) 17 | clex Simple C Lexer, input is 980Kloc/22MB fike 18 | collatz Work out steps for N up to 300K 19 | comments Strip comments from 8MB C file and write out result 20 | cray Simple ray-tracing (64x64 greyscale image, write PGM) 21 | fann Fannkuch benchmark (N=9, twice) 22 | fib Fibonacci for N in 1..34 23 | for Empty for-loop (N=400M) 24 | jpeg JPEG decoder; input is 84KB/0.5Mpixel 25 | kiss64 PRNG test 26 | manboy 'Man-or-boy' closure emulation test (N=0 to 13, 200 times) 27 | mandelbrot Create fractal over 250x400 greyscale image, write PGM 28 | nbody NBody test (N=128K) 29 | nsieve Sieve benchmark (for larger N=3M) 30 | neg Invert bits in 25MB data (extracted from image library) 31 | nums 'Countdown' number puzzle solver 32 | poly ? 33 | pythag Find Pythagorean triplets up to N=400 34 | queens ? 35 | readx (Dump/disassemble EXE file to text file; input is 400KB file) 36 | rubik Represent Rubik's cube and apply 1M 90-deg rotations of one face 37 | runint Interpret Pascal P-code program evaluating Fibonacci for N=1..27 38 | search ? 39 | shell Shell sort 40 | sieve Sieve benchmark (small N of 10000, times 1000) 41 | spectral 'Spectral' benchmark 42 | sqrt ? 43 | sud Solve Sudoku puzzle (200 times) 44 | to Empty to-loop (N=300M) 45 | while While-loop (N=500M) 46 | ```` 47 | '?' means I can't remember exactly what it does. The important thing is it does some task that can be used to compare performance. 48 | 49 | ### Results 50 | 51 | The tests are done somewhat differently than before: 52 | 53 | * AA represents the old Q interpreter usng the fastest -asmopt ASM-assisted dispatcher 54 | * BB is the new interpreter with 100% HLL code and using new 'doswitchx' statement (built with my MM compiler) 55 | * DD is the same code, transpiled to C, and compiled with gcc-O3 56 | 57 | BB and DD are tested separately against AA. Raw runtimes in msec are shown, then AA result is normalised to 1.0, and the BB/DD result is shown relative to that; bigger is faster: 58 | ```` 59 | AA BB AA BB 60 | Running: ack 382 413 | 1.00 0.92 61 | Running: basic 898 991 | 1.00 0.91 62 | Running: bigint 491 601 | 1.00 0.82 63 | Running: binary 632 960 | 1.00 0.66 64 | Running: bitops 428 539 | 1.00 0.79 65 | Running: blur 1381 1351 | 1.00 1.02 66 | Running: bubble 585 1148 | 1.00 0.51 67 | Running: clex 694 694 | 1.00 1.00 68 | Running: collatz 882 804 | 1.00 1.10 69 | Running: comments 569 632 | 1.00 0.90 70 | Running: cray 445 413 | 1.00 1.08 71 | Running: fann 522 741 | 1.00 0.70 72 | Running: fib 476 491 | 1.00 0.97 73 | Running: for 835 867 | 1.00 0.96 74 | Running: kiss64 428 679 | 1.00 0.63 75 | Running: manboy 710 694 | 1.00 1.02 76 | Running: mandelbrot 398 522 | 1.00 0.76 77 | Running: nbody 648 726 | 1.00 0.89 78 | Running: nsieve 381 429 | 1.00 0.89 79 | Running: neg 70 194 | 1.00 0.36 80 | Running: nums 429 538 | 1.00 0.80 81 | Running: poly 460 475 | 1.00 0.97 82 | Running: pythag 445 663 | 1.00 0.67 83 | Running: queens 288 335 | 1.00 0.86 84 | Running: readx 351 382 | 1.00 0.92 85 | Running: rubik 1288 1538 | 1.00 0.84 86 | Running: runint 772 1070 | 1.00 0.72 87 | Running: search 194 460 | 1.00 0.42 88 | Running: shell 429 616 | 1.00 0.70 89 | Running: showg 413 445 | 1.00 0.93 90 | Running: sieve 569 726 | 1.00 0.78 91 | Running: spectral 288 382 | 1.00 0.75 92 | Running: sqrt 975 851 | 1.00 1.15 93 | Running: sud 1507 1757 | 1.00 0.86 94 | Running: to 678 679 | 1.00 1.00 95 | Running: while 257 319 | 1.00 0.81 96 | 97 | Totals: 21198 25125 98 | 99 | Averages: 1.00 0.84 100 | ```` 101 | 102 | Now for DD: 103 | ```` 104 | AA DD AA DD 105 | Running: ack 398 366 | 1.00 1.09 106 | Running: basic 913 647 | 1.00 1.41 107 | Running: bigint 460 414 | 1.00 1.11 108 | Running: binary 616 538 | 1.00 1.14 109 | Running: bitops 476 600 | 1.00 0.79 110 | Running: blur 1429 1069 | 1.00 1.34 111 | Running: bubble 585 726 | 1.00 0.81 112 | Running: clex 694 616 | 1.00 1.13 113 | Running: collatz 835 788 | 1.00 1.06 114 | Running: comments 585 398 | 1.00 1.47 115 | Running: cray 460 257 | 1.00 1.79 116 | Running: fann 475 460 | 1.00 1.03 117 | Running: fib 492 428 | 1.00 1.15 118 | Running: for 882 1038 | 1.00 0.85 119 | Running: kiss64 429 616 | 1.00 0.70 120 | Running: manboy 695 413 | 1.00 1.68 121 | Running: mandelbrot 397 320 | 1.00 1.24 122 | Running: nbody 663 492 | 1.00 1.35 123 | Running: nsieve 366 397 | 1.00 0.92 124 | Running: neg 54 179 | 1.00 0.30 125 | Running: nums 397 351 | 1.00 1.13 126 | Running: poly 444 382 | 1.00 1.16 127 | Running: pythag 444 554 | 1.00 0.80 128 | Running: queens 273 288 | 1.00 0.95 129 | Running: readx 366 288 | 1.00 1.27 130 | Running: rubik 1288 882 | 1.00 1.46 131 | Running: runint 757 757 | 1.00 1.00 132 | Running: search 225 289 | 1.00 0.78 133 | Running: shell 475 429 | 1.00 1.11 134 | Running: showg 397 335 | 1.00 1.19 135 | Running: sieve 523 772 | 1.00 0.68 136 | Running: spectral 288 226 | 1.00 1.27 137 | Running: sqrt 960 835 | 1.00 1.15 138 | Running: sud 1507 1585 | 1.00 0.95 139 | Running: to 679 679 | 1.00 1.00 140 | Running: while 257 272 | 1.00 0.94 141 | 142 | Totals: 21184 19686 143 | 144 | Averages: 1.00 1.09 145 | ```` 146 | 147 | ### Comparisons with CPython 3.14 and Lua 5.41 148 | 149 | The following were also tested under CPython 3.14 with the same parameters: 150 | 151 | ```` 152 | ack 5.9 seconds 153 | binary 5.9 154 | bitops 3.0 155 | bubble 3.3 156 | clex 9.5 (100Klps, best of several versions; B2 managed 1700Klps) 157 | fann 2.3 158 | fib 2.5 159 | for 6.6 160 | jpeg 1.7 161 | manboy 5.1 162 | mandelbrot 2.8 163 | nbody 1.5 164 | nsieve 1.3 165 | pythag 5.2 166 | shell 1.7 167 | sieve 1.9 168 | while 4.3 169 | ```` 170 | 171 | The following were also tested under Lua 5.41: 172 | ```` 173 | binary 4.8 seconds 174 | clex/alex 14.7 (66Klps; two versions exist) 175 | clex/slex 22.3 (44Klps) 176 | fann 0.6 177 | fib 1.3 178 | manboy 3.0 179 | nbody 0.5 180 | nsieve 1.9 181 | pythag 1.0 182 | while 2.9 183 | ```` 184 | ### Test Environment 185 | * Windows 11 186 | * AMD Ryzen 3 x64 processor 187 | 188 | -------------------------------------------------------------------------------- /QExamples/fib.q: -------------------------------------------------------------------------------- 1 | func fib(n)= 2 | if n<3 then 3 | 1 4 | else 5 | fib(n-1)+fib(n-2) 6 | fi 7 | end 8 | 9 | for i to 34 do 10 | println i,fib(i) 11 | od 12 | -------------------------------------------------------------------------------- /QExamples/hello.q: -------------------------------------------------------------------------------- 1 | println "Hello, World!", $date, $time 2 | -------------------------------------------------------------------------------- /QExamples/qq_run.m: -------------------------------------------------------------------------------- 1 | !const doretcheck=1 2 | const doretcheck=0 3 | 4 | macro steppc = ++pc 5 | macro skip1 = pc+:=2 6 | macro skip2 = pc+:=3 7 | 8 | macro zz = sp 9 | macro yy = sp-1 10 | 11 | macro save = pcptr:=pc 12 | !macro save = (pcptr:=pc; sptr:=sp) 13 | 14 | macro pclerror(x) = (pcptr:=pc; pcerror(x)) 15 | macro pclerror2(x,y) = (pcptr:=pc; pcerror(x,y)) 16 | macro pclustype(x,t) = (pcptr:=pc; pcustype(x,t)) 17 | macro pclmxtypes(x,t,u) = (pcptr:=pc; pcmxtypes(x,t,u)) 18 | 19 | macro copyvar(x, y) = x^:=y^ 20 | macro copyvarv(x, y) = x:=y^ 21 | macro copyvar_v(x, y) = x^:=y 22 | ! 23 | !macro copyvar(x, y) = (x.dummy:=y.dummy; x.value:=y.value) 24 | !macro copyvarv(x, y) = (x.dummy:=y.dummy; x.value:=y.value) 25 | !macro copyvar_v(x, y) = (x.dummy:=y.dummy; x.value:=y.value) 26 | 27 | global ref[0:]ref label jumptable !stays nil here 28 | 29 | global proc disploop = 30 | pcl pc 31 | variant sp 32 | ref byte fp 33 | 34 | variant x 35 | int index @ x 36 | variant dest @ x 37 | variant px @ x 38 | variant y 39 | symbol d @ y 40 | int nloc @ y 41 | variant z 42 | int n @ z 43 | pcl pz @ z 44 | object pp @ z 45 | object q @ z 46 | 47 | int xt,yt, res, lower, upper, moduleno, offset 48 | variant newsp 49 | symbol e 50 | 51 | varrec vx 52 | 53 | sp:=sptr 54 | pc:=pcptr 55 | fp:=frameptr 56 | 57 | doswitchu pc.opcode 58 | when knop then ! simple nop 59 | ! unimpl 60 | steppc 61 | 62 | when kskip then ! ignore on pcl listing 63 | unimpl 64 | steppc 65 | 66 | when kprocdef then ! 67 | unimpl 68 | steppc 69 | 70 | when kprocent then ! n=number of locals; 71 | to pc.n do 72 | ++sp 73 | sp.tagx:=tvoid 74 | od 75 | steppc 76 | 77 | when kprocend then 78 | unimpl 79 | steppc 80 | 81 | when kendmod then 82 | unimpl 83 | steppc 84 | 85 | when kcomment then 86 | ! unimpl 87 | steppc 88 | 89 | when kpushm then ! Push v 90 | ++sp 91 | copyvar(sp, pc.varptr) 92 | var_share(sp) 93 | steppc 94 | 95 | when kpushf then ! Push v 96 | jpushf: 97 | ++sp 98 | x:=cast(fp+pc.offset) 99 | ! sp^:=x^ 100 | copyvar(sp, x) 101 | 102 | var_share(sp) 103 | steppc 104 | 105 | when kpushmref then ! push &v 106 | jpushmref: 107 | ++sp 108 | sp.tagx:=trefvar 109 | sp.varptr:=pc.varptr 110 | steppc 111 | 112 | when kpushfref then ! push &v 113 | jpushfref: 114 | ++sp 115 | sp.tagx:=trefvar 116 | sp.varptr:=cast(fp+pc.offset) 117 | steppc 118 | 119 | when kpopm then ! v := Z 120 | x:=pc.varptr 121 | var_unshare(x) 122 | ! x^:=sp^ 123 | copyvar(x, sp) 124 | --sp 125 | steppc 126 | 127 | when kpopf then ! v := Z 128 | x:=cast(fp+pc.offset) 129 | var_unshare(x) 130 | copyvar(x, sp) 131 | --sp 132 | steppc 133 | 134 | when kpushci then ! Push i 135 | jpushci: 136 | ++sp 137 | sp.tagx:=tint 138 | sp.value:=pc.value 139 | steppc 140 | jpushcix: 141 | 142 | when kpushvoid then ! Push void 143 | ++sp 144 | sp.tagx:=tvoid 145 | steppc 146 | 147 | when kpushnil then ! Push nil (ref void) 148 | ++sp 149 | sp.tagx:=trefpack 150 | sp.elemtag:=tvoid 151 | sp.ptr:=nil 152 | steppc 153 | 154 | when kpushcr then ! Push r 155 | ++sp 156 | sp.tagx:=treal 157 | sp.xvalue:=pc.xvalue 158 | steppc 159 | 160 | when kpushcs then ! Push constant string object 161 | ++sp 162 | sp.tagx:=tstring ior hasrefmask 163 | sp.objptr:=pc.objptr 164 | ++sp.objptr.refcount 165 | steppc 166 | 167 | when kpushtype then ! Push type constant 168 | ++sp 169 | sp.tagx:=ttype 170 | sp.value:=pc.typecode 171 | steppc 172 | 173 | when kpushopc then ! Push operator constant 174 | ++sp 175 | sp.tagx:=toperator 176 | sp.value:=pc.pclop 177 | steppc 178 | 179 | when kpushsym then ! Push symbol reference 180 | ++sp 181 | sp.tagx:=tsymbol 182 | sp.def:=pc.def 183 | 184 | steppc 185 | 186 | when kpushptr then ! Z' := Z^ 187 | x:=sp 188 | jpushptr: 189 | case x.tag 190 | when trefvar then 191 | sp^:=x.varptr^ 192 | 193 | when trefpack then 194 | case x.elemtag 195 | when tu8 then 196 | sp.tagx:=tint 197 | sp.value:=x.ptr^ 198 | goto refpackend 199 | else 200 | save 201 | var_loadpacked(x.ptr, x.elemtag, sp, nil) 202 | esac 203 | 204 | when trefbit then 205 | save 206 | var_loadbit(x.ptr, x.bitoffset, x.elemtag, x.bitlength, sp) 207 | 208 | else 209 | pclustype("Pushptr",x) 210 | esac 211 | 212 | var_share(sp) 213 | refpackend: 214 | steppc 215 | 216 | when kpushptrf then 217 | x:=cast(fp+pc.offset) 218 | ++sp 219 | ++pc 220 | goto jpushptr 221 | 222 | when kpopptr then ! Z^ := Y 223 | y:=sp-- 224 | x:=sp-- 225 | 226 | case y.tag 227 | when trefvar then 228 | var_unshare(y.varptr) 229 | y.varptr^:=x^ 230 | when trefpack then 231 | save 232 | var_storepacked(y.ptr,x, y.elemtag) 233 | when trefbit then 234 | save 235 | var_storebit(y.ptr, y.bitoffset, x, y.elemtag, y.bitlength) 236 | 237 | else 238 | pclustype("Popptr",y) 239 | esac 240 | 241 | steppc 242 | 243 | when kzpopm then ! v := Z; don't free v first 244 | copyvar(pc.varptr, sp) 245 | --sp 246 | steppc 247 | 248 | when kzpopf then ! v := Z; don't free v first 249 | x:=cast(fp+pc.offset) 250 | copyvar(x, sp) 251 | --sp 252 | steppc 253 | 254 | when kdupl then ! (Z',Y') := (share(Z), Z) 255 | ++sp 256 | copyvar(sp, sp-1) 257 | var_share(sp) 258 | steppc 259 | 260 | when kcopy then ! Z' := deepcopy(Z) 261 | if sp.hasref then 262 | copyvarv(vx, sp) 263 | save 264 | var_duplu(sp) 265 | var_unshareu(&vx) 266 | fi 267 | steppc 268 | 269 | when kswap then ! swap(Z^, Y^) 270 | x:=sp-- 271 | y:=sp-- 272 | 273 | if x.tag=y.tag=trefvar then 274 | copyvar(&vx, x.varptr) 275 | copyvar(x.varptr, y.varptr) 276 | copyvar(y.varptr, &vx) 277 | else 278 | save 279 | k_swap(x,y) 280 | fi 281 | steppc 282 | 283 | when kconvrefp then ! Change ref in Z to refpacked 284 | save 285 | k_convrefpack(sp) 286 | steppc 287 | 288 | when kjump then ! Jump to L 289 | pc:=pc.labelref 290 | 291 | when kjumpptr then ! Jump to Z 292 | unimpl 293 | steppc 294 | 295 | when kjumpt then ! Jump to L when Z is true 296 | x:=sp-- 297 | 298 | if x.tag=tint then 299 | if x.value then 300 | pc:=pc.labelref 301 | else 302 | steppc 303 | fi 304 | else 305 | save 306 | if var_istruel(x) then 307 | pc:=pc.labelref 308 | else 309 | steppc 310 | fi 311 | var_unshare(x) 312 | fi 313 | 314 | when kjumpf then ! Jump to L when Z is false 315 | x:=sp-- 316 | 317 | if x.tag=tint then 318 | if not x.value then 319 | pc:=pc.labelref 320 | else 321 | steppc 322 | fi 323 | else 324 | save 325 | if not var_istruel(x) then 326 | pc:=pc.labelref 327 | else 328 | steppc 329 | fi 330 | var_unshare(x) 331 | fi 332 | 333 | when kjumpeq then ! Jump to L when Y = Z 334 | y:=sp-- 335 | x:=sp-- 336 | 337 | if x.tag=y.tag=tint then 338 | if x.value=y.value then 339 | pc:=pc.labelref 340 | else 341 | steppc 342 | fi 343 | else 344 | save 345 | if var_equal(x, y) then 346 | pc:=pc.labelref 347 | else 348 | steppc 349 | fi 350 | fi 351 | 352 | when kjumpne then ! Jump to L when Y<>= Z 353 | y:=sp-- 354 | x:=sp-- 355 | 356 | if x.tag=y.tag=tint then 357 | if x.value<>y.value then 358 | pc:=pc.labelref 359 | else 360 | steppc 361 | fi 362 | else 363 | save 364 | if not var_equal(x, y) then 365 | pc:=pc.labelref 366 | else 367 | steppc 368 | fi 369 | fi 370 | 371 | when kjumplt then ! Jump to L when Y < Z 372 | y:=sp-- 373 | x:=sp-- 374 | 375 | if x.tag=y.tag=tint then 376 | if x.value= Z 416 | y:=sp-- 417 | x:=sp-- 418 | 419 | if x.tag=y.tag=tint then 420 | if x.value>=y.value then 421 | pc:=pc.labelref 422 | else 423 | steppc 424 | fi 425 | else 426 | save 427 | if var_compare(x,y)>=0 then 428 | pc:=pc.labelref 429 | else 430 | steppc 431 | fi 432 | fi 433 | 434 | when kjumpgt then ! Jump to L when Y > Z 435 | y:=sp-- 436 | x:=sp-- 437 | 438 | if x.tag=y.tag=tint then 439 | if x.value>y.value then 440 | pc:=pc.labelref 441 | else 442 | steppc 443 | fi 444 | else 445 | save 446 | if var_compare(x,y)>0 then 447 | pc:=pc.labelref 448 | else 449 | steppc 450 | fi 451 | fi 452 | 453 | when kjmpeqfci then ! Jump to L when B = C 454 | x:=cast(fp+pc.offset) 455 | if x.tag<>tint then goto jpushf fi 456 | if x.value=(pc+1).value then 457 | pc:=(pc+2).labelref 458 | else 459 | skip2 460 | fi 461 | 462 | when kjmpnefci then ! Jump to L when B <> C 463 | x:=cast(fp+pc.offset) 464 | if x.tag<>tint then goto jpushf fi 465 | if x.value<>(pc+1).value then 466 | pc:=(pc+2).labelref 467 | else 468 | skip2 469 | fi 470 | 471 | when kjmpltfci then ! Jump to L when B < C 472 | x:=cast(fp+pc.offset) 473 | if x.tag<>tint then goto jpushf fi 474 | if x.value<(pc+1).value then 475 | pc:=(pc+2).labelref 476 | else 477 | skip2 478 | fi 479 | 480 | when kjmplefci then ! Jump to L when B <= C 481 | x:=cast(fp+pc.offset) 482 | if x.tag<>tint then goto jpushf fi 483 | if x.value<=(pc+1).value then 484 | pc:=(pc+2).labelref 485 | else 486 | skip2 487 | fi 488 | 489 | when kjmpgefci then ! Jump to L when B >= C 490 | x:=cast(fp+pc.offset) 491 | if x.tag<>tint then goto jpushf fi 492 | if x.value>=(pc+1).value then 493 | pc:=(pc+2).labelref 494 | else 495 | skip2 496 | fi 497 | 498 | when kjmpgtfci then ! Jump to L when B > C 499 | x:=cast(fp+pc.offset) 500 | if x.tag<>tint then goto jpushf fi 501 | if x.value>(pc+1).value then 502 | pc:=(pc+2).labelref 503 | else 504 | skip2 505 | fi 506 | 507 | when kjmpeqff then ! Jump to L when B = C 508 | x:=cast(fp+pc.offset) 509 | if x.tag<>tint then goto jpushf fi 510 | y:=cast(fp+(pc+1).offset) 511 | if x.value=y.value then 512 | pc:=(pc+2).labelref 513 | else 514 | skip2 515 | fi 516 | 517 | when kjmpneff then ! Jump to L when B <> C 518 | x:=cast(fp+pc.offset) 519 | if x.tag<>tint then goto jpushf fi 520 | y:=cast(fp+(pc+1).offset) 521 | if x.value<>y.value then 522 | pc:=(pc+2).labelref 523 | else 524 | skip2 525 | fi 526 | 527 | when kjmpltff then ! Jump to L when B < C 528 | x:=cast(fp+pc.offset) 529 | if x.tag<>tint then goto jpushf fi 530 | y:=cast(fp+(pc+1).offset) 531 | if x.valuetint then goto jpushf fi 540 | y:=cast(fp+(pc+1).offset) 541 | if x.value<=y.value then 542 | pc:=(pc+2).labelref 543 | else 544 | skip2 545 | fi 546 | 547 | when kjmpgeff then ! Jump to L when B >= C 548 | x:=cast(fp+pc.offset) 549 | if x.tag<>tint then goto jpushf fi 550 | y:=cast(fp+(pc+1).offset) 551 | if x.value>=y.value then 552 | pc:=(pc+2).labelref 553 | else 554 | skip2 555 | fi 556 | 557 | when kjmpgtff then ! Jump to L when B > C 558 | x:=cast(fp+pc.offset) 559 | if x.tag<>tint then goto jpushf fi 560 | y:=cast(fp+(pc+1).offset) 561 | if x.value>y.value then 562 | pc:=(pc+2).labelref 563 | else 564 | skip2 565 | fi 566 | 567 | when kwheneq then ! Y = Z: pop both, jump to L 568 | ! Y <> Z: pop Z only; don't jump 569 | y:=sp-- 570 | x:=sp 571 | 572 | if x.tag=y.tag=tint then 573 | if x.value=y.value then 574 | --sp 575 | pc:=pc.labelref 576 | else 577 | steppc 578 | fi 579 | else 580 | save 581 | res:=k_when(x, y) 582 | var_unshare(y) 583 | if res then 584 | var_unshare(x) 585 | --sp 586 | pc:=pc.labelref 587 | else 588 | steppc 589 | fi 590 | fi 591 | 592 | when kwhenne then ! Y <> Z: pop Z only, jump to L 593 | ! Y = Z: pop both, step to next 594 | jwhenne: 595 | y:=sp-- 596 | x:=sp 597 | 598 | if x.tag=y.tag=tint then 599 | if x.value<>y.value then 600 | pc:=pc.labelref 601 | else 602 | --sp 603 | steppc 604 | fi 605 | else 606 | save 607 | res:=k_when(x, y) 608 | var_unshare(y) 609 | if not res then 610 | pc:=pc.labelref 611 | else 612 | var_unshare(x) 613 | --sp 614 | steppc 615 | fi 616 | fi 617 | 618 | when kjumplab then ! Jumptable entry 619 | unimpl 620 | steppc 621 | 622 | when kswitch then ! Jumptable has y-x+1 entries 623 | lower:=pc.x 624 | n:=pc.y-lower+1 625 | 626 | case sp.tag 627 | when tint,ttype then 628 | else 629 | pclerror2("switch not int",ttname[sp.tag]) 630 | esac 631 | 632 | index:=sp.value-lower !now 0-based index 633 | ! 634 | --sp 635 | 636 | if u64(index)>=u64(n) then !out of range 637 | pc:=(pc+n+1).labelref 638 | else !in range 639 | pc:=(pc+index+1).labelref 640 | fi 641 | 642 | when ktom then ! --v; jump to l when v<>0 in next op 643 | x:=(pc+1).varptr 644 | doto 645 | 646 | when ktof then ! --v; jump to l when v<>0 in next op 647 | freddy: 648 | x:=cast(fp+(pc+1).offset) 649 | doto: 650 | if --x.value then 651 | pc:=pc.labelref 652 | else 653 | skip1 654 | fi 655 | 656 | when kformci then ! ++v; jump to l when v<=i in next 2 ops: pushm/pushci 657 | x:=(pc+1).varptr 658 | doforfci 659 | 660 | when kforfci then ! ++v; jump to l when v<=i in next 2 ops: pushm/pushci 661 | x:=cast(fp+(pc+1).offset) 662 | doforfci: 663 | ++x.value 664 | if x.value<=(pc+2).value then 665 | pc:=pc.labelref 666 | else 667 | skip2 668 | fi 669 | 670 | when kformm then ! ++v; jump to l when v<=v in next 2 ops 671 | x:=(pc+1).varptr 672 | y:=(pc+2).varptr 673 | doforff 674 | 675 | when kforff then ! ++v; jump to l when v<=v in next 2 ops 676 | x:=cast(fp+(pc+1).offset) 677 | y:=cast(fp+(pc+2).offset) 678 | doforff: 679 | ++x.value 680 | 681 | if x.value<=y.value then 682 | pc:=pc.labelref 683 | else 684 | skip2 685 | fi 686 | 687 | when kcallproc then ! Call &A; n is no. args 688 | const countinterval=100 689 | static int count=countinterval 690 | 691 | if --count=0 then 692 | count:=countinterval 693 | os_peek() 694 | fi 695 | 696 | if sp>=stacklimit then 697 | pclerror("Stack Overflow") 698 | fi 699 | 700 | ++sp 701 | sp.tagx:=tretaddr 702 | sp.retaddr := pc+1 703 | 704 | sp.frameptr_low := u64(fp) 705 | fp:=cast(sp) 706 | 707 | pc:=pc.labelref 708 | 709 | when kcallptr then ! Call X^; n is no. of params supplied; x is stack adjust 710 | if sp.tag<>tsymbol then 711 | pclerror("Probably undefined function") 712 | fi 713 | 714 | d:=sp.def 715 | if d.nameid=linkid then d:=d.alias fi 716 | 717 | if d.nparams<>pc.n then 718 | pclerror2("Callptr: wrong # params; need:",strint(d.nparams)) 719 | fi 720 | 721 | sp.tagx:=tretaddr 722 | sp.retaddr := pc+1 723 | 724 | sp.frameptr_low := word(fp) 725 | fp:=cast(sp) 726 | 727 | pc:=cast(d.labelref) 728 | 729 | when kretproc then 730 | doretproc: 731 | to pc.x do 732 | var_unshare(sp) 733 | --sp 734 | od 735 | 736 | n:=pc.n 737 | pc:=sp.retaddr 738 | fp:= cast(u64(fp) iand (0xFFFF'FFFF'0000'0000) ior sp.frameptr_low) 739 | --sp 740 | 741 | to n do 742 | var_unshare(sp) 743 | --sp 744 | od 745 | 746 | when kretfn then 747 | x:=variant(fp+pc.y) 748 | copyvar(x, sp) !transfer reference 749 | --sp 750 | doretproc 751 | 752 | when kmodcall then ! 753 | d:=pc.def 754 | moduleno:=d.moduleno 755 | 756 | ++sp 757 | sp.tagx:=tretaddr 758 | sp.retaddr := pc+1 759 | pc:=modules[moduleno].pcstart 760 | 761 | when kmodret then ! 762 | pc:=sp.retaddr 763 | 764 | when kcalldll then ! Call dll function d (sysmbol); n=nargs 765 | n:=pc.n 766 | save 767 | SPTR:=SP 768 | 769 | calldll(pc.def, sp-n+1, sp-n, n) 770 | sp-:=n 771 | 772 | steppc 773 | 774 | when kcallhost then ! Call Q host function h (Host index) 775 | save 776 | sp:=callhostfunction(pc.hostindex, sp) 777 | steppc 778 | 779 | when kunshare then ! Unshare and pop A var values on stack 780 | to pc.n do 781 | var_unshare(sp) 782 | --sp 783 | od 784 | steppc 785 | 786 | when kstop then ! Stop program with stopcode Z; n=1 to stop runproc instead 787 | stopped:=1 788 | sptr:=sp 789 | exit 790 | 791 | when kmakelist then ! x items on stack; make list with lwb y 792 | save 793 | sp:=k_makelist(sp, pc.y, pc.x) 794 | steppc 795 | 796 | when kmakevrec then ! x items on stack; make record of type u 797 | n:=pc.x 798 | x:=sp-pc.x+1 !start of data 799 | 800 | save 801 | var_make_record(x, x, pc.x, pc.usertag) 802 | sp:=x 803 | sp.objptr.mutable:=0 804 | steppc 805 | 806 | when kmakeax then ! x items on stack; make array with lwb y, type u and elemtype v 807 | unimpl 808 | steppc 809 | 810 | when kmakebits then ! x items on stack; make bits with lwb y, type u and elemtype v 811 | unimpl 812 | steppc 813 | 814 | when kmaketrec then ! x items on stack; make struct with type u 815 | n:=pc.x 816 | x:=sp-n+1 !start of data 817 | 818 | save 819 | var_make_struct(x, x, n, pc.usertag) 820 | sp:=x 821 | sp.objptr.mutable:=0 822 | steppc 823 | 824 | when kmakeset then ! x items on stack; make set 825 | n:=pc.x 826 | 827 | x:=sp-n+1 !start of data 828 | 829 | save 830 | var_make_set(x, x, n) 831 | sp:=x 832 | sp.objptr.mutable:=0 833 | 834 | steppc 835 | 836 | when kmakerang then ! 2 items on stack; make range 837 | y:=sp-- 838 | x:=sp 839 | 840 | unless x.tag=y.tag=tint then 841 | pclerror("makerange/not int") 842 | end 843 | 844 | sp.tagx:=trange 845 | lower:=x.value 846 | upper:=y.value 847 | 848 | if lower not in -(2**48)..2**48-1 then 849 | pclerror("Range lwb bounds") 850 | end 851 | 852 | sp.range_upper:=upper 853 | sp.range_lower:=lower 854 | 855 | steppc 856 | 857 | when kmakedict then ! x*2 items on stack (x key:val items); make dict 858 | n:=pc.x 859 | x:=sp-n*2+1 !start of data 860 | 861 | save 862 | var_make_dict(x, x, n) 863 | sp:=x 864 | steppc 865 | 866 | when kmakedec then ! Turn string on stack to decimal number 867 | ! vx:=sp^ 868 | copyvarv(vx, sp) 869 | 870 | if vx.tag<>tstring then pclerror("Not str") fi 871 | pp:=vx.objptr 872 | if pp.length=0 then pclerror("Null str") fi 873 | 874 | save 875 | var_make_dec_str(pp.strptr, pp.length, sp) 876 | 877 | var_unshare(&vx) 878 | 879 | steppc 880 | 881 | when kincrptr then ! Z^ +:= x 882 | save 883 | k_incrptr(sp, pc.x) 884 | --sp 885 | steppc 886 | 887 | when kincrtom then ! v +:= x 888 | x:=pc.varptr 889 | doincrto 890 | 891 | when kincrtof then ! v +:= x 892 | jincrtof: 893 | x:=cast(fp+pc.offset) 894 | doincrto: 895 | case x.tag 896 | when tint then 897 | x.value+:=pc.x 898 | when trefvar then 899 | x.varptr+:=pc.x 900 | when trefpack then 901 | x.ptr+:=ttsize[x.elemtag]*pc.x 902 | when treal then 903 | x.xvalue+:=pc.x 904 | else 905 | pclustype("incrto",x) 906 | end 907 | steppc 908 | jincrtofx: 909 | 910 | when kloadincr then ! T := Z^; Z^ +:= x; Z' := T 911 | copyvarv(vx, sp) 912 | ! vx:=sp^ 913 | save 914 | var_loadptr(sp,sp) 915 | ++sp 916 | ! sp^:=vx 917 | copyvar_v(sp, vx) 918 | k_incrptr(sp, pc.x) 919 | --sp 920 | steppc 921 | 922 | when kincrload then ! Z^ +:= x; Z' := Z^ 923 | ! vx:=sp^ 924 | copyvarv(vx, sp) 925 | save 926 | k_incrptr(sp, pc.x) 927 | --sp 928 | var_loadptr(&vx, ++sp) 929 | steppc 930 | 931 | when kneg then ! Z':= -Z 932 | ! vx:=sp^ 933 | 934 | copyvarv(vx, sp) 935 | save 936 | var_neg(sp) 937 | var_unshare(&vx) 938 | steppc 939 | 940 | when kabs then ! Z' := abs Z 941 | ! vx:=sp^ 942 | copyvarv(vx, sp) 943 | 944 | save 945 | var_abs(sp) 946 | var_unshare(&vx) 947 | 948 | steppc 949 | 950 | when knotl then ! Z' := not Z 951 | save 952 | res:=not var_istruel(sp) 953 | var_unshare(sp) 954 | sp.tagx:=tint 955 | sp.value:=res 956 | steppc 957 | 958 | when kinot then ! Z' := inot Z 959 | if sp.tag=tint then 960 | sp.value:=inot sp.value 961 | else 962 | copyvarv(vx, sp) 963 | save 964 | var_inot(sp) 965 | var_unshare(&vx) 966 | fi 967 | 968 | steppc 969 | 970 | when kistruel then ! Z' := istrue Z 971 | save 972 | n:=var_istruel(sp) 973 | var_unshare(sp) 974 | sp.tagx:=tint 975 | sp.value:=n 976 | 977 | steppc 978 | 979 | when kasc then ! Z' := asc(Z) 980 | case sp.tag 981 | when tstring then 982 | if sp.objptr.length then 983 | n:=sp.objptr.strptr^ 984 | else 985 | n:=0 986 | fi 987 | var_unshareu(sp) 988 | sp.tagx:=tint 989 | sp.value:=n 990 | else 991 | pcustype("ASC",sp) 992 | esac 993 | steppc 994 | 995 | when kchr then ! Z' := chr(Z) 996 | if sp.tag=tint then 997 | save 998 | var_makechar(sp.value, sp) 999 | else 1000 | pclustype("CHR",sp) 1001 | fi 1002 | steppc 1003 | 1004 | when ksqr then ! Z' := op(Z) 1005 | case sp.tag 1006 | when tint then 1007 | sp.value:=sqr(sp.value) 1008 | when treal then 1009 | sp.xvalue:=sqr(sp.xvalue) 1010 | else 1011 | pclustype("sqr", sp) 1012 | esac 1013 | steppc 1014 | 1015 | when kmaths then ! Z' := op(Z) 1016 | save 1017 | k_maths(sp, pc.mathscode) 1018 | steppc 1019 | 1020 | when kmaths2 then ! Z' := op(Y, Z) 1021 | unimpl 1022 | steppc 1023 | 1024 | when kunaryto then ! Z^ op:= Z 1025 | unimpl 1026 | steppc 1027 | 1028 | when knotlto then ! Z^ not:= Z 1029 | unimpl 1030 | steppc 1031 | 1032 | when klen then ! Z' := Z.len 1033 | save 1034 | k_len(sp) 1035 | steppc 1036 | 1037 | when klwb then ! Z' := Z.lwb 1038 | save 1039 | k_lwb(sp) 1040 | steppc 1041 | 1042 | when kupb then ! Z' := Z.upb 1043 | jupb: 1044 | save 1045 | k_upb(sp) 1046 | steppc 1047 | 1048 | when kbounds then ! Z' := Z.bounds; n=1: one range value; n=2: two dims 1049 | save 1050 | k_bounds(sp, lower, upper) 1051 | 1052 | if pc.n=2 then !push as 2 value 1053 | var_unshare(sp) 1054 | sp.tagx:=tint 1055 | sp.value:=lower 1056 | ++sp 1057 | sp.tagx:=tint 1058 | sp.value:=upper 1059 | 1060 | else !push as 1 range value 1061 | var_unshare(sp) 1062 | sp.tagx:=trange 1063 | sp.range_lower:=lower 1064 | sp.range_upper:=upper 1065 | fi 1066 | 1067 | steppc 1068 | 1069 | when kbytesize then ! Z' := Z.bytesize 1070 | save 1071 | res:=k_bytesize(sp) 1072 | var_unshare(sp) 1073 | sp.tagx:=tint 1074 | sp.value:=res 1075 | steppc 1076 | 1077 | when ktype then ! Z' := n=0/1/2 = basetype/tag/elemtype 1078 | save 1079 | n:=k_type(sp, pc.n) 1080 | var_unshare(sp) 1081 | sp.tagx:=ttype 1082 | sp.value:=n 1083 | 1084 | steppc 1085 | 1086 | when kdictsize then ! Z' := Z.dictsize 1087 | unimpl 1088 | steppc 1089 | 1090 | when kisfound then ! Z' := Z.isfound 1091 | if sp.tag<>tint then pclerror("isfound") fi 1092 | sp.value:=sp.value<>i64.min 1093 | steppc 1094 | 1095 | when kminval then ! Z' := Z.minvalue 1096 | unimpl 1097 | steppc 1098 | 1099 | when kmaxval then ! Z' := Z.maxvalue 1100 | unimpl 1101 | steppc 1102 | 1103 | when kistype then ! Z' := Z.type/etc = t 1104 | n:=0 1105 | if pc.typecode=trefvar then 1106 | if sp.tag in [trefvar, trefpack, trefbit] then n:=1 fi 1107 | else 1108 | if pc.typecode=sp.tag then n:=1 fi 1109 | fi 1110 | var_unshare(sp) 1111 | sp.tagx:=tint 1112 | sp.value:=n 1113 | steppc 1114 | 1115 | when kisvoid then ! Z' := Z.isvoid (n=0) or not Z.isdef (n=1) 1116 | res:=sp.tag=tvoid 1117 | var_unshare(sp) 1118 | sp.tagx:=tint 1119 | sp.value:=res ixor pc.n 1120 | steppc 1121 | 1122 | when kconvert then ! Z' := t(Z) 1123 | if sp.tag<>pc.usertag then 1124 | ! vx:=sp^ 1125 | copyvarv(vx, sp) 1126 | save 1127 | var_convert(&vx, pc.usertag, sp) 1128 | var_unshare(&vx) 1129 | fi 1130 | 1131 | steppc 1132 | 1133 | when ktypepun then ! Z' := t@(Z) 1134 | unimpl 1135 | steppc 1136 | 1137 | when kadd then ! Z' := Y + Z 1138 | jadd: 1139 | y:=sp-- 1140 | 1141 | if sp.tag=y.tag=tint then 1142 | sp.value+:=y.value 1143 | elsif sp.tag=y.tag=treal then 1144 | sp.xvalue+:=y.xvalue 1145 | else 1146 | ! vx:=sp^ 1147 | copyvarv(vx, sp) 1148 | 1149 | save 1150 | var_add(sp, y) 1151 | 1152 | var_unshare(&vx) 1153 | var_unshare(y) 1154 | fi 1155 | steppc 1156 | 1157 | when ksub then ! Z' := Y - Z 1158 | y:=sp-- 1159 | 1160 | if sp.tag=y.tag=tint then 1161 | sp.value-:=y.value 1162 | elsif sp.tag=y.tag=treal then 1163 | sp.xvalue-:=y.xvalue 1164 | else 1165 | copyvarv(vx, sp) 1166 | 1167 | save 1168 | var_sub(sp, y) 1169 | 1170 | var_unshare(&vx) 1171 | var_unshare(y) 1172 | fi 1173 | steppc 1174 | 1175 | when kmul then ! Z' := Y * Z 1176 | y:=sp-- 1177 | 1178 | if sp.tag=y.tag=tint then 1179 | sp.value*:=y.value 1180 | elsif sp.tag=y.tag=treal then 1181 | sp.xvalue*:=y.xvalue 1182 | else 1183 | ! vx:=sp^ 1184 | copyvarv(vx, sp) 1185 | 1186 | save 1187 | var_mul(sp,y) 1188 | 1189 | var_unshare(&vx) 1190 | var_unshare(y) 1191 | fi 1192 | 1193 | steppc 1194 | 1195 | when kdiv then ! Z' := Y / Z 1196 | y:=sp-- 1197 | copyvarv(vx, sp) 1198 | 1199 | if sp.tag=y.tag=treal then 1200 | sp.xvalue/:=y.xvalue 1201 | else 1202 | save 1203 | var_div(sp,y) 1204 | 1205 | var_unshare(&vx) 1206 | var_unshare(y) 1207 | fi 1208 | 1209 | steppc 1210 | 1211 | when kidiv then ! Z' := Y % Z 1212 | y:=sp-- 1213 | copyvarv(vx, sp) 1214 | 1215 | if sp.tag=y.tag=tint then 1216 | sp.value/:=y.value 1217 | else 1218 | save 1219 | var_idiv(sp, y) 1220 | 1221 | var_unshare(&vx) 1222 | var_unshare(y) 1223 | fi 1224 | 1225 | 1226 | steppc 1227 | 1228 | when kirem then ! Z' := Y rem Z 1229 | y:=sp-- 1230 | copyvarv(vx, sp) 1231 | 1232 | save 1233 | var_irem(sp,y) 1234 | 1235 | var_unshare(&vx) 1236 | var_unshare(y) 1237 | 1238 | steppc 1239 | 1240 | when kidivrem then ! (Y', Z') := Y divrem Z 1241 | unimpl 1242 | steppc 1243 | 1244 | when kiand then ! Z' := Y iand Z 1245 | y:=sp-- 1246 | 1247 | if sp.tag=y.tag=tint then 1248 | sp.value iand:=y.value 1249 | else 1250 | copyvarv(vx, sp) 1251 | save 1252 | var_iand(sp,y) 1253 | 1254 | var_unshare(&vx) 1255 | var_unshare(y) 1256 | fi 1257 | steppc 1258 | 1259 | when kior then ! Z' := Y ior Z 1260 | y:=sp-- 1261 | 1262 | if sp.tag=y.tag=tint then 1263 | sp.value ior:=y.value 1264 | else 1265 | copyvarv(vx, sp) 1266 | save 1267 | var_ior(sp,y) 1268 | 1269 | var_unshare(&vx) 1270 | var_unshare(y) 1271 | fi 1272 | steppc 1273 | 1274 | when kixor then ! Z' := Y ixor Z 1275 | y:=sp-- 1276 | if sp.tag=y.tag=tint then 1277 | sp.value ixor:=y.value 1278 | else 1279 | copyvarv(vx, sp) 1280 | 1281 | save 1282 | var_ixor(sp,y) 1283 | 1284 | var_unshare(&vx) 1285 | var_unshare(y) 1286 | fi 1287 | steppc 1288 | 1289 | when kshl then ! Z' := Y << Z 1290 | y:=sp-- 1291 | 1292 | if sp.tag=y.tag=tint then 1293 | sp.value <<:=y.value 1294 | else 1295 | copyvarv(vx, sp) 1296 | 1297 | save 1298 | var_shl(sp,y) 1299 | 1300 | var_unshare(&vx) 1301 | var_unshare(y) 1302 | fi 1303 | steppc 1304 | 1305 | when kshr then ! Z' := Y >> Z 1306 | y:=sp-- 1307 | 1308 | if sp.tag=y.tag=tint then 1309 | sp.value >>:=y.value 1310 | else 1311 | copyvarv(vx, sp) 1312 | 1313 | save 1314 | var_shr(sp,y) 1315 | 1316 | var_unshare(&vx) 1317 | var_unshare(y) 1318 | fi 1319 | steppc 1320 | 1321 | when kin then ! Z' := Y in Z (n=0) or Y not in Z (n=1) 1322 | y:=sp 1323 | x:=--sp 1324 | 1325 | save 1326 | n:=var_in(x,y) ixor pc.n 1327 | var_unshare(x) 1328 | var_unshare(y) 1329 | 1330 | sp.tagx:=tint 1331 | sp.value:=n 1332 | steppc 1333 | 1334 | when kinx then ! Z' := Y inx Z 1335 | y:=sp 1336 | x:=--sp 1337 | 1338 | save 1339 | n:=var_inx(x,y) 1340 | var_unshare(x) 1341 | var_unshare(y) 1342 | 1343 | sp.tagx:=tint 1344 | sp.value:=n 1345 | 1346 | steppc 1347 | 1348 | when kcmp then ! Z' := Y c Z 1349 | y:=sp 1350 | x:=--sp 1351 | 1352 | save 1353 | res:=k_cmp(pc.n, x, y) 1354 | var_unshare(x) 1355 | var_unshare(y) 1356 | 1357 | sp.tagx:=tint 1358 | sp.value:=res 1359 | steppc 1360 | 1361 | when kmin then ! Z' := min(Y, Z) 1362 | y:=sp-- 1363 | x:=sp 1364 | 1365 | save 1366 | if var_compare(x,y)<0 then !x is smaller 1367 | var_unshare(y) 1368 | else 1369 | var_unshare(x) 1370 | sp^:=y^ 1371 | fi 1372 | 1373 | steppc 1374 | 1375 | when kmax then ! Z' := max(Y, Z) 1376 | y:=sp-- 1377 | x:=sp 1378 | 1379 | save 1380 | if var_compare(x,y)>=0 then !x is bigger 1381 | var_unshare(y) 1382 | else 1383 | var_unshare(x) 1384 | sp^:=y^ 1385 | fi 1386 | steppc 1387 | 1388 | when kconcat then ! Z' := concat(Y, Z) or Y && Z 1389 | unimpl 1390 | steppc 1391 | 1392 | when kappend then ! Z' := append(Y, Z) or Y & Z 1393 | unimpl 1394 | steppc 1395 | 1396 | when ksame then ! Z' := Y == Z 1397 | y:=sp-- 1398 | x:=sp 1399 | 1400 | if x.hasref and y.hasref and x.objptr=y.objptr then 1401 | res:=1 1402 | else 1403 | res:=0 1404 | fi 1405 | 1406 | var_unshare(x) 1407 | var_unshare(y) 1408 | sp.tagx:=tint 1409 | sp.value:=res 1410 | 1411 | steppc 1412 | 1413 | when kpower then ! Z' := Y ** Z 1414 | y:=sp-- 1415 | copyvarv(vx, sp) 1416 | 1417 | save 1418 | var_power(sp, y) 1419 | 1420 | var_unshare(&vx) 1421 | var_unshare(y) 1422 | steppc 1423 | 1424 | when kbinto then ! Y^ op:= Z 1425 | y:=sp-- 1426 | x:=sp-- 1427 | 1428 | z:=x.varptr 1429 | if pc.bintoindex=1 and x.tag=trefvar and z.tag=y.tag=tint then 1430 | z.value+:=y.value 1431 | else 1432 | save 1433 | var_inplace(pc.bintoindex, x, y) 1434 | var_unshare(y) 1435 | fi 1436 | steppc 1437 | 1438 | when kandlto then ! Y^ and:= Z 1439 | unimpl 1440 | steppc 1441 | 1442 | when korlto then ! Y^ or:= Z 1443 | unimpl 1444 | steppc 1445 | 1446 | when kappendto then ! Y^ append:= Z or Y^ &:= Z 1447 | y:=sp-- 1448 | px:=sp-- 1449 | 1450 | case px.tag 1451 | when trefvar then 1452 | save 1453 | var_appendto(px.varptr, y) 1454 | else 1455 | pclustype("Appendto", px) 1456 | esac 1457 | steppc 1458 | 1459 | when kconcatto then ! Y^ concat:= Z or Y^ &&:= Z 1460 | y:=sp-- 1461 | px:=sp-- 1462 | 1463 | case px.tag 1464 | when trefvar then 1465 | save 1466 | var_concatto(px.varptr, y) 1467 | else 1468 | pclustype("Concatto", px) 1469 | esac 1470 | steppc 1471 | 1472 | when kdot then ! Z' := Z.g 1473 | save 1474 | k_dot(sp, pc.index) 1475 | steppc 1476 | 1477 | when kdot1 then ! Z' := Z.g 1478 | if sp.tag<>trecord then pclerror("Dot1: not rec") fi 1479 | 1480 | d:=genfieldtable[pc.index].def 1481 | 1482 | if sp.objptr.usertag<>d.owner.mode then pclerror("Dot1: wrong type") fi 1483 | x:=sp.objptr.varptr+d.fieldoffset/varsize 1484 | var_share(x) 1485 | var_unshare(sp) 1486 | copyvar(sp, x) 1487 | steppc 1488 | 1489 | when kpopdot then ! Z.g := Y 1490 | save 1491 | sp:=k_popdot(sp, pc.index) 1492 | steppc 1493 | 1494 | when kpopdot1 then ! Z.g := Y 1495 | x:=sp-- 1496 | y:=sp-- 1497 | 1498 | if x.tag<>trecord then pclerror("Popdot1: not rec") fi 1499 | if not x.objptr.mutable then 1500 | save 1501 | pcnotmut() 1502 | fi 1503 | e:=genfieldtable[pc.index].def 1504 | 1505 | if x.objptr.usertag<>e.owner.mode then pclerror("Popdot1: wrong type") fi 1506 | z:=x.objptr.varptr+e.fieldoffset/varsize 1507 | 1508 | var_unshare(z) 1509 | copyvar(z, y) 1510 | var_unshare(x) 1511 | steppc 1512 | 1513 | when kdotref then ! Z' := &Z.g 1514 | save 1515 | k_dotref(sp, pc.index) 1516 | steppc 1517 | 1518 | when kindex then ! Z' := Y[Z] 1519 | y:=sp-- 1520 | copyvarv(vx, sp) 1521 | 1522 | save 1523 | case y.tag 1524 | when tint then 1525 | var_getix(sp,y.value) 1526 | when trange then 1527 | var_getslice(sp,y.range_lower,y.range_upper) 1528 | else 1529 | pclmxtypes("Index",&vx,y) 1530 | esac 1531 | 1532 | var_unshare(&vx) 1533 | 1534 | steppc 1535 | 1536 | when kpopix then ! Z' := Y[Z]:=X 1537 | z:=sp-- !index 1538 | y:=sp-- !list etc 1539 | x:=sp-- !value to store 1540 | 1541 | save 1542 | case z.tag 1543 | when tint then 1544 | var_putix(y, z.value, x) 1545 | var_unshare(y) 1546 | when trange then 1547 | var_putslice(y, z.range_lower, z.range_upper, x) 1548 | var_unshare(x) 1549 | var_unshare(y) 1550 | else 1551 | pclmxtypes("Popix",y,z) 1552 | esac 1553 | 1554 | steppc 1555 | 1556 | when kindexref then ! Z' := &Y[Z] 1557 | y:=sp-- 1558 | copyvarv(vx, sp) 1559 | 1560 | save 1561 | case y.tag 1562 | when tint then 1563 | var_getixref(sp, y.value) 1564 | else 1565 | pclmxtypes("Indexref",sp,y) 1566 | esac 1567 | 1568 | var_unshare(&vx) 1569 | steppc 1570 | 1571 | when kkeyindex then ! Z' := X{Y, Z} 1572 | save 1573 | sp:=k_keyindex(sp) 1574 | steppc 1575 | 1576 | when kpopkeyix then ! Y{Z} := X 1577 | save 1578 | sp:=k_popkeyindex(sp) 1579 | steppc 1580 | 1581 | when kkeyixref then ! Z' := &X{Y, Z} 1582 | save 1583 | sp:=k_keyindexref(sp) 1584 | steppc 1585 | 1586 | when kdotix then ! Z' := Y.[Z] 1587 | y:=sp-- 1588 | copyvarv(vx, sp) 1589 | 1590 | save 1591 | case y.tag 1592 | when tint then 1593 | var_getdotix(sp, y.value) 1594 | when trange then 1595 | var_getdotslice(sp, y.range_lower, y.range_upper) 1596 | else 1597 | pcmxtypes("Dotindex", &vx, y) 1598 | esac 1599 | 1600 | var_unshare(&vx) 1601 | 1602 | steppc 1603 | 1604 | when kpopdotix then ! Y.[Z] := X 1605 | z:=sp-- !index 1606 | y:=sp-- !ref to int, string etc 1607 | x:=sp-- !value to store 1608 | 1609 | save 1610 | case z.tag 1611 | when tint then 1612 | var_putdotix(y, z.value, x) 1613 | var_unshare(y) 1614 | when trange then 1615 | var_putdotslice(y, z.range_lower, z.range_upper, x) 1616 | var_unshare(x) 1617 | var_unshare(y) 1618 | else 1619 | pclmxtypes("Popdotindex",y,z) 1620 | esac 1621 | 1622 | steppc 1623 | 1624 | when kdotixref then ! Z' := &Y.[Z] 1625 | unimpl 1626 | steppc 1627 | 1628 | when kexpand then ! Z' := Expand Z into n objects are needed 1629 | x:=sp+pc.n-1 1630 | save 1631 | var_expand(sp, x, pc.n) 1632 | sp:=x 1633 | 1634 | steppc 1635 | 1636 | when kpushtry then ! Push try/except into; label/except code/no. exceptions 1637 | (++sp).tagx:=texception 1638 | sp.ptr:=cast(pc.labelref) 1639 | sp.frameoffset:=fp-ref byte(sp) !byte offset 1640 | sp.exceptiontype:=pc.x 1641 | sp.nexceptions:=pc.y 1642 | steppc 1643 | 1644 | when kraise then ! Raise exception Z 1645 | if sp.tag<>tint then 1646 | pcerror("Raise: not Int") 1647 | fi 1648 | PCLERROR("RAISE") 1649 | ! pc:=raiseexception(sp.value, sp, fp) !will unwind stack and set pc to address of exception code 1650 | 1651 | when kmap then ! Z' := map(Y, Z) 1652 | save 1653 | pc:=k_map(sp, pc, newsp) 1654 | sp:=newsp 1655 | 1656 | when kaddsp then ! SP+:=A; note: positive A will push, negative will pop (reverse of the hardware) 1657 | sp-:=pc.n 1658 | steppc 1659 | 1660 | 1661 | when kpushff then ! Push f/f 1662 | ++sp 1663 | sp^:=cast(fp+pc.offset, variant)^ 1664 | var_share(sp) 1665 | ++sp 1666 | sp^:=cast(fp+(pc+1).offset, variant)^ 1667 | var_share(sp) 1668 | skip1 1669 | 1670 | when kpushfff then ! Push f/f/f 1671 | ++sp 1672 | copyvar(sp, cast(fp+pc.offset, variant)) 1673 | var_share(sp) 1674 | ++sp 1675 | copyvar(sp, cast(fp+(pc+1).offset, variant)) 1676 | var_share(sp) 1677 | ++sp 1678 | copyvar(sp, cast(fp+(pc+2).offset, variant)) 1679 | var_share(sp) 1680 | skip2 1681 | 1682 | when kpushmci then 1683 | ++sp 1684 | copyvar(sp, pc.varptr) 1685 | var_share(sp) 1686 | ++sp 1687 | sp.tagx:=tint 1688 | sp.value:=(pc+1).value 1689 | skip1 1690 | 1691 | when kpushfci then 1692 | ++sp 1693 | copyvar(sp, cast(fp+pc.offset, variant)) 1694 | var_share(sp) 1695 | ++sp 1696 | sp.tagx:=tint 1697 | sp.value:=(pc+1).value 1698 | skip1 1699 | 1700 | when kaddff then ! 1701 | x:=cast(fp+pc.offset, variant) 1702 | y:=cast(fp+(pc+1).offset, variant) 1703 | 1704 | if x.tag=y.tag=tint then 1705 | ++sp 1706 | sp.tagx:=tint 1707 | sp.value:=x.value+y.value 1708 | skip2 1709 | else 1710 | goto jpushf 1711 | fi 1712 | 1713 | when kaddfci then ! 1714 | x:=cast(fp+pc.offset, variant) 1715 | 1716 | if x.tag=tint then 1717 | ++sp 1718 | sp.tagx:=tint 1719 | sp.value:=x.value+(pc+1).value 1720 | skip2 1721 | else 1722 | goto jpushf 1723 | fi 1724 | 1725 | when kaddci then 1726 | if sp.tag=tint then 1727 | sp.value+:=pc.value 1728 | skip1 1729 | else 1730 | goto jpushci 1731 | fi 1732 | 1733 | when kmovefci then 1734 | x:=cast(fp+(pc+1).offset) 1735 | var_unshare(x) 1736 | x.tagx:=tint 1737 | x.value:=pc.value 1738 | skip1 1739 | 1740 | when kmoveff then 1741 | x:=cast(fp+(pc+1).offset) 1742 | y:=cast(fp+pc.offset) 1743 | var_share(y) 1744 | var_unshare(x) 1745 | copyvar(x, y) 1746 | skip1 1747 | 1748 | when kindexff then 1749 | x:=cast(fp+pc.offset) 1750 | doindexff: 1751 | y:=cast(fp+(pc+1).offset) 1752 | ++sp 1753 | copyvar(sp, x) 1754 | 1755 | save 1756 | case y.tag 1757 | when tint then 1758 | var_getix(sp, y.value) 1759 | when trange then 1760 | var_getslice(sp, y.range_lower, y.range_upper) 1761 | else 1762 | pclmxtypes("Indexff",x,y) 1763 | esac 1764 | skip2 1765 | 1766 | when kindexmf then 1767 | x:=pc.varptr 1768 | goto doindexff 1769 | 1770 | when kwheneqci then 1771 | x:=sp 1772 | if x.tag=tint then 1773 | if x.value=pc.value then 1774 | --sp 1775 | pc:=(pc+1).labelref 1776 | else 1777 | skip1 1778 | fi 1779 | else 1780 | goto jpushci 1781 | fi 1782 | 1783 | when kwhenneci then ! Y <> Z: pop Z only, jump to L 1784 | ! Y = Z: pop both, step to next 1785 | x:=sp 1786 | 1787 | if x.tag=tint then 1788 | if x.value<>pc.value then 1789 | pc:=(pc+1).labelref 1790 | else 1791 | --sp 1792 | skip1 1793 | fi 1794 | else 1795 | goto jpushci 1796 | fi 1797 | 1798 | when kupbm then 1799 | ++sp 1800 | copyvar(sp, pc.varptr) 1801 | var_share(sp) 1802 | save 1803 | k_upb(sp) 1804 | skip1 1805 | 1806 | when kpushipm then 1807 | x:=pc.varptr 1808 | if x.tag<>trefpack or x.elemtag<>tu8 then goto jpushmref fi 1809 | goto dopushipf 1810 | 1811 | when kpushipf then 1812 | x:=cast(fp+pc.offset) 1813 | if x.tag<>trefpack or x.elemtag<>tu8 then goto jpushfref fi 1814 | dopushipf: 1815 | ++sp 1816 | sp.tagx:=tint 1817 | case x.elemtag 1818 | when tu8 then 1819 | sp.value:=x.ptr^ 1820 | x.ptr+:=(pc+1).x 1821 | esac 1822 | skip2 1823 | 1824 | when kpopipm then 1825 | x:=pc.varptr 1826 | if x.tag<>trefpack or x.elemtag<>tu8 or sp.tag<>tint then goto jpushmref fi 1827 | goto dopopipf 1828 | 1829 | when kpopipf then 1830 | x:=cast(fp+pc.offset) 1831 | if x.tag<>trefpack or x.elemtag<>tu8 or sp.tag<>tint then goto jpushfref fi 1832 | dopopipf: 1833 | case x.elemtag 1834 | when tu8 then 1835 | x.ptr^:=sp.value 1836 | x.ptr+:=(pc+1).x 1837 | esac 1838 | --sp 1839 | skip2 1840 | 1841 | when klastpcl then ! needed for switchu when to trap unimpl extended ops 1842 | unimpl 1843 | else 1844 | unimpl: 1845 | pclerror2("Unimpl op:", pclnames[pc.opcode]) 1846 | stop 1 1847 | end 1848 | end 1849 | 1850 | global proc fixupcode(ifile pm)= 1851 | end 1852 | 1853 | global function runqprogram(isubprog sp, int ismain)int= 1854 | 1855 | return 0 when runcode= Z 394 | y:=sp-- 395 | x:=sp-- 396 | 397 | if x.tag=y.tag=tint then 398 | if x.value<>y.value then 399 | pc:=pc.labelref 400 | else 401 | steppc 402 | fi 403 | else 404 | save 405 | if not var_equal(x, y) then 406 | pc:=pc.labelref 407 | else 408 | steppc 409 | fi 410 | fi 411 | jumpnext 412 | 413 | jjumplt: ! Jump to L when Y < Z 414 | y:=sp-- 415 | x:=sp-- 416 | 417 | if x.tag=y.tag=tint then 418 | if x.value= Z 460 | y:=sp-- 461 | x:=sp-- 462 | 463 | if x.tag=y.tag=tint then 464 | if x.value>=y.value then 465 | pc:=pc.labelref 466 | else 467 | steppc 468 | fi 469 | else 470 | save 471 | if var_compare(x,y)>=0 then 472 | pc:=pc.labelref 473 | else 474 | steppc 475 | fi 476 | fi 477 | jumpnext 478 | 479 | jjumpgt: ! Jump to L when Y > Z 480 | y:=sp-- 481 | x:=sp-- 482 | 483 | if x.tag=y.tag=tint then 484 | if x.value>y.value then 485 | pc:=pc.labelref 486 | else 487 | steppc 488 | fi 489 | else 490 | save 491 | if var_compare(x,y)>0 then 492 | pc:=pc.labelref 493 | else 494 | steppc 495 | fi 496 | fi 497 | jumpnext 498 | 499 | jjmpeqfci: ! Jump to L when B = C 500 | x:=cast(fp+pc.offset) 501 | if x.tag<>tint then goto jpushf fi 502 | if x.value=(pc+1).value then 503 | pc:=(pc+2).labelref 504 | else 505 | skip2 506 | fi 507 | jumpnext 508 | 509 | jjmpnefci: ! Jump to L when B <> C 510 | x:=cast(fp+pc.offset) 511 | if x.tag<>tint then goto jpushf fi 512 | if x.value<>(pc+1).value then 513 | pc:=(pc+2).labelref 514 | else 515 | skip2 516 | fi 517 | jumpnext 518 | 519 | jjmpltfci: ! Jump to L when B < C 520 | x:=cast(fp+pc.offset) 521 | if x.tag<>tint then goto jpushf fi 522 | if x.value<(pc+1).value then 523 | pc:=(pc+2).labelref 524 | else 525 | skip2 526 | fi 527 | jumpnext 528 | 529 | jjmplefci: ! Jump to L when B <= C 530 | x:=cast(fp+pc.offset) 531 | if x.tag<>tint then goto jpushf fi 532 | if x.value<=(pc+1).value then 533 | pc:=(pc+2).labelref 534 | else 535 | skip2 536 | fi 537 | jumpnext 538 | 539 | jjmpgefci: ! Jump to L when B >= C 540 | x:=cast(fp+pc.offset) 541 | if x.tag<>tint then goto jpushf fi 542 | if x.value>=(pc+1).value then 543 | pc:=(pc+2).labelref 544 | else 545 | skip2 546 | fi 547 | jumpnext 548 | 549 | jjmpgtfci: ! Jump to L when B > C 550 | x:=cast(fp+pc.offset) 551 | if x.tag<>tint then goto jpushf fi 552 | if x.value>(pc+1).value then 553 | pc:=(pc+2).labelref 554 | else 555 | skip2 556 | fi 557 | jumpnext 558 | 559 | jjmpeqff: ! Jump to L when B = C 560 | x:=cast(fp+pc.offset) 561 | if x.tag<>tint then goto jpushf fi 562 | y:=cast(fp+(pc+1).offset) 563 | if x.value=y.value then 564 | pc:=(pc+2).labelref 565 | else 566 | skip2 567 | fi 568 | jumpnext 569 | 570 | jjmpneff: ! Jump to L when B <> C 571 | x:=cast(fp+pc.offset) 572 | if x.tag<>tint then goto jpushf fi 573 | y:=cast(fp+(pc+1).offset) 574 | if x.value<>y.value then 575 | pc:=(pc+2).labelref 576 | else 577 | skip2 578 | fi 579 | jumpnext 580 | 581 | jjmpltff: ! Jump to L when B < C 582 | x:=cast(fp+pc.offset) 583 | if x.tag<>tint then goto jpushf fi 584 | y:=cast(fp+(pc+1).offset) 585 | if x.valuetint then goto jpushf fi 595 | y:=cast(fp+(pc+1).offset) 596 | if x.value<=y.value then 597 | pc:=(pc+2).labelref 598 | else 599 | skip2 600 | fi 601 | jumpnext 602 | 603 | jjmpgeff: ! Jump to L when B >= C 604 | x:=cast(fp+pc.offset) 605 | if x.tag<>tint then goto jpushf fi 606 | y:=cast(fp+(pc+1).offset) 607 | if x.value>=y.value then 608 | pc:=(pc+2).labelref 609 | else 610 | skip2 611 | fi 612 | jumpnext 613 | 614 | jjmpgtff: ! Jump to L when B > C 615 | x:=cast(fp+pc.offset) 616 | if x.tag<>tint then goto jpushf fi 617 | y:=cast(fp+(pc+1).offset) 618 | if x.value>y.value then 619 | pc:=(pc+2).labelref 620 | else 621 | skip2 622 | fi 623 | jumpnext 624 | 625 | jwheneq: ! Y = Z: pop both, jump to L 626 | ! Y <> Z: pop Z only; don't jump 627 | y:=sp-- 628 | x:=sp 629 | 630 | if x.tag=y.tag=tint then 631 | if x.value=y.value then 632 | --sp 633 | pc:=pc.labelref 634 | else 635 | steppc 636 | fi 637 | else 638 | save 639 | res:=k_when(x, y) 640 | var_unshare(y) 641 | if res then 642 | var_unshare(x) 643 | --sp 644 | pc:=pc.labelref 645 | else 646 | steppc 647 | fi 648 | fi 649 | jumpnext 650 | 651 | jwhenne: ! Y <> Z: pop Z only, jump to L 652 | ! Y = Z: pop both, step to next 653 | y:=sp-- 654 | x:=sp 655 | 656 | if x.tag=y.tag=tint then 657 | if x.value<>y.value then 658 | pc:=pc.labelref 659 | else 660 | --sp 661 | steppc 662 | fi 663 | else 664 | save 665 | res:=k_when(x, y) 666 | var_unshare(y) 667 | if not res then 668 | pc:=pc.labelref 669 | else 670 | var_unshare(x) 671 | --sp 672 | steppc 673 | fi 674 | fi 675 | jumpnext 676 | 677 | jjumplab: ! Jumptable entry 678 | unimpl 679 | steppc 680 | jumpnext 681 | 682 | jswitch: ! Jumptable has y-x+1 entries 683 | lower:=pc.x 684 | n:=pc.y-lower+1 685 | 686 | case sp.tag 687 | when tint,ttype then 688 | else 689 | pclerror2("switch not int",ttname[sp.tag]) 690 | esac 691 | 692 | index:=sp.value-lower !now 0-based index 693 | ! 694 | --sp 695 | 696 | if u64(index)>=u64(n) then !out of range 697 | pc:=(pc+n+1).labelref 698 | else !in range 699 | pc:=(pc+index+1).labelref 700 | fi 701 | jumpnext 702 | 703 | jtom: ! --v; jump to l when v<>0 in next op 704 | x:=(pc+1).varptr 705 | doto 706 | 707 | jtof: ! --v; jump to l when v<>0 in next op 708 | x:=cast(fp+(pc+1).offset) 709 | doto: 710 | if --x.value then 711 | pc:=pc.labelref 712 | else 713 | skip1 714 | fi 715 | jumpnext 716 | 717 | jformci: ! ++v; jump to l when v<=i in next 2 ops: pushm/pushci 718 | x:=(pc+1).varptr 719 | doforfci 720 | 721 | jforfci: ! ++v; jump to l when v<=i in next 2 ops: pushm/pushci 722 | x:=cast(fp+(pc+1).offset) 723 | doforfci: 724 | ++x.value 725 | if x.value<=(pc+2).value then 726 | pc:=pc.labelref 727 | else 728 | skip2 729 | fi 730 | jumpnext 731 | 732 | jformm: ! ++v; jump to l when v<=v in next 2 ops 733 | x:=(pc+1).varptr 734 | y:=(pc+2).varptr 735 | doforff 736 | 737 | jforff: ! ++v; jump to l when v<=v in next 2 ops 738 | x:=cast(fp+(pc+1).offset) 739 | y:=cast(fp+(pc+2).offset) 740 | doforff: 741 | ++x.value 742 | 743 | if x.value<=y.value then 744 | pc:=pc.labelref 745 | else 746 | skip2 747 | fi 748 | jumpnext 749 | 750 | jcallproc: ! Call &A; n is no. args 751 | const countinterval=100 752 | static int count=countinterval 753 | 754 | if --count=0 then 755 | count:=countinterval 756 | os_peek() 757 | fi 758 | 759 | if sp>=stacklimit then 760 | pclerror("Stack Overflow") 761 | fi 762 | 763 | ++sp 764 | sp.tagx:=tretaddr 765 | sp.retaddr:= pc+1 766 | 767 | sp.frameptr_low:= u64(fp) 768 | fp:=cast(sp) 769 | 770 | pc:=pc.labelref 771 | jumpnext 772 | 773 | jcallptr: ! Call X^; n is no. of params supplied; x is stack adjust 774 | if sp.tag<>tsymbol then 775 | pclerror("Probably undefined function") 776 | fi 777 | 778 | d:=sp.def 779 | if d.nameid=linkid then d:=d.alias fi 780 | 781 | if d.nparams<>pc.n then 782 | pclerror2("Callptr: wrong # params; need:",strint(d.nparams)) 783 | fi 784 | 785 | sp.tagx:=tretaddr 786 | sp.retaddr:= pc+1 787 | 788 | sp.frameptr_low:= word(fp) 789 | fp:=cast(sp) 790 | 791 | pc:=cast(d.labelref) 792 | jumpnext 793 | 794 | jretproc: 795 | doretproc: 796 | to pc.x do 797 | var_unshare(sp) 798 | --sp 799 | od 800 | 801 | n:=pc.n 802 | pc:=sp.retaddr 803 | fp:= cast(u64(fp) iand (0xFFFF'FFFF'0000'0000) ior sp.frameptr_low) 804 | --sp 805 | 806 | to n do 807 | var_unshare(sp) 808 | --sp 809 | od 810 | jumpnext 811 | 812 | jretfn: 813 | x:=variant(fp+pc.y) 814 | copyvar(x, sp) !transfer reference 815 | --sp 816 | doretproc 817 | jumpnext 818 | 819 | jmodcall: ! 820 | d:=pc.def 821 | moduleno:=d.moduleno 822 | 823 | ++sp 824 | sp.tagx:=tretaddr 825 | sp.retaddr:= pc+1 826 | pc:=modules[moduleno].pcstart 827 | jumpnext 828 | 829 | jmodret: ! 830 | pc:=sp.retaddr 831 | jumpnext 832 | 833 | jcalldll: ! Call dll function d (sysmbol); n=nargs 834 | n:=pc.n 835 | save 836 | SPTR:=SP 837 | 838 | calldll(pc.def, sp-n+1, sp-n, n) 839 | sp-:=n 840 | 841 | steppc 842 | jumpnext 843 | 844 | jcallhost: ! Call Q host function h (Host index) 845 | save 846 | sp:=callhostfunction(pc.hostindex, sp) 847 | steppc 848 | jumpnext 849 | 850 | junshare: ! Unshare and pop A var values on stack 851 | to pc.n do 852 | var_unshare(sp) 853 | --sp 854 | od 855 | steppc 856 | jumpnext 857 | 858 | jstop: ! Stop program with stopcode Z; n=1 to stop runproc instead 859 | sptr:=sp 860 | return 861 | 862 | jmakelist: ! x items on stack; make list with lwb y 863 | save 864 | sp:=k_makelist(sp, pc.y, pc.x) 865 | steppc 866 | jumpnext 867 | 868 | jmakevrec: ! x items on stack; make record of type u 869 | n:=pc.x 870 | x:=sp-pc.x+1 !start of data 871 | 872 | save 873 | var_make_record(x, x, pc.x, pc.usertag) 874 | sp:=x 875 | sp.objptr.mutable:=0 876 | steppc 877 | jumpnext 878 | 879 | jmakeax: ! x items on stack; make array with lwb y, type u and elemtype v 880 | unimpl 881 | steppc 882 | jumpnext 883 | 884 | jmakebits: ! x items on stack; make bits with lwb y, type u and elemtype v 885 | unimpl 886 | steppc 887 | jumpnext 888 | 889 | jmaketrec: ! x items on stack; make struct with type u 890 | n:=pc.x 891 | x:=sp-n+1 !start of data 892 | 893 | save 894 | var_make_struct(x, x, n, pc.usertag) 895 | sp:=x 896 | sp.objptr.mutable:=0 897 | steppc 898 | jumpnext 899 | 900 | jmakeset: ! x items on stack; make set 901 | n:=pc.x 902 | 903 | x:=sp-n+1 !start of data 904 | 905 | save 906 | var_make_set(x, x, n) 907 | sp:=x 908 | sp.objptr.mutable:=0 909 | 910 | steppc 911 | jumpnext 912 | 913 | jmakerang: ! 2 items on stack; make range 914 | y:=sp-- 915 | x:=sp 916 | 917 | unless x.tag=y.tag=tint then 918 | pclerror("makerange/not int") 919 | end 920 | 921 | sp.tagx:=trange 922 | lower:=x.value 923 | upper:=y.value 924 | 925 | if lower not in -(2**48)..2**48-1 then 926 | pclerror("Range lwb bounds") 927 | end 928 | 929 | sp.range_upper:=upper 930 | sp.range_lower:=lower 931 | 932 | steppc 933 | jumpnext 934 | 935 | jmakedict: ! x*2 items on stack (x key:val items); make dict 936 | n:=pc.x 937 | x:=sp-n*2+1 !start of data 938 | 939 | save 940 | var_make_dict(x, x, n) 941 | sp:=x 942 | steppc 943 | jumpnext 944 | 945 | jmakedec: ! Turn string on stack to decimal number 946 | copyvarv(vx, sp) 947 | 948 | if vx.tag<>tstring then pclerror("Not str") fi 949 | pp:=vx.objptr 950 | if pp.length=0 then pclerror("Null str") fi 951 | 952 | save 953 | var_make_dec_str(pp.strptr, pp.length, sp) 954 | 955 | var_unshare(&vx) 956 | 957 | steppc 958 | jumpnext 959 | 960 | jincrptr: ! Z^ +:= x 961 | save 962 | k_incrptr(sp, pc.x) 963 | --sp 964 | steppc 965 | jumpnext 966 | 967 | jincrtom: ! v +:= x 968 | x:=pc.varptr 969 | doincrto 970 | 971 | jincrtof: ! v +:= x 972 | x:=cast(fp+pc.offset) 973 | doincrto: 974 | case x.tag 975 | when tint then 976 | x.value+:=pc.x 977 | when trefvar then 978 | x.varptr+:=pc.x 979 | when trefpack then 980 | x.ptr+:=ttsize[x.elemtag]*pc.x 981 | when treal then 982 | x.xvalue+:=pc.x 983 | else 984 | pclustype("incrto",x) 985 | end 986 | 987 | steppc 988 | jincrtofx: 989 | jumpnext 990 | 991 | jloadincr: ! T:= Z^; Z^ +:= x; Z':= T 992 | copyvarv(vx, sp) 993 | save 994 | var_loadptr(sp,sp) 995 | ++sp 996 | copyvar_v(sp, vx) 997 | k_incrptr(sp, pc.x) 998 | --sp 999 | steppc 1000 | jumpnext 1001 | 1002 | jincrload: ! Z^ +:= x; Z':= Z^ 1003 | copyvarv(vx, sp) 1004 | save 1005 | k_incrptr(sp, pc.x) 1006 | --sp 1007 | var_loadptr(&vx, ++sp) 1008 | steppc 1009 | jumpnext 1010 | 1011 | jneg: ! Z':= -Z 1012 | copyvarv(vx, sp) 1013 | save 1014 | var_neg(sp) 1015 | var_unshare(&vx) 1016 | steppc 1017 | jumpnext 1018 | 1019 | jabs: ! Z':= abs Z 1020 | copyvarv(vx, sp) 1021 | 1022 | save 1023 | var_abs(sp) 1024 | var_unshare(&vx) 1025 | 1026 | steppc 1027 | jumpnext 1028 | 1029 | jnotl: ! Z':= not Z 1030 | save 1031 | res:=not var_istruel(sp) 1032 | var_unshare(sp) 1033 | sp.tagx:=tint 1034 | sp.value:=res 1035 | steppc 1036 | jumpnext 1037 | 1038 | jinot: ! Z':= inot Z 1039 | if sp.tag=tint then 1040 | sp.value:=inot sp.value 1041 | else 1042 | copyvarv(vx, sp) 1043 | save 1044 | var_inot(sp) 1045 | var_unshare(&vx) 1046 | fi 1047 | 1048 | steppc 1049 | jumpnext 1050 | 1051 | jistruel: ! Z':= istrue Z 1052 | save 1053 | n:=var_istruel(sp) 1054 | var_unshare(sp) 1055 | sp.tagx:=tint 1056 | sp.value:=n 1057 | 1058 | steppc 1059 | jumpnext 1060 | 1061 | jasc: ! Z':= asc(Z) 1062 | case sp.tag 1063 | when tstring then 1064 | if sp.objptr.length then 1065 | n:=sp.objptr.strptr^ 1066 | else 1067 | n:=0 1068 | fi 1069 | var_unshareu(sp) 1070 | sp.tagx:=tint 1071 | sp.value:=n 1072 | else 1073 | pcustype("ASC",sp) 1074 | esac 1075 | steppc 1076 | jumpnext 1077 | 1078 | jchr: ! Z':= chr(Z) 1079 | if sp.tag=tint then 1080 | save 1081 | var_makechar(sp.value, sp) 1082 | else 1083 | pclustype("CHR",sp) 1084 | fi 1085 | steppc 1086 | jumpnext 1087 | 1088 | jsqr: ! Z':= op(Z) 1089 | case sp.tag 1090 | when tint then 1091 | sp.value:=sqr(sp.value) 1092 | when treal then 1093 | sp.xvalue:=sqr(sp.xvalue) 1094 | else 1095 | pclustype("sqr", sp) 1096 | esac 1097 | steppc 1098 | jumpnext 1099 | 1100 | jmaths: ! Z':= op(Z) 1101 | save 1102 | k_maths(sp, pc.mathscode) 1103 | steppc 1104 | jumpnext 1105 | 1106 | jmaths2: ! Z':= op(Y, Z) 1107 | unimpl 1108 | steppc 1109 | jumpnext 1110 | 1111 | junaryto: ! Z^ op:= Z 1112 | unimpl 1113 | steppc 1114 | jumpnext 1115 | 1116 | jnotlto: ! Z^ not:= Z 1117 | unimpl 1118 | steppc 1119 | jumpnext 1120 | 1121 | jlen: ! Z':= Z.len 1122 | save 1123 | k_len(sp) 1124 | steppc 1125 | jumpnext 1126 | 1127 | jlwb: ! Z':= Z.lwb 1128 | save 1129 | k_lwb(sp) 1130 | steppc 1131 | jumpnext 1132 | 1133 | jupb: ! Z':= Z.upb 1134 | save 1135 | k_upb(sp) 1136 | steppc 1137 | jumpnext 1138 | 1139 | jbounds: ! Z':= Z.bounds; n=1: one range value; n=2: two dims 1140 | save 1141 | k_bounds(sp, lower, upper) 1142 | 1143 | if pc.n=2 then !push as 2 value 1144 | var_unshare(sp) 1145 | sp.tagx:=tint 1146 | sp.value:=lower 1147 | ++sp 1148 | sp.tagx:=tint 1149 | sp.value:=upper 1150 | 1151 | else !push as 1 range value 1152 | var_unshare(sp) 1153 | sp.tagx:=trange 1154 | sp.range_lower:=lower 1155 | sp.range_upper:=upper 1156 | fi 1157 | 1158 | steppc 1159 | jumpnext 1160 | 1161 | jbytesize: ! Z':= Z.bytesize 1162 | save 1163 | res:=k_bytesize(sp) 1164 | var_unshare(sp) 1165 | sp.tagx:=tint 1166 | sp.value:=res 1167 | steppc 1168 | jumpnext 1169 | 1170 | jtype: ! Z':= n=0/1/2 = basetype/tag/elemtype 1171 | save 1172 | n:=k_type(sp, pc.n) 1173 | var_unshare(sp) 1174 | sp.tagx:=ttype 1175 | sp.value:=n 1176 | 1177 | steppc 1178 | jumpnext 1179 | 1180 | jdictsize: ! Z':= Z.dictsize 1181 | unimpl 1182 | steppc 1183 | jumpnext 1184 | 1185 | jisfound: ! Z':= Z.isfound 1186 | if sp.tag<>tint then pclerror("isfound") fi 1187 | sp.value:=sp.value<>i64.min 1188 | steppc 1189 | jumpnext 1190 | 1191 | jminval: ! Z':= Z.minvalue 1192 | unimpl 1193 | steppc 1194 | jumpnext 1195 | 1196 | jmaxval: ! Z':= Z.maxvalue 1197 | unimpl 1198 | steppc 1199 | jumpnext 1200 | 1201 | jistype: ! Z':= Z.type/etc = t 1202 | n:=0 1203 | if pc.typecode=trefvar then 1204 | if sp.tag in [trefvar, trefpack, trefbit] then n:=1 fi 1205 | else 1206 | if pc.typecode=sp.tag then n:=1 fi 1207 | fi 1208 | var_unshare(sp) 1209 | sp.tagx:=tint 1210 | sp.value:=n 1211 | steppc 1212 | jumpnext 1213 | 1214 | jisvoid: ! Z':= Z.isvoid (n=0) or not Z.isdef (n=1) 1215 | res:=sp.tag=tvoid 1216 | var_unshare(sp) 1217 | sp.tagx:=tint 1218 | sp.value:=res ixor pc.n 1219 | steppc 1220 | jumpnext 1221 | 1222 | jconvert: ! Z':= t(Z) 1223 | if sp.tag<>pc.usertag then 1224 | ! vx:=sp^ 1225 | copyvarv(vx, sp) 1226 | save 1227 | var_convert(&vx, pc.usertag, sp) 1228 | var_unshare(&vx) 1229 | fi 1230 | 1231 | steppc 1232 | jumpnext 1233 | 1234 | jtypepun: ! Z':= t@(Z) 1235 | unimpl 1236 | steppc 1237 | jumpnext 1238 | 1239 | jadd: ! Z':= Y + Z 1240 | y:=sp-- 1241 | 1242 | if sp.tag=y.tag=tint then 1243 | sp.value+:=y.value 1244 | elsif sp.tag=y.tag=treal then 1245 | sp.xvalue+:=y.xvalue 1246 | else 1247 | ! vx:=sp^ 1248 | copyvarv(vx, sp) 1249 | 1250 | save 1251 | var_add(sp, y) 1252 | 1253 | var_unshare(&vx) 1254 | var_unshare(y) 1255 | fi 1256 | steppc 1257 | jumpnext 1258 | 1259 | jsub: ! Z':= Y - Z 1260 | y:=sp-- 1261 | 1262 | if sp.tag=y.tag=tint then 1263 | sp.value-:=y.value 1264 | elsif sp.tag=y.tag=treal then 1265 | sp.xvalue-:=y.xvalue 1266 | else 1267 | ! vx:=sp^ 1268 | copyvarv(vx, sp) 1269 | 1270 | save 1271 | var_sub(sp, y) 1272 | 1273 | var_unshare(&vx) 1274 | var_unshare(y) 1275 | fi 1276 | steppc 1277 | jumpnext 1278 | 1279 | jmul: ! Z':= Y * Z 1280 | y:=sp-- 1281 | 1282 | if sp.tag=y.tag=tint then 1283 | sp.value*:=y.value 1284 | elsif sp.tag=y.tag=treal then 1285 | sp.xvalue*:=y.xvalue 1286 | else 1287 | copyvarv(vx, sp) 1288 | 1289 | save 1290 | var_mul(sp,y) 1291 | 1292 | var_unshare(&vx) 1293 | var_unshare(y) 1294 | fi 1295 | 1296 | steppc 1297 | jumpnext 1298 | 1299 | jdiv: ! Z':= Y / Z 1300 | y:=sp-- 1301 | copyvarv(vx, sp) 1302 | 1303 | if sp.tag=y.tag=treal then 1304 | sp.xvalue/:=y.xvalue 1305 | else 1306 | save 1307 | var_div(sp,y) 1308 | 1309 | var_unshare(&vx) 1310 | var_unshare(y) 1311 | fi 1312 | 1313 | steppc 1314 | jumpnext 1315 | 1316 | jidiv: ! Z':= Y % Z 1317 | y:=sp-- 1318 | copyvarv(vx, sp) 1319 | 1320 | if sp.tag=y.tag=tint then 1321 | sp.value/:=y.value 1322 | else 1323 | save 1324 | var_idiv(sp, y) 1325 | 1326 | var_unshare(&vx) 1327 | var_unshare(y) 1328 | fi 1329 | 1330 | 1331 | steppc 1332 | jumpnext 1333 | 1334 | jirem: ! Z':= Y rem Z 1335 | y:=sp-- 1336 | copyvarv(vx, sp) 1337 | 1338 | save 1339 | var_irem(sp,y) 1340 | 1341 | var_unshare(&vx) 1342 | var_unshare(y) 1343 | 1344 | steppc 1345 | jumpnext 1346 | 1347 | jidivrem: ! (Y', Z'):= Y divrem Z 1348 | unimpl 1349 | steppc 1350 | jumpnext 1351 | 1352 | jiand: ! Z':= Y iand Z 1353 | y:=sp-- 1354 | 1355 | if sp.tag=y.tag=tint then 1356 | sp.value iand:=y.value 1357 | else 1358 | ! vx:=sp^ 1359 | copyvarv(vx, sp) 1360 | save 1361 | var_iand(sp,y) 1362 | 1363 | var_unshare(&vx) 1364 | var_unshare(y) 1365 | fi 1366 | steppc 1367 | jumpnext 1368 | 1369 | jior: ! Z':= Y ior Z 1370 | y:=sp-- 1371 | 1372 | if sp.tag=y.tag=tint then 1373 | sp.value ior:=y.value 1374 | else 1375 | ! vx:=sp^ 1376 | copyvarv(vx, sp) 1377 | save 1378 | var_ior(sp,y) 1379 | 1380 | var_unshare(&vx) 1381 | var_unshare(y) 1382 | fi 1383 | steppc 1384 | jumpnext 1385 | 1386 | jixor: ! Z':= Y ixor Z 1387 | y:=sp-- 1388 | if sp.tag=y.tag=tint then 1389 | sp.value ixor:=y.value 1390 | else 1391 | ! vx:=sp^ 1392 | copyvarv(vx, sp) 1393 | 1394 | save 1395 | var_ixor(sp,y) 1396 | 1397 | var_unshare(&vx) 1398 | var_unshare(y) 1399 | fi 1400 | steppc 1401 | jumpnext 1402 | 1403 | jshl: ! Z':= Y << Z 1404 | y:=sp-- 1405 | 1406 | if sp.tag=y.tag=tint then 1407 | sp.value <<:=y.value 1408 | else 1409 | ! vx:=sp^ 1410 | copyvarv(vx, sp) 1411 | 1412 | save 1413 | var_shl(sp,y) 1414 | 1415 | var_unshare(&vx) 1416 | var_unshare(y) 1417 | fi 1418 | steppc 1419 | jumpnext 1420 | 1421 | jshr: ! Z':= Y >> Z 1422 | y:=sp-- 1423 | 1424 | if sp.tag=y.tag=tint then 1425 | sp.value >>:=y.value 1426 | else 1427 | ! vx:=sp^ 1428 | copyvarv(vx, sp) 1429 | 1430 | save 1431 | var_shr(sp,y) 1432 | 1433 | var_unshare(&vx) 1434 | var_unshare(y) 1435 | fi 1436 | steppc 1437 | jumpnext 1438 | 1439 | jin: ! Z':= Y in Z (n=0) or Y not in Z (n=1) 1440 | y:=sp 1441 | x:=--sp 1442 | 1443 | save 1444 | n:=var_in(x,y) ixor pc.n 1445 | var_unshare(x) 1446 | var_unshare(y) 1447 | 1448 | sp.tagx:=tint 1449 | sp.value:=n 1450 | steppc 1451 | jumpnext 1452 | 1453 | jinx: ! Z':= Y inx Z 1454 | y:=sp 1455 | x:=--sp 1456 | 1457 | save 1458 | n:=var_inx(x,y) 1459 | var_unshare(x) 1460 | var_unshare(y) 1461 | 1462 | sp.tagx:=tint 1463 | sp.value:=n 1464 | 1465 | steppc 1466 | jumpnext 1467 | 1468 | jcmp: ! Z':= Y c Z 1469 | y:=sp 1470 | x:=--sp 1471 | 1472 | save 1473 | res:=k_cmp(pc.n, x, y) 1474 | var_unshare(x) 1475 | var_unshare(y) 1476 | 1477 | sp.tagx:=tint 1478 | sp.value:=res 1479 | steppc 1480 | jumpnext 1481 | 1482 | jmin: ! Z':= min(Y, Z) 1483 | y:=sp-- 1484 | x:=sp 1485 | 1486 | save 1487 | if var_compare(x,y)<0 then !x is smaller 1488 | var_unshare(y) 1489 | else 1490 | var_unshare(x) 1491 | sp^:=y^ 1492 | fi 1493 | 1494 | steppc 1495 | jumpnext 1496 | 1497 | jmax: ! Z':= max(Y, Z) 1498 | y:=sp-- 1499 | x:=sp 1500 | 1501 | save 1502 | if var_compare(x,y)>=0 then !x is bigger 1503 | var_unshare(y) 1504 | else 1505 | var_unshare(x) 1506 | sp^:=y^ 1507 | fi 1508 | steppc 1509 | jumpnext 1510 | 1511 | jconcat: ! Z':= concat(Y, Z) or Y && Z 1512 | unimpl 1513 | steppc 1514 | jumpnext 1515 | 1516 | jappend: ! Z':= append(Y, Z) or Y & Z 1517 | unimpl 1518 | steppc 1519 | jumpnext 1520 | 1521 | jsame: ! Z':= Y == Z 1522 | y:=sp-- 1523 | x:=sp 1524 | 1525 | if x.hasref and y.hasref and x.objptr=y.objptr then 1526 | res:=1 1527 | else 1528 | res:=0 1529 | fi 1530 | 1531 | var_unshare(x) 1532 | var_unshare(y) 1533 | sp.tagx:=tint 1534 | sp.value:=res 1535 | 1536 | steppc 1537 | jumpnext 1538 | 1539 | jpower: ! Z':= Y ** Z 1540 | y:=sp-- 1541 | copyvarv(vx, sp) 1542 | 1543 | save 1544 | var_power(sp, y) 1545 | 1546 | var_unshare(&vx) 1547 | var_unshare(y) 1548 | steppc 1549 | jumpnext 1550 | 1551 | jbinto: ! Y^ op:= Z 1552 | y:=sp-- 1553 | x:=sp-- 1554 | 1555 | z:=x.varptr 1556 | if pc.bintoindex=1 and x.tag=trefvar and z.tag=y.tag=tint then 1557 | z.value+:=y.value 1558 | else 1559 | save 1560 | var_inplace(pc.bintoindex, x, y) 1561 | var_unshare(y) 1562 | fi 1563 | steppc 1564 | jumpnext 1565 | 1566 | jandlto: ! Y^ and:= Z 1567 | unimpl 1568 | steppc 1569 | jumpnext 1570 | 1571 | jorlto: ! Y^ or:= Z 1572 | unimpl 1573 | steppc 1574 | jumpnext 1575 | 1576 | jappendto: ! Y^ append:= Z or Y^ &:= Z 1577 | y:=sp-- 1578 | px:=sp-- 1579 | 1580 | case px.tag 1581 | when trefvar then 1582 | save 1583 | var_appendto(px.varptr, y) 1584 | else 1585 | pclustype("Appendto", px) 1586 | esac 1587 | steppc 1588 | jumpnext 1589 | 1590 | jconcatto: ! Y^ concat:= Z or Y^ &&:= Z 1591 | y:=sp-- 1592 | px:=sp-- 1593 | 1594 | case px.tag 1595 | when trefvar then 1596 | save 1597 | var_concatto(px.varptr, y) 1598 | else 1599 | pclustype("Concatto", px) 1600 | esac 1601 | steppc 1602 | jumpnext 1603 | 1604 | jdot: ! Z':= Z.g 1605 | save 1606 | k_dot(sp, pc.index) 1607 | steppc 1608 | jumpnext 1609 | 1610 | jdot1: ! Z':= Z.g 1611 | if sp.tag<>trecord then pclerror("Dot1: not rec") fi 1612 | 1613 | d:=genfieldtable[pc.index].def 1614 | 1615 | if sp.objptr.usertag<>d.owner.mode then pclerror("Dot1: wrong type") fi 1616 | x:=sp.objptr.varptr+d.fieldoffset/varsize 1617 | var_share(x) 1618 | var_unshare(sp) 1619 | copyvar(sp, x) 1620 | steppc 1621 | jumpnext 1622 | 1623 | jpopdot: ! Z.g:= Y 1624 | save 1625 | sp:=k_popdot(sp, pc.index) 1626 | steppc 1627 | jumpnext 1628 | 1629 | jpopdot1: ! Z.g:= Y 1630 | x:=sp-- 1631 | y:=sp-- 1632 | 1633 | if x.tag<>trecord then pclerror("Popdot1: not rec") fi 1634 | if not x.objptr.mutable then 1635 | save 1636 | pcnotmut() 1637 | fi 1638 | e:=genfieldtable[pc.index].def 1639 | 1640 | if x.objptr.usertag<>e.owner.mode then pclerror("Popdot1: wrong type") fi 1641 | z:=x.objptr.varptr+e.fieldoffset/varsize 1642 | 1643 | var_unshare(z) 1644 | copyvar(z, y) 1645 | var_unshare(x) 1646 | steppc 1647 | jumpnext 1648 | 1649 | jdotref: ! Z':= &Z.g 1650 | save 1651 | k_dotref(sp, pc.index) 1652 | steppc 1653 | jumpnext 1654 | 1655 | jindex: ! Z':= Y[Z] 1656 | y:=sp-- 1657 | copyvarv(vx, sp) 1658 | 1659 | save 1660 | case y.tag 1661 | when tint then 1662 | var_getix(sp,y.value) 1663 | when trange then 1664 | var_getslice(sp,y.range_lower,y.range_upper) 1665 | else 1666 | pclmxtypes("Index",&vx,y) 1667 | esac 1668 | 1669 | var_unshare(&vx) 1670 | 1671 | steppc 1672 | jumpnext 1673 | 1674 | jpopix: ! Z':= Y[Z]:=X 1675 | z:=sp-- !index 1676 | y:=sp-- !list etc 1677 | x:=sp-- !value to store 1678 | 1679 | save 1680 | case z.tag 1681 | when tint then 1682 | var_putix(y, z.value, x) 1683 | var_unshare(y) 1684 | when trange then 1685 | var_putslice(y, z.range_lower, z.range_upper, x) 1686 | var_unshare(x) 1687 | var_unshare(y) 1688 | else 1689 | pclmxtypes("Popix",y,z) 1690 | esac 1691 | 1692 | steppc 1693 | jumpnext 1694 | 1695 | jindexref: ! Z':= &Y[Z] 1696 | y:=sp-- 1697 | copyvarv(vx, sp) 1698 | 1699 | save 1700 | case y.tag 1701 | when tint then 1702 | var_getixref(sp, y.value) 1703 | else 1704 | pclmxtypes("Indexref",sp,y) 1705 | esac 1706 | 1707 | var_unshare(&vx) 1708 | steppc 1709 | jumpnext 1710 | 1711 | jkeyindex: ! Z':= X{Y, Z} 1712 | save 1713 | sp:=k_keyindex(sp) 1714 | steppc 1715 | jumpnext 1716 | 1717 | jpopkeyix: ! Y{Z}:= X 1718 | save 1719 | sp:=k_popkeyindex(sp) 1720 | steppc 1721 | jumpnext 1722 | 1723 | jkeyixref: ! Z':= &X{Y, Z} 1724 | save 1725 | sp:=k_keyindexref(sp) 1726 | steppc 1727 | jumpnext 1728 | 1729 | jdotix: ! Z':= Y.[Z] 1730 | y:=sp-- 1731 | copyvarv(vx, sp) 1732 | 1733 | save 1734 | case y.tag 1735 | when tint then 1736 | var_getdotix(sp, y.value) 1737 | when trange then 1738 | var_getdotslice(sp, y.range_lower, y.range_upper) 1739 | else 1740 | pcmxtypes("Dotindex", &vx, y) 1741 | esac 1742 | 1743 | var_unshare(&vx) 1744 | 1745 | steppc 1746 | jumpnext 1747 | 1748 | jpopdotix: ! Y.[Z]:= X 1749 | z:=sp-- !index 1750 | y:=sp-- !ref to int, string etc 1751 | x:=sp-- !value to store 1752 | 1753 | save 1754 | case z.tag 1755 | when tint then 1756 | var_putdotix(y, z.value, x) 1757 | var_unshare(y) 1758 | when trange then 1759 | var_putdotslice(y, z.range_lower, z.range_upper, x) 1760 | var_unshare(x) 1761 | var_unshare(y) 1762 | else 1763 | pclmxtypes("Popdotindex",y,z) 1764 | esac 1765 | 1766 | steppc 1767 | jumpnext 1768 | 1769 | jdotixref: ! Z':= &Y.[Z] 1770 | unimpl 1771 | steppc 1772 | jumpnext 1773 | 1774 | jexpand: ! Z':= Expand Z into n objects are needed 1775 | x:=sp+pc.n-1 1776 | save 1777 | var_expand(sp, x, pc.n) 1778 | sp:=x 1779 | 1780 | steppc 1781 | jumpnext 1782 | 1783 | jpushtry: ! Push try/except into; label/except code/no. exceptions 1784 | (++sp).tagx:=texception 1785 | sp.ptr:=cast(pc.labelref) 1786 | sp.frameoffset:=fp-ref byte(sp) !byte offset 1787 | sp.exceptiontype:=pc.x 1788 | sp.nexceptions:=pc.y 1789 | steppc 1790 | jumpnext 1791 | 1792 | jraise: ! Raise exception Z 1793 | if sp.tag<>tint then 1794 | pcerror("Raise: not Int") 1795 | fi 1796 | PCLERROR("RAISE") 1797 | ! pc:=raiseexception(sp.value, sp, fp) !will unwind stack and set pc to address of exception code 1798 | jumpnext 1799 | 1800 | jmap: ! Z':= map(Y, Z) 1801 | save 1802 | pc:=k_map(sp, pc, newsp) 1803 | sp:=newsp 1804 | jumpnext 1805 | 1806 | jaddsp: ! SP+:=A; note: positive A will push, negative will pop (reverse of the hardware) 1807 | sp-:=pc.n 1808 | steppc 1809 | 1810 | jumpnext 1811 | 1812 | jpushff: ! Push f/f 1813 | ++sp 1814 | sp^:=cast(fp+pc.offset, variant)^ 1815 | var_share(sp) 1816 | ++sp 1817 | sp^:=cast(fp+(pc+1).offset, variant)^ 1818 | var_share(sp) 1819 | skip1 1820 | jumpnext 1821 | 1822 | jpushfff: ! Push f/f/f 1823 | ++sp 1824 | copyvar(sp, cast(fp+pc.offset, variant)) 1825 | var_share(sp) 1826 | ++sp 1827 | copyvar(sp, cast(fp+(pc+1).offset, variant)) 1828 | var_share(sp) 1829 | ++sp 1830 | copyvar(sp, cast(fp+(pc+2).offset, variant)) 1831 | var_share(sp) 1832 | skip2 1833 | jumpnext 1834 | 1835 | jpushmci: 1836 | ++sp 1837 | copyvar(sp, pc.varptr) 1838 | var_share(sp) 1839 | ++sp 1840 | sp.tagx:=tint 1841 | sp.value:=(pc+1).value 1842 | skip1 1843 | jumpnext 1844 | 1845 | jpushfci: 1846 | ++sp 1847 | copyvar(sp, cast(fp+pc.offset, variant)) 1848 | var_share(sp) 1849 | ++sp 1850 | sp.tagx:=tint 1851 | sp.value:=(pc+1).value 1852 | skip1 1853 | jumpnext 1854 | 1855 | jaddff: ! 1856 | x:=cast(fp+pc.offset, variant) 1857 | y:=cast(fp+(pc+1).offset, variant) 1858 | 1859 | if x.tag=y.tag=tint then 1860 | ++sp 1861 | sp.tagx:=tint 1862 | sp.value:=x.value+y.value 1863 | skip2 1864 | else 1865 | goto jpushf 1866 | fi 1867 | jumpnext 1868 | 1869 | jaddfci: ! 1870 | x:=cast(fp+pc.offset, variant) 1871 | 1872 | if x.tag=tint then 1873 | ++sp 1874 | sp.tagx:=tint 1875 | sp.value:=x.value+(pc+1).value 1876 | skip2 1877 | else 1878 | goto jpushf 1879 | fi 1880 | jumpnext 1881 | 1882 | jaddci: 1883 | if sp.tag=tint then 1884 | sp.value+:=pc.value 1885 | skip1 1886 | else 1887 | goto jpushci 1888 | fi 1889 | jumpnext 1890 | 1891 | jmovefci: 1892 | x:=cast(fp+(pc+1).offset) 1893 | var_unshare(x) 1894 | x.tagx:=tint 1895 | x.value:=pc.value 1896 | skip1 1897 | jumpnext 1898 | 1899 | jmoveff: 1900 | x:=cast(fp+(pc+1).offset) 1901 | y:=cast(fp+pc.offset) 1902 | var_share(y) 1903 | var_unshare(x) 1904 | copyvar(x, y) 1905 | skip1 1906 | jumpnext 1907 | 1908 | jindexff: 1909 | x:=cast(fp+pc.offset) 1910 | doindexff: 1911 | y:=cast(fp+(pc+1).offset) 1912 | ++sp 1913 | copyvar(sp, x) 1914 | 1915 | save 1916 | case y.tag 1917 | when tint then 1918 | var_getix(sp, y.value) 1919 | when trange then 1920 | var_getslice(sp, y.range_lower, y.range_upper) 1921 | else 1922 | pclmxtypes("Indexff",x,y) 1923 | esac 1924 | skip2 1925 | jumpnext 1926 | 1927 | jindexmf: 1928 | x:=pc.varptr 1929 | goto doindexff 1930 | 1931 | jwheneqci: 1932 | x:=sp 1933 | if x.tag=tint then 1934 | if x.value=pc.value then 1935 | --sp 1936 | pc:=(pc+1).labelref 1937 | else 1938 | skip1 1939 | fi 1940 | else 1941 | goto jpushci 1942 | fi 1943 | jumpnext 1944 | 1945 | jwhenneci: ! Y <> Z: pop Z only, jump to L 1946 | ! Y = Z: pop both, step to next 1947 | x:=sp 1948 | 1949 | if x.tag=tint then 1950 | if x.value<>pc.value then 1951 | pc:=(pc+1).labelref 1952 | else 1953 | --sp 1954 | skip1 1955 | fi 1956 | else 1957 | goto jpushci 1958 | fi 1959 | jumpnext 1960 | 1961 | jupbm: 1962 | ++sp 1963 | copyvar(sp, pc.varptr) 1964 | var_share(sp) 1965 | save 1966 | k_upb(sp) 1967 | skip1 1968 | jumpnext 1969 | 1970 | jpushipm: 1971 | x:=pc.varptr 1972 | if x.tag<>trefpack or x.elemtag<>tu8 then goto jpushmref fi 1973 | goto dopushipf 1974 | 1975 | jpushipf: 1976 | x:=cast(fp+pc.offset) 1977 | if x.tag<>trefpack or x.elemtag<>tu8 then goto jpushfref fi 1978 | dopushipf: 1979 | ++sp 1980 | sp.tagx:=tint 1981 | case x.elemtag 1982 | when tu8 then 1983 | sp.value:=x.ptr^ 1984 | x.ptr+:=(pc+1).x 1985 | esac 1986 | skip2 1987 | jumpnext 1988 | 1989 | jpopipm: 1990 | x:=pc.varptr 1991 | if x.tag<>trefpack or x.elemtag<>tu8 or sp.tag<>tint then goto jpushmref fi 1992 | goto dopopipf 1993 | 1994 | jpopipf: 1995 | x:=cast(fp+pc.offset) 1996 | if x.tag<>trefpack or x.elemtag<>tu8 or sp.tag<>tint then goto jpushfref fi 1997 | dopopipf: 1998 | case x.elemtag 1999 | when tu8 then 2000 | x.ptr^:=sp.value 2001 | x.ptr+:=(pc+1).x 2002 | esac 2003 | --sp 2004 | skip2 2005 | jumpnext 2006 | 2007 | jlastpcl: 2008 | jpushmm: 2009 | jpushmf: 2010 | jpushfm: 2011 | jmovemm: 2012 | jmovefm: 2013 | jmovemf: 2014 | jzmoveff: 2015 | jzmovemci: 2016 | jzmovefci: 2017 | jmovemci: 2018 | jpushv2: 2019 | jpushv3: 2020 | jsubfci: 2021 | jsubff: 2022 | jswitchf: 2023 | jupbf: 2024 | jlenf: 2025 | jstoref: 2026 | 2027 | unimpl: 2028 | pclerror2("Unimpl op:", pclnames[pc.opcode]) 2029 | stop 1 2030 | end 2031 | 2032 | proc start= 2033 | !set up jumptable 2034 | getjt:=1 2035 | disploop() 2036 | getjt:=0 2037 | end 2038 | 2039 | global proc fixupcode(ifile pm)= 2040 | pcl pc 2041 | 2042 | pc:=pm.pcstart 2043 | 2044 | while pc.opcode<>kendmod, ++pc do 2045 | pc.labaddr:=jumptable[pc.opcode] 2046 | od 2047 | end 2048 | 2049 | global function runqprogram(isubprog sp, int ismain)int= 2050 | 2051 | return 0 when runcode IL/API ──┬───────────────────────> IL Source (Input to PC) 5 | PC ───────┘ ├───────────────────────> Run from source via interpreter 6 | ├────/──────────────────> C Source (Input to C compiler) 7 | └──┬─/──> Win/x64 ──┬───> EXE/DLL 8 | AA ───────────>─────────────┘ ├───> OBJ (Input to external linker) 9 | ├───> ASM (Input to AA) 10 | ├───> NASM (Input to NASM) 11 | ├───> MX/ML (Input to RUNMX) 12 | └───> Run from source 13 | ```` 14 | 15 | -------------------------------------------------------------------------------- /runmx.c: -------------------------------------------------------------------------------- 1 | // Launch .mx binary 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | 9 | typedef short i16; 10 | typedef int i32; 11 | typedef long long int i64; 12 | 13 | typedef unsigned char byte; 14 | 15 | typedef unsigned short u16; 16 | typedef unsigned int u32; 17 | typedef unsigned long long int u64; 18 | 19 | #define mcxsig ('M' + ('C'<<8) + ('X'<<16) + (26<<24)) 20 | 21 | enum { 22 | pad_dir = 0, 23 | version_dir, 24 | code_dir, 25 | idata_dir, 26 | zdata_dir, 27 | reloc_dir, 28 | dlls_dir, 29 | libs_dir, 30 | importsymbols_dir, 31 | exportsymbols_dir, 32 | exportsegs_dir, 33 | exportoffsets_dir, 34 | entry_dir, 35 | end_dir 36 | }; 37 | 38 | enum { 39 | no_rel = 0, 40 | locabs32_rel, 41 | locabs64_rel, 42 | impabs32_rel, 43 | impabs64_rel, 44 | imprel32_rel 45 | }; 46 | 47 | enum { 48 | code_seg = 1, 49 | idata_seg, 50 | zdata_seg, 51 | rodata_seg 52 | }; 53 | 54 | typedef struct { 55 | u32 offset; 56 | union { 57 | u16 stindex; 58 | byte targetsegment; 59 | }; 60 | byte segment; 61 | byte reloctype; 62 | } mcxreloc; 63 | 64 | typedef struct { 65 | char* version; 66 | 67 | i64 codesize; 68 | i64 idatasize; 69 | i64 zdatasize; 70 | 71 | i64 nrelocs; 72 | i64 ndlllibs; 73 | i64 nlibs; 74 | i64 nimports; 75 | i64 nexports; 76 | 77 | byte* codeptr; 78 | byte* idataptr; 79 | 80 | mcxreloc* reloctable; 81 | char** dllnames; 82 | char** libnames; 83 | char** importnames; 84 | char** exports; 85 | byte* exportsegs; 86 | u64* exportoffsets; 87 | 88 | u64 entryoffset; 89 | 90 | byte* zdataptr; 91 | i64 codexsize; 92 | u64* exportaddr; 93 | i16* importxreftable; 94 | 95 | char* filespec; 96 | char* libname; 97 | byte* entryaddr; 98 | i64 libno; 99 | } librec; 100 | 101 | enum {maxdlls = 20}; 102 | enum {maxlibs = 20}; 103 | enum {maxsymbols = 3000}; 104 | 105 | char* addext(char*, char*); 106 | char* extractbasefile(char*); 107 | byte* readfile(char*); 108 | int rfsize=0; 109 | char* convlcstring(char*); 110 | 111 | char* extractext(char*,int); 112 | char* extractpath(char*); 113 | char* extractfile(char*); 114 | char* changeext(char*,char*); 115 | 116 | u64 os_getdllinst(char*); 117 | void* os_getdllprocaddr(u64, char*); 118 | void* os_allocexecmem(u64); 119 | 120 | u64 LoadLibraryA(char*); 121 | void* GetProcAddress(u64, char*); 122 | 123 | void* VirtualAlloc(void*, u32, u32, u32); 124 | u32 VirtualProtect(void*, u32, u32, u32*); 125 | 126 | enum {NORMAL_PRIORITY_CLASS=32}; 127 | enum {CREATE_NEW_CONSOLE=16}; 128 | enum {DETACHED_PROCESS=16}; 129 | 130 | enum {MEM_COMMIT = 4096}; 131 | enum {MEM_RESERVE = 8192}; 132 | enum {PAGE_EXECUTE = 16}; 133 | enum {PAGE_EXECUTE_READ = 32}; 134 | enum {PAGE_EXECUTE_READWRITE = 64}; 135 | enum {PAGE_NOACCESS = 1}; 136 | 137 | 138 | char* dllnametable[maxdlls]; 139 | u64 dllinsttable[maxdlls]; 140 | i64 ndlllibs=0; 141 | 142 | char* libnametable[maxlibs]; 143 | librec* libtable[maxlibs]; 144 | byte librelocated[maxlibs]; 145 | byte libinitdone[maxlibs]; 146 | i64 nlibs=0; 147 | 148 | char* symbolnametable[maxsymbols]; 149 | byte symboldefined[maxsymbols]; 150 | void* symboladdress[maxsymbols]; 151 | i16 symbollibindex[maxsymbols]; 152 | i16 symboldllindex[maxsymbols]; 153 | i64 nsymbols=0; 154 | 155 | void loadimports(librec* plib); 156 | librec* loadlibfile(char* filename, int libno); 157 | int cmdskip; 158 | 159 | void error(char* mess, char* param) { 160 | printf("%s %s\n",mess,param); 161 | puts("Aborting"); 162 | exit(1); 163 | } 164 | 165 | byte* readmxfile(char* filename) { 166 | byte* p; 167 | 168 | p=readfile(filename); 169 | if (p) { 170 | *(p+rfsize) = end_dir; 171 | } 172 | return p; 173 | } 174 | 175 | void calllibinit(librec* lib) { 176 | void (*fnptr)(void); 177 | 178 | if (lib->entryaddr) { 179 | fnptr=(void(*)(void))lib->entryaddr; 180 | (*fnptr)(); 181 | } 182 | libinitdone[lib->libno]=1; 183 | } 184 | 185 | void setspecialglobals(int cmdskip) { 186 | for (int i=1; i<=nsymbols; ++i) if (*symbolnametable[i]=='$') { 187 | if (strcmp(symbolnametable[i], "$cmdskip")==0) { 188 | *(byte*)symboladdress[i] = cmdskip; 189 | } 190 | } 191 | } 192 | 193 | void runprogram(librec* lib, int cmdskip) { 194 | int libno=lib->libno; 195 | void (*fnptr)(void); 196 | 197 | for (int i=1; i<=nlibs; ++i) if (i!=libno && !libinitdone[i]) { 198 | calllibinit(libtable[i]); 199 | } 200 | 201 | if (lib->entryaddr==NULL) error("No entry point found",""); 202 | 203 | setspecialglobals(cmdskip); 204 | 205 | fnptr = (void(*)(void))lib->entryaddr; 206 | 207 | (*fnptr)(); 208 | 209 | libinitdone[libno]=1; 210 | } 211 | 212 | void* mallocz(i64 n) { 213 | void* p=malloc(n); 214 | memset(p,0,n); 215 | return p; 216 | } 217 | 218 | void reloclib(librec* lib) { 219 | int index, targetoffset; 220 | char* name; 221 | byte* p; 222 | byte* q; 223 | u64* qaddr; 224 | mcxreloc r; 225 | 226 | p=lib->codeptr+lib->codesize; 227 | qaddr=(u64*)(p+lib->nimports*sizeof(u64)); 228 | 229 | for (int i=1; i<=lib->nimports; ++i) { 230 | name=lib->importnames[i]; 231 | *p++=0x48; 232 | *p++=0xFF; 233 | *p++=0x24; 234 | *p++=0x25; 235 | *(u32*)p=(u32)(u64)qaddr; 236 | p+=4; 237 | 238 | index=lib->importxreftable[i]; 239 | *qaddr++ = (u64)symboladdress[index]; 240 | } 241 | 242 | for (int i=1; i<=lib->nrelocs; ++i) { 243 | r=lib->reloctable[i]; 244 | if (r.segment==code_seg) p=lib->codeptr+r.offset; 245 | else if (r.segment==idata_seg) p=lib->idataptr+r.offset; 246 | else if (r.segment==zdata_seg) p=lib->zdataptr+r.offset; 247 | 248 | switch (r.reloctype) { 249 | case locabs32_rel: 250 | targetoffset=*(u32*)p; 251 | switch (r.targetsegment) { 252 | case code_seg: *(u32*)p = (u32)(u64)(lib->codeptr+targetoffset); 253 | break; case idata_seg: *(u32*)p = (u32)(u64)(lib->idataptr+targetoffset); 254 | break; case zdata_seg: *(u32*)p = (u32)(u64)(lib->zdataptr+targetoffset); 255 | } 256 | 257 | break; case locabs64_rel: 258 | targetoffset=*(u32*)p; 259 | switch (r.targetsegment) { 260 | case code_seg: *(u64*)p = (u64)(lib->codeptr+targetoffset); 261 | break; case idata_seg: *(u64*)p = (u64)(lib->idataptr+targetoffset); 262 | break; case zdata_seg: *(u64*)p = (u64)(lib->zdataptr+targetoffset); 263 | } 264 | 265 | break; case impabs64_rel: 266 | 267 | index=lib->importxreftable[r.stindex]; 268 | *(u64*)p += (u64)symboladdress[index]; 269 | 270 | break; case impabs32_rel: 271 | index=lib->importxreftable[r.stindex]; 272 | *(u32*)p += (u32)(u64)symboladdress[index]; 273 | 274 | break; case imprel32_rel: 275 | if (r.segment!=code_seg) error("imprel32?",""); 276 | index=r.stindex; 277 | q=lib->codeptr+lib->codesize+(index-1)*8; 278 | *(u32*)p = q-(p+4); 279 | } 280 | } 281 | 282 | librelocated[lib->libno]=1; 283 | } 284 | 285 | void dorelocations(void) { 286 | for (int i=1; i<=nlibs; ++i) if (!librelocated[i]) { 287 | reloclib(libtable[i]); 288 | } 289 | } 290 | 291 | int findlib(char* name) { 292 | for (int i=1; i<=nlibs; ++i) { 293 | if (strcmp(name, libnametable[i])==0) return i; 294 | } 295 | return 0; 296 | } 297 | 298 | int addlib(char* name) { 299 | if (nlibs>maxlibs) error("Too many libs",""); 300 | libnametable[++nlibs]=name; 301 | return nlibs; 302 | } 303 | 304 | void adddll(char* name) { 305 | 306 | for (int i=1; i<=ndlllibs; ++i) { 307 | if (strcmp(name, dllnametable[i])==0) return; 308 | } 309 | 310 | if (ndlllibs>=maxdlls) error("Too many libs",""); 311 | dllnametable[++ndlllibs]=name; 312 | } 313 | 314 | int addsymbol(char* name) { 315 | for (int i=1; i<=nsymbols; ++i) { 316 | if (strcmp(name, symbolnametable[i])==0) return i; 317 | } 318 | 319 | if (nsymbols>maxsymbols) error("Too many imports",""); 320 | symbolnametable[++nsymbols]=name; 321 | return nsymbols; 322 | } 323 | 324 | void* finddllsymbol(char* name, int* dllindex) { 325 | void* p; 326 | 327 | *dllindex = 0; 328 | for (int i=1; i<=ndlllibs; ++i) { 329 | p = os_getdllprocaddr(dllinsttable[i], name); 330 | if (p) { 331 | *dllindex=i; 332 | return p; 333 | } 334 | } 335 | return NULL; 336 | } 337 | 338 | void scansymbols(void) { 339 | int dllindex, undef=0; 340 | void* p; 341 | 342 | for (int i=1; i<=nsymbols; ++i) if (!symboldefined[i]) { 343 | p=finddllsymbol(symbolnametable[i], &dllindex); 344 | if (p) { 345 | symboladdress[i]=p; 346 | symboldllindex[i]=dllindex; 347 | symboldefined[i]=1; 348 | } else { 349 | printf("Undef: %s\n",symbolnametable[i]); 350 | ++undef; 351 | } 352 | } 353 | 354 | if (undef) { 355 | error("Symbols undefined",""); 356 | } 357 | } 358 | 359 | 360 | char* readstring(byte** p) { 361 | char* s = strdup((char*)*p); 362 | while (*++(*p)) {} 363 | ++(*p); 364 | return s; 365 | } 366 | 367 | int readbyte(byte** p) {return *(*p)++;} 368 | 369 | u64 readu32(byte** p) { 370 | u64 x = *(u32*)(*p); 371 | (*p)+=4; 372 | return x; 373 | } 374 | 375 | void loaddlls(void) { 376 | u64 inst; 377 | 378 | for (int i=1; i<=ndlllibs; ++i) if (!dllinsttable[i]) { 379 | inst=os_getdllinst(dllnametable[i]); 380 | if (inst==0) error("Can't find DLL:",dllnametable[i]); 381 | 382 | dllinsttable[i]=inst; 383 | } 384 | } 385 | 386 | void dosymbols(librec* lib) { 387 | int ix; 388 | byte* baseaddr; 389 | 390 | for (int i=1; i<=lib->ndlllibs; ++i) 391 | adddll(lib->dllnames[i]); 392 | 393 | for (int i=1; i<=lib->nimports; ++i) 394 | lib->importxreftable[i]=addsymbol(lib->importnames[i]); 395 | 396 | for (int i=1; i<=lib->nexports; ++i) { 397 | ix=addsymbol(lib->exports[i]); 398 | if (symboldefined[ix]) { 399 | printf("Dupl symbol: %s\n", lib->exports[i]); 400 | continue; 401 | } 402 | 403 | symboldefined[ix]=1; 404 | 405 | switch (lib->exportsegs[i]) { 406 | case code_seg: baseaddr=lib->codeptr; break; 407 | case idata_seg: baseaddr=lib->idataptr; break; 408 | case zdata_seg: baseaddr=lib->zdataptr; break; 409 | default: baseaddr=NULL; 410 | } 411 | 412 | symboladdress[ix]=baseaddr+lib->exportoffsets[i]; 413 | symbollibindex[ix]=lib->libno; 414 | } 415 | } 416 | 417 | void fixuplib(librec* lib) { 418 | loaddlls(); 419 | scansymbols(); 420 | dorelocations(); 421 | } 422 | 423 | void alloclibdata(librec* lib) { 424 | int tablesize, n; 425 | byte* p; 426 | 427 | lib->zdataptr=mallocz(lib->zdatasize); 428 | 429 | tablesize=lib->nimports*16; 430 | n=lib->codesize; 431 | 432 | p=os_allocexecmem(n+tablesize); 433 | if (p==NULL) error("Can't alloc code memory",""); 434 | 435 | memcpy(p, lib->codeptr, n); 436 | 437 | memset(p+n, 0, tablesize); 438 | 439 | lib->codeptr=p; 440 | lib->codexsize=tablesize; 441 | 442 | lib->exportaddr=malloc(sizeof(u64)*(lib->nexports+1)); 443 | lib->importxreftable=malloc(sizeof(i16)*(lib->nimports+1)); 444 | 445 | if (lib->entryoffset!=0xFFFFFFFF) 446 | lib->entryaddr=lib->codeptr+lib->entryoffset; 447 | } 448 | 449 | void dosublib(char* name) { 450 | librec* qlib; 451 | 452 | int n=findlib(name); 453 | 454 | if (n==0) { 455 | n=addlib(name); 456 | printf("Loading sublib: %s\n",name); 457 | qlib=loadlibfile(addext(name,"ml"),n); 458 | loadimports(qlib); 459 | } 460 | } 461 | 462 | void loadimports(librec* plib) { 463 | librec* qlib; 464 | char* name; 465 | 466 | for (int i=1; i<=plib->nlibs; ++i) { 467 | dosublib(plib->libnames[i]); 468 | } 469 | 470 | alloclibdata(plib); 471 | dosymbols(plib); 472 | } 473 | 474 | librec* readlibfile(char* filename, byte* p) { 475 | librec lib; 476 | u32 sig; 477 | int dir, n, tablesize; 478 | byte* pstart=p; 479 | 480 | memset(&lib, 0, sizeof(librec)); 481 | 482 | sig=readu32(&p); 483 | if (sig!=mcxsig) error("Bad sig - not MX/ML file",""); 484 | 485 | lib.filespec=strdup(filename); 486 | lib.libname=strdup(extractbasefile(filename)); 487 | 488 | while (1) { 489 | switch (dir=readbyte(&p)) { 490 | case version_dir: 491 | lib.version=readstring(&p); 492 | break; 493 | 494 | case zdata_dir: 495 | lib.zdatasize=readu32(&p); 496 | lib.zdataptr=mallocz(lib.zdatasize); 497 | break; 498 | 499 | case idata_dir: 500 | lib.idatasize=n=readu32(&p); 501 | lib.idataptr=malloc(n); 502 | memcpy(lib.idataptr, p, n) ; 503 | p+=n; 504 | break; 505 | 506 | case code_dir: 507 | lib.codesize=n=readu32(&p); 508 | lib.codeptr=p; 509 | p+=n; 510 | break; 511 | 512 | case dlls_dir: 513 | lib.ndlllibs=n=readu32(&p); 514 | lib.dllnames=malloc(sizeof(char*)*(n+1)); 515 | for (int i=1; i<=n; ++i) { 516 | lib.dllnames[i]=readstring(&p); 517 | } 518 | break; 519 | 520 | case libs_dir: 521 | lib.nlibs=n=readu32(&p); 522 | lib.libnames=malloc(sizeof(char*)*(n+1)); 523 | for (int i=1; i<=n; ++i) { 524 | lib.libnames[i]=readstring(&p); 525 | } 526 | break; 527 | 528 | case importsymbols_dir: 529 | lib.nimports=n=readu32(&p); 530 | lib.importnames=malloc(sizeof(char*)*(n+1)); 531 | for (int i=1; i<=n; ++i) { 532 | lib.importnames[i]=readstring(&p); 533 | } 534 | break; 535 | 536 | case exportsymbols_dir: 537 | lib.nexports=n=readu32(&p); 538 | lib.exports=malloc(sizeof(char*)*(n+1)); 539 | for (int i=1; i<=n; ++i) { 540 | lib.exports[i]=readstring(&p); 541 | } 542 | break; 543 | 544 | case exportsegs_dir: 545 | n=readu32(&p); 546 | lib.exportsegs=malloc(n); 547 | for (int i=1; i<=n; ++i) { 548 | lib.exportsegs[i]=readbyte(&p); 549 | } 550 | break; 551 | 552 | case exportoffsets_dir: 553 | n=readu32(&p); 554 | lib.exportoffsets=malloc(sizeof(u64)*(n+1)); 555 | for (int i=1; i<=n; ++i) { 556 | lib.exportoffsets[i]=readu32(&p); 557 | } 558 | break; 559 | 560 | case reloc_dir: 561 | lib.nrelocs=n=readu32(&p); 562 | n=lib.nrelocs*sizeof(mcxreloc); 563 | lib.reloctable=malloc(n+sizeof(mcxreloc)); 564 | memcpy(lib.reloctable+1, p, n); 565 | p+=n; 566 | break; 567 | 568 | case entry_dir: 569 | lib.entryoffset=readu32(&p); 570 | break; 571 | 572 | case end_dir: 573 | goto finish; 574 | 575 | case pad_dir: 576 | break; 577 | 578 | default: 579 | // error(("Unknown directive:",mcxdirnames[dir]); 580 | // error("Unknown directive:",""); 581 | printf("%d\n",dir); 582 | printf("%x\n",dir); 583 | error("Unknown directive:",""); 584 | exit(1); 585 | }} 586 | finish:; 587 | 588 | librec* plib=malloc(sizeof(librec)); 589 | memcpy(plib, &lib, sizeof(librec)); 590 | 591 | return plib; 592 | } 593 | 594 | librec* loadlibfile(char* filename, int libno) { 595 | byte* p; 596 | librec* plib; 597 | 598 | p=readmxfile(filename); 599 | if (p==NULL) 600 | error("Can't load:", filename); 601 | 602 | plib=readlibfile(filename, p); 603 | plib->libno=libno; 604 | libtable[libno]=plib; 605 | 606 | return plib; 607 | } 608 | 609 | librec* loadmx(char* filename) { 610 | librec* plib; 611 | int newlib; 612 | char* name; 613 | 614 | name=strdup(convlcstring(extractbasefile(filename))); 615 | 616 | newlib=addlib(name); 617 | 618 | plib=loadlibfile(filename, newlib); 619 | 620 | loadimports(plib); 621 | 622 | return plib; 623 | } 624 | 625 | int main(int nargs, char** args) { 626 | char* filename; 627 | librec* plib; 628 | 629 | if (nargs<2) { 630 | printf("Usage:\n %s filename[.mx]\n", args[0]); 631 | exit(1); 632 | } 633 | 634 | filename = strdup(addext(args[1],"mx")); 635 | cmdskip = 1; 636 | 637 | plib=loadmx(filename); 638 | fixuplib(plib); 639 | 640 | runprogram(plib, cmdskip); 641 | } 642 | 643 | char* extractpath(char* s) { 644 | static char str[260]; 645 | char* t; 646 | int n; 647 | 648 | t=s+strlen(s)-1; 649 | 650 | while (t>=s) { 651 | switch (*t) { 652 | case '\\': case '/': case ':': 653 | n=t-s+1; 654 | memcpy(str,s,n); 655 | str[n]=0; 656 | return str; 657 | } 658 | --t; 659 | } 660 | return ""; 661 | } 662 | 663 | char* extractfile(char* s) { 664 | char* t=extractpath(s); 665 | if (*t==0) return s; 666 | return s+strlen(t); 667 | } 668 | 669 | char* extractext(char* s, int period) { 670 | char* t; 671 | char* u; 672 | 673 | t=extractfile(s); 674 | 675 | if (*t==0) return ""; 676 | 677 | u=t+strlen(t)-1; 678 | 679 | while (u>=t) { 680 | if (*u=='.') { 681 | if (*(u+1)==0) 682 | return (period?".":""); 683 | return u+1; 684 | } 685 | --u; 686 | } 687 | return ""; 688 | } 689 | 690 | char* changeext(char* s, char* newext) { 691 | static char newfile[260]; 692 | char newext2[32]; 693 | char* sext; 694 | int n; 695 | 696 | strcpy(newfile,s); 697 | 698 | if (*newext==0) { 699 | newext2[0]=0; 700 | newext2[1]=0; 701 | } else if (*newext=='.') { 702 | strcpy(newext2, newext); 703 | } else { 704 | strcpy(newext2, "."); 705 | strcat(newext2, newext); 706 | } 707 | 708 | sext=extractext(s,1); 709 | 710 | if (*sext==0) { 711 | strcat(newfile, newext2); 712 | } else if (*sext=='.') { 713 | strcat(newfile, newext2+1); 714 | } else { 715 | n=sext-s-2; 716 | strcpy(newfile+n+1, newext2); 717 | } 718 | 719 | return newfile; 720 | } 721 | 722 | char* addext(char* s, char* newext) { 723 | char* sext; 724 | 725 | sext=extractext(s,1); 726 | if (*sext==0) return changeext(s, newext); 727 | 728 | return s; 729 | } 730 | 731 | char* extractbasefile(char* s) { 732 | static char str[100]; 733 | char* f; 734 | char* e; 735 | int n, flen; 736 | 737 | f=extractfile(s); 738 | flen=strlen(f); 739 | if (flen==0) return ""; 740 | 741 | e=extractext(f,0); 742 | 743 | if (*e) { 744 | n=flen-strlen(e)-1; 745 | memcpy(str,f,n); 746 | str[n]=0; 747 | return str; 748 | } 749 | if (*(f+flen-1)=='.') { 750 | memcpy(str,f,flen-1); 751 | str[flen-1]=0; 752 | return str; 753 | } 754 | 755 | return f; 756 | } 757 | 758 | u64 getfilesize(FILE* f) { 759 | u64 p, size; 760 | 761 | p=ftell(f); 762 | fseek(f,0,2); 763 | size=ftell(f); 764 | fseek(f,p,SEEK_SET); 765 | return size; 766 | } 767 | 768 | byte* readfile(char* filename) { 769 | FILE* f; 770 | byte* m; 771 | byte* p; 772 | 773 | f=fopen(filename,"rb"); 774 | if (f==NULL) return NULL; 775 | rfsize=getfilesize(f); 776 | 777 | m=malloc(rfsize+2); 778 | if (m==NULL) return NULL; 779 | 780 | 781 | fread(m, 1, rfsize, f); 782 | fclose(f); 783 | 784 | *(u16*)(m+rfsize) = 0; 785 | return m; 786 | } 787 | 788 | char* convlcstring(char* s) { 789 | char* t=s; 790 | while (*t) { 791 | *t=tolower(*t); 792 | ++t; 793 | } 794 | return s; 795 | } 796 | 797 | u64 os_getdllinst(char* name) { 798 | return (u64)LoadLibraryA(name); 799 | } 800 | 801 | void* os_getdllprocaddr(u64 hinst, char* fnname) { 802 | return GetProcAddress(hinst, fnname); 803 | } 804 | 805 | void* os_allocexecmem(u64 n) { 806 | byte* p; 807 | u32 oldprot; 808 | int status; 809 | 810 | p=VirtualAlloc(NULL, n, MEM_RESERVE | MEM_COMMIT, PAGE_NOACCESS); 811 | if (p==NULL) return NULL; 812 | 813 | status=VirtualProtect(p, n, PAGE_EXECUTE_READWRITE, &oldprot); 814 | 815 | if (status==0) return NULL; 816 | 817 | return p; 818 | } 819 | --------------------------------------------------------------------------------