├── README.org ├── p4 ├── pcom.p └── pint.p ├── p5 ├── pcom.pas └── pint.pas ├── super ├── assemble.p ├── common.p ├── compile.p ├── interpret.p ├── notes.tex ├── parse.p ├── readthis.tex ├── report.tex ├── scan.p ├── sun3.user ├── sun4.user └── user.tex ├── web ├── tangle.pas ├── tangle.web └── weave.web └── xdp ├── compsamp.bat ├── readme.txt ├── samples ├── cannabis.pas ├── clock.pas ├── eq.dat ├── eqerr.dat ├── factor.pas ├── fft.pas ├── fractal.pas ├── gauss.inc ├── inserr.pas ├── kalman.inc ├── life.pas ├── lineq.pas ├── list.pas ├── palette.pas └── sort.pas ├── system.pas ├── xdp.dpr └── xdp.exe /README.org: -------------------------------------------------------------------------------- 1 | 2 | All of these are in the public domain: 3 | 4 | - p4 :: pascal compiler - niklaus wirth, et al ( 1976 ) 5 | - web :: literate programming - donald knuth ( 1981 ) 6 | - super :: super pascal ( parallel programming ) - per brinch hansen ( 1993 ) 7 | - p5 :: ISO 7185 compliant extensions to p4 - scott moore ( 2009 ) 8 | - xdp :: TP 3.0-style pascal compiler - vasiliy tereshkov ( 2010 ) 9 | 10 | -------------------------------------------------------------------------------- /p4/pint.p: -------------------------------------------------------------------------------- 1 | (*Assembler and interpreter of Pascal code*) 2 | (*K. Jensen, N. Wirth, Ch. Jacobi, ETH May 76*) 3 | 4 | program pcode(input,output,prd,prr); 5 | 6 | (* Note for the implementation. 7 | =========================== 8 | This interpreter is written for the case where all the fundamental types 9 | take one storage unit. 10 | In an actual implementation, the handling of the sp pointer has to take 11 | into account the fact that the types may have lengths different from one: 12 | in push and pop operations the sp has to be increased and decreased not 13 | by 1, but by a number depending on the type concerned. 14 | However, where the number of units of storage has been computed by the 15 | compiler, the value must not be corrected, since the lengths of the types 16 | involved have already been taken into account. 17 | *) 18 | 19 | 20 | label 1; 21 | const codemax = 8650; 22 | pcmax = 17500; 23 | maxstk = 13650; (* size of variable store *) 24 | overi = 13655; (* size of integer constant table = 5 *) 25 | overr = 13660; (* size of real constant table = 5 *) 26 | overs = 13730; (* size of set constant table = 70 *) 27 | overb = 13820; 28 | overm = 18000; 29 | maxstr = 18001; 30 | largeint = 26144; 31 | begincode = 3; 32 | inputadr = 5; 33 | outputadr = 6; 34 | prdadr = 7; 35 | prradr = 8; 36 | duminst = 62; 37 | 38 | type bit4 = 0..15; 39 | bit6 = 0..127; 40 | bit20 = -26143..26143; 41 | datatype = (undef,int,reel,bool,sett,adr,mark,car); 42 | address = -1..maxstr; 43 | beta = packed array[1..25] of char; (*error message*) 44 | settype = set of 0..58; 45 | alfa = packed array[1..10] of char; 46 | 47 | var code : array[0..codemax] of (* the program *) 48 | packed record op1 :bit6; 49 | p1 :bit4; 50 | q1 :bit20; 51 | op2 :bit6; 52 | p2 :bit4; 53 | q2 :bit20 54 | end; 55 | pc : 0..pcmax; (*program address register*) 56 | op : bit6; p : bit4; q : bit20; (*instruction register*) 57 | 58 | store : array [0..overm] of 59 | record case datatype of 60 | int :(vi :integer); 61 | reel :(vr :real); 62 | bool :(vb :boolean); 63 | sett :(vs :settype); 64 | car :(vc :char); 65 | adr :(va :address); 66 | (*address in store*) 67 | mark :(vm :integer) 68 | end; 69 | mp,sp,np,ep : address; (* address registers *) 70 | (*mp points to beginning of a data segment 71 | sp points to top of the stack 72 | ep points to the maximum extent of the stack 73 | np points to top of the dynamically allocated area*) 74 | 75 | interpreting: boolean; 76 | prd,prr : text;(*prd for read only, prr for write only *) 77 | 78 | instr : array[bit6] of alfa; (* mnemonic instruction codes *) 79 | cop : array[bit6] of integer; 80 | sptable : array[0..20] of alfa; (*standard functions and procedures*) 81 | 82 | (*locally used for interpreting one instruction*) 83 | ad,ad1 : address; 84 | b : boolean; 85 | i,j,i1,i2 : integer; 86 | c : char; 87 | 88 | (*--------------------------------------------------------------------*) 89 | 90 | procedure load; 91 | const maxlabel = 1850; 92 | type labelst = (entered,defined); (*label situation*) 93 | labelrg = 0..maxlabel; (*label range*) 94 | labelrec = record 95 | val: address; 96 | st: labelst 97 | end; 98 | var icp,rcp,scp,bcp,mcp : address; (*pointers to next free position*) 99 | word : array[1..10] of char; i : integer; ch : char; 100 | labeltab: array[labelrg] of labelrec; 101 | labelvalue: address; 102 | 103 | procedure init; 104 | var i: integer; 105 | begin instr[ 0]:='lod '; instr[ 1]:='ldo '; 106 | instr[ 2]:='str '; instr[ 3]:='sro '; 107 | instr[ 4]:='lda '; instr[ 5]:='lao '; 108 | instr[ 6]:='sto '; instr[ 7]:='ldc '; 109 | instr[ 8]:='... '; instr[ 9]:='ind '; 110 | instr[10]:='inc '; instr[11]:='mst '; 111 | instr[12]:='cup '; instr[13]:='ent '; 112 | instr[14]:='ret '; instr[15]:='csp '; 113 | instr[16]:='ixa '; instr[17]:='equ '; 114 | instr[18]:='neq '; instr[19]:='geq '; 115 | instr[20]:='grt '; instr[21]:='leq '; 116 | instr[22]:='les '; instr[23]:='ujp '; 117 | instr[24]:='fjp '; instr[25]:='xjp '; 118 | instr[26]:='chk '; instr[27]:='eof '; 119 | instr[28]:='adi '; instr[29]:='adr '; 120 | instr[30]:='sbi '; instr[31]:='sbr '; 121 | instr[32]:='sgs '; instr[33]:='flt '; 122 | instr[34]:='flo '; instr[35]:='trc '; 123 | instr[36]:='ngi '; instr[37]:='ngr '; 124 | instr[38]:='sqi '; instr[39]:='sqr '; 125 | instr[40]:='abi '; instr[41]:='abr '; 126 | instr[42]:='not '; instr[43]:='and '; 127 | instr[44]:='ior '; instr[45]:='dif '; 128 | instr[46]:='int '; instr[47]:='uni '; 129 | instr[48]:='inn '; instr[49]:='mod '; 130 | instr[50]:='odd '; instr[51]:='mpi '; 131 | instr[52]:='mpr '; instr[53]:='dvi '; 132 | instr[54]:='dvr '; instr[55]:='mov '; 133 | instr[56]:='lca '; instr[57]:='dec '; 134 | instr[58]:='stp '; instr[59]:='ord '; 135 | instr[60]:='chr '; instr[61]:='ujc '; 136 | 137 | sptable[ 0]:='get '; sptable[ 1]:='put '; 138 | sptable[ 2]:='rst '; sptable[ 3]:='rln '; 139 | sptable[ 4]:='new '; sptable[ 5]:='wln '; 140 | sptable[ 6]:='wrs '; sptable[ 7]:='eln '; 141 | sptable[ 8]:='wri '; sptable[ 9]:='wrr '; 142 | sptable[10]:='wrc '; sptable[11]:='rdi '; 143 | sptable[12]:='rdr '; sptable[13]:='rdc '; 144 | sptable[14]:='sin '; sptable[15]:='cos '; 145 | sptable[16]:='exp '; sptable[17]:='log '; 146 | sptable[18]:='sqt '; sptable[19]:='atn '; 147 | sptable[20]:='sav '; 148 | 149 | cop[ 0] := 105; cop[ 1] := 65; 150 | cop[ 2] := 70; cop[ 3] := 75; 151 | cop[ 6] := 80; cop[ 9] := 85; 152 | cop[10] := 90; cop[26] := 95; 153 | cop[57] := 100; 154 | 155 | pc := begincode; 156 | icp := maxstk + 1; 157 | rcp := overi + 1; 158 | scp := overr + 1; 159 | bcp := overs + 2; 160 | mcp := overb + 1; 161 | for i:= 1 to 10 do word[i]:= ' '; 162 | for i:= 0 to maxlabel do 163 | with labeltab[i] do begin val:=-1; st:= entered end; 164 | reset(prd); 165 | end;(*init*) 166 | 167 | procedure errorl(string: beta); (*error in loading*) 168 | begin writeln; 169 | write(string); 170 | halt 171 | end; (*errorl*) 172 | 173 | procedure update(x: labelrg); (*when a label definition lx is found*) 174 | var curr,succ: -1..pcmax; (*resp. current element and successor element 175 | of a list of future references*) 176 | endlist: boolean; 177 | begin 178 | if labeltab[x].st=defined then errorl(' duplicated label ') 179 | else begin 180 | if labeltab[x].val<>-1 then (*forward reference(s)*) 181 | begin curr:= labeltab[x].val; endlist:= false; 182 | while not endlist do 183 | with code[curr div 2] do 184 | begin 185 | if odd(curr) then begin succ:= q2; 186 | q2:= labelvalue 187 | end 188 | else begin succ:= q1; 189 | q1:= labelvalue 190 | end; 191 | if succ=-1 then endlist:= true 192 | else curr:= succ 193 | end; 194 | end; 195 | labeltab[x].st := defined; 196 | labeltab[x].val:= labelvalue; 197 | end 198 | end;(*update*) 199 | 200 | procedure assemble; forward; 201 | 202 | procedure generate;(*generate segment of code*) 203 | var x: integer; (* label number *) 204 | again: boolean; 205 | begin 206 | again := true; 207 | while again do 208 | begin read(prd,ch);(* first character of line*) 209 | case ch of 210 | 'i': readln(prd); 211 | 'l': begin read(prd,x); 212 | if not eoln(prd) then read(prd,ch); 213 | if ch='=' then read(prd,labelvalue) 214 | else labelvalue:= pc; 215 | update(x); readln(prd); 216 | end; 217 | 'q': begin again := false; readln(prd) end; 218 | ' ': begin read(prd,ch); assemble end 219 | end; 220 | end 221 | end; (*generate*) 222 | 223 | procedure assemble; (*translate symbolic code into machine code and store*) 224 | label 1; (*goto 1 for instructions without code generation*) 225 | var name :alfa; b :boolean; r :real; s :settype; 226 | c1 :char; i,s1,lb,ub :integer; 227 | 228 | procedure lookup(x: labelrg); (* search in label table*) 229 | begin case labeltab[x].st of 230 | entered: begin q := labeltab[x].val; 231 | labeltab[x].val := pc 232 | end; 233 | defined: q:= labeltab[x].val 234 | end(*case label..*) 235 | end;(*lookup*) 236 | 237 | procedure labelsearch; 238 | var x: labelrg; 239 | begin while (ch<>'l') and not eoln(prd) do read(prd,ch); 240 | read(prd,x); lookup(x) 241 | end;(*labelsearch*) 242 | 243 | procedure getname; 244 | begin word[1] := ch; 245 | read(prd,word[2],word[3]); 246 | if not eoln(prd) then read(prd,ch) (*next character*); 247 | pack(word,1,name) 248 | end; (*getname*) 249 | 250 | procedure typesymbol; 251 | var i: integer; 252 | begin 253 | if ch <> 'i' then 254 | begin 255 | case ch of 256 | 'a': i := 0; 257 | 'r': i := 1; 258 | 's': i := 2; 259 | 'b': i := 3; 260 | 'c': i := 4; 261 | end; 262 | op := cop[op]+i; 263 | end; 264 | end (*typesymbol*) ; 265 | 266 | begin p := 0; q := 0; op := 0; 267 | getname; 268 | instr[duminst] := name; 269 | while instr[op]<>name do op := op+1; 270 | if op = duminst then errorl(' illegal instruction '); 271 | 272 | case op of (* get parameters p,q *) 273 | 274 | (*equ,neq,geq,grt,leq,les*) 275 | 17,18,19, 276 | 20,21,22: begin case ch of 277 | 'a': ; (*p = 0*) 278 | 'i': p := 1; 279 | 'r': p := 2; 280 | 'b': p := 3; 281 | 's': p := 4; 282 | 'c': p := 6; 283 | 'm': begin p := 5; 284 | read(prd,q) 285 | end 286 | end 287 | end; 288 | 289 | (*lod,str*) 290 | 0,2: begin typesymbol; read(prd,p,q) 291 | end; 292 | 293 | 4 (*lda*): read(prd,p,q); 294 | 295 | 12 (*cup*): begin read(prd,p); labelsearch end; 296 | 297 | 11 (*mst*): read(prd,p); 298 | 299 | 14 (*ret*): case ch of 300 | 'p': p:=0; 301 | 'i': p:=1; 302 | 'r': p:=2; 303 | 'c': p:=3; 304 | 'b': p:=4; 305 | 'a': p:=5 306 | end; 307 | 308 | (*lao,ixa,mov*) 309 | 5,16,55: read(prd,q); 310 | 311 | (*ldo,sro,ind,inc,dec*) 312 | 1,3,9,10,57: begin typesymbol; read(prd,q) 313 | end; 314 | 315 | (*ujp,fjp,xjp*) 316 | 23,24,25: labelsearch; 317 | 318 | 13 (*ent*): begin read(prd,p); labelsearch end; 319 | 320 | 15 (*csp*): begin for i:=1 to 9 do read(prd,ch); getname; 321 | while name<>sptable[q] do q := q+1 322 | end; 323 | 324 | 7 (*ldc*): begin case ch of (*get q*) 325 | 'i': begin p := 1; read(prd,i); 326 | if abs(i)>=largeint then 327 | begin op := 8; 328 | store[icp].vi := i; q := maxstk; 329 | repeat q := q+1 until store[q].vi=i; 330 | if q=icp then 331 | begin icp := icp+1; 332 | if icp=overi then 333 | errorl(' integer table overflow '); 334 | end 335 | end else q := i 336 | end; 337 | 338 | 'r': begin op := 8; p := 2; 339 | read(prd,r); 340 | store[rcp].vr := r; q := overi; 341 | repeat q := q+1 until store[q].vr=r; 342 | if q=rcp then 343 | begin rcp := rcp+1; 344 | if rcp = overr then 345 | errorl(' real table overflow '); 346 | end 347 | end; 348 | 349 | 'n': ; (*p,q = 0*) 350 | 351 | 'b': begin p := 3; read(prd,q) end; 352 | 353 | 'c': begin p := 6; 354 | repeat read(prd,ch); until ch <> ' '; 355 | if ch <> '''' then 356 | errorl(' illegal character '); 357 | read(prd,ch); q := ord(ch); 358 | read(prd,ch); 359 | if ch <> '''' then 360 | errorl(' illegal character '); 361 | end; 362 | '(': begin op := 8; p := 4; 363 | s := [ ]; read(prd,ch); 364 | while ch<>')' do 365 | begin read(prd,s1,ch); s := s + [s1] 366 | end; 367 | store[scp].vs := s; q := overr; 368 | repeat q := q+1 until store[q].vs=s; 369 | if q=scp then 370 | begin scp := scp+1; 371 | if scp=overs then 372 | errorl(' set table overflow '); 373 | end 374 | end 375 | end (*case*) 376 | end; 377 | 378 | 26 (*chk*): begin typesymbol; 379 | read(prd,lb,ub); 380 | if op = 95 then q := lb 381 | else 382 | begin 383 | store[bcp-1].vi := lb; store[bcp].vi := ub; 384 | q := overs; 385 | repeat q := q+2 386 | until (store[q-1].vi=lb)and (store[q].vi=ub); 387 | if q=bcp then 388 | begin bcp := bcp+2; 389 | if bcp=overb then 390 | errorl(' boundary table overflow '); 391 | end 392 | end 393 | end; 394 | 395 | 56 (*lca*): begin 396 | if mcp + 16 >= overm then 397 | errorl(' multiple table overflow '); 398 | mcp := mcp+16; 399 | q := mcp; 400 | for i := 0 to 15 (*stringlgth*) do 401 | begin read(prd,ch); 402 | store[q+i].vc := ch 403 | end; 404 | end; 405 | 406 | 6 (*sto*): typesymbol; 407 | 408 | 27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47, 409 | 48,49,50,51,52,53,54,58: ; 410 | 411 | (*ord,chr*) 412 | 59,60: goto 1; 413 | 414 | 61 (*ujc*): ; (*must have same length as ujp*) 415 | 416 | end; (*case*) 417 | 418 | (* store instruction *) 419 | with code[pc div 2] do 420 | if odd(pc) then 421 | begin op2 := op; p2 := p; q2 := q 422 | end else 423 | begin op1 := op; p1 := p; q1 := q 424 | end; 425 | pc := pc+1; 426 | 1: readln(prd); 427 | end; (*assemble*) 428 | 429 | begin (*load*) 430 | init; 431 | generate; 432 | pc := 0; 433 | generate; 434 | end; (*load*) 435 | 436 | (*------------------------------------------------------------------------*) 437 | 438 | procedure pmd; 439 | var s :integer; i: integer; 440 | 441 | procedure pt; 442 | begin write(s:6); 443 | if abs(store[s].vi) < maxint then write(store[s].vi) 444 | else write('too big '); 445 | s := s - 1; 446 | i := i + 1; 447 | if i = 4 then 448 | begin writeln(output); i := 0 end; 449 | end; (*pt*) 450 | 451 | begin 452 | write(' pc =',pc-1:5,' op =',op:3,' sp =',sp:5,' mp =',mp:5, 453 | ' np =',np:5); 454 | writeln; writeln('--------------------------------------'); 455 | 456 | s := sp; i := 0; 457 | while s>=0 do pt; 458 | s := maxstk; 459 | while s>=np do pt; 460 | end; (*pmd*) 461 | 462 | procedure errori(string: beta); 463 | begin writeln; writeln(string); 464 | pmd; goto 1 465 | end;(*errori*) 466 | 467 | function base(ld :integer):address; 468 | var ad :address; 469 | begin ad := mp; 470 | while ld>0 do 471 | begin ad := store[ad+1].vm; ld := ld-1 472 | end; 473 | base := ad 474 | end; (*base*) 475 | 476 | procedure compare; 477 | (*comparing is only correct if result by comparing integers will be*) 478 | begin 479 | i1 := store[sp].va; 480 | i2 := store[sp+1].va; 481 | i := 0; b := true; 482 | while b and (i<>q) do 483 | if store[i1+i].vi = store[i2+i].vi then i := i+1 484 | else b := false 485 | end; (*compare*) 486 | 487 | procedure callsp; 488 | var line: boolean; adptr,adelnt: address; 489 | i: integer; 490 | 491 | procedure readi(var f:text); 492 | var ad: address; 493 | begin ad:= store[sp-1].va; 494 | read(f,store[ad].vi); 495 | store[store[sp].va].vc := f^; 496 | sp:= sp-2 497 | end;(*readi*) 498 | 499 | procedure readr(var f: text); 500 | var ad: address; 501 | begin ad:= store[sp-1].va; 502 | read(f,store[ad].vr); 503 | store[store[sp].va].vc := f^; 504 | sp:= sp-2 505 | end;(*readr*) 506 | 507 | procedure readc(var f: text); 508 | var c: char; ad: address; 509 | begin read(f,c); 510 | ad:= store[sp-1].va; 511 | store[ad].vc := c; 512 | store[store[sp].va].vc := f^; 513 | store[store[sp].va].vi := ord(f^); 514 | sp:= sp-2 515 | end;(*readc*) 516 | 517 | procedure writestr(var f: text); 518 | var i,j,k: integer; 519 | ad: address; 520 | begin ad:= store[sp-3].va; 521 | k := store[sp-2].vi; j := store[sp-1].vi; 522 | (* j and k are numbers of characters *) 523 | if k>j then for i:=1 to k-j do write(f,' ') 524 | else j:= k; 525 | for i := 0 to j-1 do write(f,store[ad+i].vc); 526 | sp:= sp-4 527 | end;(*writestr*) 528 | 529 | procedure getfile(var f: text); 530 | var ad: address; 531 | begin ad:=store[sp].va; 532 | get(f); store[ad].vc := f^; 533 | sp:=sp-1 534 | end;(*getfile*) 535 | 536 | procedure putfile(var f: text); 537 | var ad: address; 538 | begin ad:= store[sp].va; 539 | f^:= store[ad].vc; put(f); 540 | sp:= sp-1; 541 | end;(*putfile*) 542 | 543 | begin (*callsp*) 544 | case q of 545 | 0 (*get*): case store[sp].va of 546 | 5: getfile(input); 547 | 6: errori(' get on output file '); 548 | 7: getfile(prd); 549 | 8: errori(' get on prr file ') 550 | end; 551 | 1 (*put*): case store[sp].va of 552 | 5: errori(' put on read file '); 553 | 6: putfile(output); 554 | 7: errori(' put on prd file '); 555 | 8: putfile(prr) 556 | end; 557 | 2 (*rst*): begin 558 | (*for testphase*) 559 | np := store[sp].va; sp := sp-1 560 | end; 561 | 3 (*rln*): begin case store[sp].va of 562 | 5: begin readln(input); 563 | store[inputadr].vc := input^ 564 | end; 565 | 6: errori(' readln on output file '); 566 | 7: begin readln(input); 567 | store[inputadr].vc := input^ 568 | end; 569 | 8: errori(' readln on prr file ') 570 | end; 571 | sp:= sp-1 572 | end; 573 | 4 (*new*): begin ad:= np-store[sp].va; 574 | (*top of stack gives the length in units of storage *) 575 | if ad <= ep then 576 | errori(' store overflow '); 577 | np:= ad; ad:= store[sp-1].va; 578 | store[ad].va := np; 579 | sp:=sp-2 580 | end; 581 | 5 (*wln*): begin case store[sp].va of 582 | 5: errori(' writeln on input file '); 583 | 6: writeln(output); 584 | 7: errori(' writeln on prd file '); 585 | 8: writeln(prr) 586 | end; 587 | sp:= sp-1 588 | end; 589 | 6 (*wrs*): case store[sp].va of 590 | 5: errori(' write on input file '); 591 | 6: writestr(output); 592 | 7: errori(' write on prd file '); 593 | 8: writestr(prr) 594 | end; 595 | 7 (*eln*): begin case store[sp].va of 596 | 5: line:= eoln(input); 597 | 6: errori(' eoln output file '); 598 | 7: line:=eoln(prd); 599 | 8: errori(' eoln on prr file ') 600 | end; 601 | store[sp].vb := line 602 | end; 603 | 8 (*wri*): begin case store[sp].va of 604 | 5: errori(' write on input file '); 605 | 6: write(output, 606 | store[sp-2].vi: store[sp-1].vi); 607 | 7: errori(' write on prd file '); 608 | 8: write(prr, 609 | store[sp-2].vi: store[sp-1].vi) 610 | end; 611 | sp:=sp-3 612 | end; 613 | 9 (*wrr*): begin case store[sp].va of 614 | 5: errori(' write on input file '); 615 | 6: write(output, 616 | store[sp-2].vr: store[sp-1].vi); 617 | 7: errori(' write on prd file '); 618 | 8: write(prr, 619 | store[sp-2].vr: store[sp-1].vi) 620 | end; 621 | sp:=sp-3 622 | end; 623 | 10(*wrc*): begin case store[sp].va of 624 | 5: errori(' write on input file '); 625 | 6: write(output,store[sp-2].vc: 626 | store[sp-1].vi); 627 | 7: errori(' write on prd file '); 628 | 8: write(prr,chr(store[sp-2].vi): 629 | store[sp-1].vi); 630 | end; 631 | sp:=sp-3 632 | end; 633 | 11(*rdi*): case store[sp].va of 634 | 5: readi(input); 635 | 6: errori(' read on output file '); 636 | 7: readi(prd); 637 | 8: errori(' read on prr file ') 638 | end; 639 | 12(*rdr*): case store[sp].va of 640 | 5: readr(input); 641 | 6: errori(' read on output file '); 642 | 7: readr(prd); 643 | 8: errori(' read on prr file ') 644 | end; 645 | 13(*rdc*): case store[sp].va of 646 | 5: readc(input); 647 | 6: errori(' read on output file '); 648 | 7: readc(prd); 649 | 8: errori(' read on prr file ') 650 | end; 651 | 14(*sin*): store[sp].vr:= sin(store[sp].vr); 652 | 15(*cos*): store[sp].vr:= cos(store[sp].vr); 653 | 16(*exp*): store[sp].vr:= exp(store[sp].vr); 654 | 17(*log*): store[sp].vr:= ln(store[sp].vr); 655 | 18(*sqt*): store[sp].vr:= sqrt(store[sp].vr); 656 | 19(*atn*): store[sp].vr:= arctan(store[sp].vr); 657 | 20(*sav*): begin ad:=store[sp].va; 658 | store[ad].va := np; 659 | sp:= sp-1 660 | end; 661 | end;(*case q*) 662 | end;(*callsp*) 663 | 664 | begin (* main *) 665 | rewrite(prr); 666 | load; (* assembles and stores code *) 667 | (* writeln(output); for testing *) 668 | pc := 0; sp := -1; mp := 0; np := maxstk+1; ep := 5; 669 | store[inputadr].vc := input^; 670 | store[prdadr].vc := prd^; 671 | interpreting := true; 672 | 673 | while interpreting do 674 | begin 675 | (*fetch*) 676 | with code[pc div 2] do 677 | if odd(pc) then 678 | begin op := op2; p := p2; q := q2 679 | end else 680 | begin op := op1; p := p1; q := q1 681 | end; 682 | pc := pc+1; 683 | 684 | (*execute*) 685 | case op of 686 | 687 | 105,106,107,108,109, 688 | 0 (*lod*): begin ad := base(p) + q; 689 | sp := sp+1; 690 | store[sp] := store[ad] 691 | end; 692 | 693 | 65,66,67,68,69, 694 | 1 (*ldo*): begin 695 | sp := sp+1; 696 | store[sp] := store[q] 697 | end; 698 | 699 | 70,71,72,73,74, 700 | 2 (*str*): begin store[base(p)+q] := store[sp]; 701 | sp := sp-1 702 | end; 703 | 704 | 75,76,77,78,79, 705 | 3 (*sro*): begin store[q] := store[sp]; 706 | sp := sp-1 707 | end; 708 | 709 | 4 (*lda*): begin sp := sp+1; 710 | store[sp].va := base(p) + q 711 | end; 712 | 713 | 5 (*lao*): begin sp := sp+1; 714 | store[sp].va := q 715 | end; 716 | 717 | 80,81,82,83,84, 718 | 6 (*sto*): begin 719 | store[store[sp-1].va] := store[sp]; 720 | sp := sp-2; 721 | end; 722 | 723 | 7 (*ldc*): begin sp := sp+1; 724 | if p=1 then 725 | begin store[sp].vi := q; 726 | end else 727 | if p = 6 then store[sp].vc := chr(q) 728 | else 729 | if p = 3 then store[sp].vb := q = 1 730 | else (* load nil *) store[sp].va := maxstr 731 | end; 732 | 733 | 8 (*lci*): begin sp := sp+1; 734 | store[sp] := store[q] 735 | end; 736 | 737 | 85,86,87,88,89, 738 | 9 (*ind*): begin ad := store[sp].va + q; 739 | (* q is a number of storage units *) 740 | store[sp] := store[ad] 741 | end; 742 | 743 | 90,91,92,93,94, 744 | 10 (*inc*): store[sp].vi := store[sp].vi+q; 745 | 746 | 11 (*mst*): begin (*p=level of calling procedure minus level of called 747 | procedure + 1; set dl and sl, increment sp*) 748 | (* then length of this element is 749 | max(intsize,realsize,boolsize,charsize,ptrsize *) 750 | store[sp+2].vm := base(p); 751 | (* the length of this element is ptrsize *) 752 | store[sp+3].vm := mp; 753 | (* idem *) 754 | store[sp+4].vm := ep; 755 | (* idem *) 756 | sp := sp+5 757 | end; 758 | 759 | 12 (*cup*): begin (*p=no of locations for parameters, q=entry point*) 760 | mp := sp-(p+4); 761 | store[mp+4].vm := pc; 762 | pc := q 763 | end; 764 | 765 | 13 (*ent*): if p = 1 then 766 | begin sp := mp + q; (*q = length of dataseg*) 767 | if sp > np then errori(' store overflow '); 768 | end 769 | else 770 | begin ep := sp+q; 771 | if ep > np then errori(' store overflow '); 772 | end; 773 | (*q = max space required on stack*) 774 | 775 | 14 (*ret*): begin case p of 776 | 0: sp:= mp-1; 777 | 1,2,3,4,5: sp:= mp 778 | end; 779 | pc := store[mp+4].vm; 780 | ep := store[mp+3].vm; 781 | mp:= store[mp+2].vm; 782 | end; 783 | 784 | 15 (*csp*): callsp; 785 | 786 | 16 (*ixa*): begin 787 | i := store[sp].vi; 788 | sp := sp-1; 789 | store[sp].va := q*i+store[sp].va; 790 | end; 791 | 792 | 17 (*equ*): begin sp := sp-1; 793 | case p of 794 | 1: store[sp].vb := store[sp].vi = store[sp+1].vi; 795 | 0: store[sp].vb := store[sp].va = store[sp+1].va; 796 | 6: store[sp].vb := store[sp].vc = store[sp+1].vc; 797 | 2: store[sp].vb := store[sp].vr = store[sp+1].vr; 798 | 3: store[sp].vb := store[sp].vb = store[sp+1].vb; 799 | 4: store[sp].vb := store[sp].vs = store[sp+1].vs; 800 | 5: begin compare; 801 | store[sp].vb := b; 802 | end; 803 | end; (*case p*) 804 | end; 805 | 806 | 18 (*neq*): begin sp := sp-1; 807 | case p of 808 | 0: store[sp].vb := store[sp].va <> store[sp+1].va; 809 | 1: store[sp].vb := store[sp].vi <> store[sp+1].vi; 810 | 6: store[sp].vb := store[sp].vc <> store[sp+1].vc; 811 | 2: store[sp].vb := store[sp].vr <> store[sp+1].vr; 812 | 3: store[sp].vb := store[sp].vb <> store[sp+1].vb; 813 | 4: store[sp].vb := store[sp].vs <> store[sp+1].vs; 814 | 5: begin compare; 815 | store[sp].vb := not b; 816 | end 817 | end; (*case p*) 818 | end; 819 | 820 | 19 (*geq*): begin sp := sp-1; 821 | case p of 822 | 0: errori(' <,<=,>,>= for address '); 823 | 1: store[sp].vb := store[sp].vi >= store[sp+1].vi; 824 | 6: store[sp].vb := store[sp].vc >= store[sp+1].vc; 825 | 2: store[sp].vb := store[sp].vr >= store[sp+1].vr; 826 | 3: store[sp].vb := store[sp].vb >= store[sp+1].vb; 827 | 4: store[sp].vb := store[sp].vs >= store[sp+1].vs; 828 | 5: begin compare; 829 | store[sp].vb := b or 830 | (store[i1+i].vi >= store[i2+i].vi) 831 | end 832 | end; (*case p*) 833 | end; 834 | 835 | 20 (*grt*): begin sp := sp-1; 836 | case p of 837 | 0: errori(' <,<=,>,>= for address '); 838 | 1: store[sp].vb := store[sp].vi > store[sp+1].vi; 839 | 6: store[sp].vb := store[sp].vc > store[sp+1].vc; 840 | 2: store[sp].vb := store[sp].vr > store[sp+1].vr; 841 | 3: store[sp].vb := store[sp].vb > store[sp+1].vb; 842 | 4: errori(' set inclusion '); 843 | 5: begin compare; 844 | store[sp].vb := not b and 845 | (store[i1+i].vi > store[i2+i].vi) 846 | end 847 | end; (*case p*) 848 | end; 849 | 850 | 21 (*leq*): begin sp := sp-1; 851 | case p of 852 | 0: errori(' <,<=,>,>= for address '); 853 | 1: store[sp].vb := store[sp].vi <= store[sp+1].vi; 854 | 6: store[sp].vb := store[sp].vc <= store[sp+1].vc; 855 | 2: store[sp].vb := store[sp].vr <= store[sp+1].vr; 856 | 3: store[sp].vb := store[sp].vb <= store[sp+1].vb; 857 | 4: store[sp].vb := store[sp].vs <= store[sp+1].vs; 858 | 5: begin compare; 859 | store[sp].vb := b or 860 | (store[i1+i].vi <= store[i2+i].vi) 861 | end; 862 | end; (*case p*) 863 | end; 864 | 865 | 22 (*les*): begin sp := sp-1; 866 | case p of 867 | 0: errori(' <,<=,>,>= for address '); 868 | 1: store[sp].vb := store[sp].vi < store[sp+1].vi; 869 | 6: store[sp].vb := store[sp].vc < store[sp+1].vc; 870 | 2: store[sp].vb := store[sp].vr < store[sp+1].vr; 871 | 3: store[sp].vb := store[sp].vb < store[sp+1].vb; 872 | 5: begin compare; 873 | store[sp].vb := not b and 874 | (store[i1+i].vi < store[i2+i].vi) 875 | end 876 | end; (*case p*) 877 | end; 878 | 879 | 23 (*ujp*): pc := q; 880 | 881 | 24 (*fjp*): begin if not store[sp].vb then pc := q; 882 | sp := sp-1 883 | end; 884 | 885 | 25 (*xjp*): begin 886 | pc := store[sp].vi + q; 887 | sp := sp-1 888 | end; 889 | 890 | 95 (*chka*): if (store[sp].va < np) or 891 | (store[sp].va > (maxstr-q)) then 892 | errori(' bad pointer value '); 893 | 894 | 96,97,98,99, 895 | 26 (*chk*): if (store[sp].vi < store[q-1].vi) or 896 | (store[sp].vi > store[q].vi) then 897 | errori(' value out of range '); 898 | 899 | 27 (*eof*): begin i := store[sp].vi; 900 | if i=inputadr then 901 | begin store[sp].vb := eof(input); 902 | end else errori(' code in error ') 903 | end; 904 | 905 | 28 (*adi*): begin sp := sp-1; 906 | store[sp].vi := store[sp].vi + store[sp+1].vi 907 | end; 908 | 909 | 29 (*adr*): begin sp := sp-1; 910 | store[sp].vr := store[sp].vr + store[sp+1].vr 911 | end; 912 | 913 | 30 (*sbi*): begin sp := sp-1; 914 | store[sp].vi := store[sp].vi - store[sp+1].vi 915 | end; 916 | 917 | 31 (*sbr*): begin sp := sp-1; 918 | store[sp].vr := store[sp].vr - store[sp+1].vr 919 | end; 920 | 921 | 32 (*sgs*): store[sp].vs := [store[sp].vi]; 922 | 923 | 33 (*flt*): store[sp].vr := store[sp].vi; 924 | 925 | 34 (*flo*): store[sp-1].vr := store[sp-1].vi; 926 | 927 | 35 (*trc*): store[sp].vi := trunc(store[sp].vr); 928 | 929 | 36 (*ngi*): store[sp].vi := -store[sp].vi; 930 | 931 | 37 (*ngr*): store[sp].vr := -store[sp].vr; 932 | 933 | 38 (*sqi*): store[sp].vi := sqr(store[sp].vi); 934 | 935 | 39 (*sqr*): store[sp].vr := sqr(store[sp].vr); 936 | 937 | 40 (*abi*): store[sp].vi := abs(store[sp].vi); 938 | 939 | 41 (*abr*): store[sp].vr := abs(store[sp].vr); 940 | 941 | 42 (*not*): store[sp].vb := not store[sp].vb; 942 | 943 | 43 (*and*): begin sp := sp-1; 944 | store[sp].vb := store[sp].vb and store[sp+1].vb 945 | end; 946 | 947 | 44 (*ior*): begin sp := sp-1; 948 | store[sp].vb := store[sp].vb or store[sp+1].vb 949 | end; 950 | 951 | 45 (*dif*): begin sp := sp-1; 952 | store[sp].vs := store[sp].vs - store[sp+1].vs 953 | end; 954 | 955 | 46 (*int*): begin sp := sp-1; 956 | store[sp].vs := store[sp].vs * store[sp+1].vs 957 | end; 958 | 959 | 47 (*uni*): begin sp := sp-1; 960 | store[sp].vs := store[sp].vs + store[sp+1].vs 961 | end; 962 | 963 | 48 (*inn*): begin 964 | sp := sp - 1; i := store[sp].vi; 965 | store[sp].vb := i in store[sp+1].vs; 966 | end; 967 | 968 | 49 (*mod*): begin sp := sp-1; 969 | store[sp].vi := store[sp].vi mod store[sp+1].vi 970 | end; 971 | 972 | 50 (*odd*): store[sp].vb := odd(store[sp].vi); 973 | 974 | 51 (*mpi*): begin sp := sp-1; 975 | store[sp].vi := store[sp].vi * store[sp+1].vi 976 | end; 977 | 978 | 52 (*mpr*): begin sp := sp-1; 979 | store[sp].vr := store[sp].vr * store[sp+1].vr 980 | end; 981 | 982 | 53 (*dvi*): begin sp := sp-1; 983 | store[sp].vi := store[sp].vi div store[sp+1].vi 984 | end; 985 | 986 | 54 (*dvr*): begin sp := sp-1; 987 | store[sp].vr := store[sp].vr / store[sp+1].vr 988 | end; 989 | 990 | 55 (*mov*): begin i1 := store[sp-1].va; 991 | i2 := store[sp].va; sp := sp-2; 992 | for i := 0 to q-1 do store[i1+i] := store[i2+i] 993 | (* q is a number of storage units *) 994 | end; 995 | 996 | 56 (*lca*): begin sp := sp+1; 997 | store[sp].va := q; 998 | end; 999 | 1000 | 100,101,102,103,104, 1001 | 57 (*dec*): store[sp].vi := store[sp].vi-q; 1002 | 1003 | 58 (*stp*): interpreting := false; 1004 | 1005 | 59 (*ord*): (*only used to change the tagfield*) 1006 | begin 1007 | end; 1008 | 1009 | 60 (*chr*): begin 1010 | end; 1011 | 1012 | 61 (*ujc*): errori(' case - error '); 1013 | end 1014 | end; (*while interpreting*) 1015 | 1016 | 1 : 1017 | end. 1018 | -------------------------------------------------------------------------------- /super/assemble.p: -------------------------------------------------------------------------------- 1 | { SUPERPASCAL COMPILER 2 | ASSEMBLER 3 | 20 August 1993 4 | Copyright (c) 1993 Per Brinch Hansen } 5 | 6 | procedure assemble( 7 | optimizing: boolean; 8 | procedure get(var value: integer); 9 | procedure put(value: integer); 10 | procedure getreal(var value: real); 11 | procedure putreal(value: real); 12 | procedure getstring( 13 | var length: integer; 14 | var value: string); 15 | procedure putstring( 16 | length: integer; 17 | value: string); 18 | procedure getcase( 19 | var lineno, length: integer; 20 | var table: casetable); 21 | procedure putcase( 22 | lineno, length: integer; 23 | table: casetable); 24 | procedure rerun; 25 | procedure halt(kind: phrase)); 26 | type 27 | operations = set of minoperation 28 | ..maxoperation; 29 | assemblytable = 30 | array [1..maxlabel] of integer; 31 | var 32 | noarguments, oneargument, 33 | twoarguments, threearguments, 34 | fourarguments, fivearguments, 35 | jumps: operations; 36 | blockno, address, op, arg1, arg2, 37 | arg3, arg4, arg5: integer; 38 | realarg: real; 39 | stringarg: string; 40 | casearg: casetable; 41 | table: assemblytable; 42 | 43 | procedure nextinstruction; 44 | begin 45 | get(op); 46 | if op in noarguments then 47 | { skip } 48 | else if op in oneargument then 49 | get(arg1) 50 | else if op in twoarguments then 51 | begin 52 | get(arg1); get(arg2) 53 | end 54 | else if op in threearguments then 55 | begin 56 | get(arg1); get(arg2); 57 | get(arg3) 58 | end 59 | else if op in fourarguments then 60 | begin 61 | get(arg1); get(arg2); 62 | get(arg3); get(arg4) 63 | end 64 | else if op in fivearguments then 65 | begin 66 | get(arg1); get(arg2); 67 | get(arg3); get(arg4); 68 | get(arg5) 69 | end 70 | else if op = realconst2 then 71 | getreal(realarg) 72 | else if op = stringconst2 then 73 | getstring(arg1, stringarg) 74 | else { op = caseconst2 } 75 | getcase(arg1, arg2, 76 | casearg) 77 | end; 78 | 79 | procedure emit1(op: integer); 80 | begin 81 | put(op); 82 | address := address + 1 83 | end; 84 | 85 | procedure emit2( 86 | op, arg: integer); 87 | begin 88 | put(op); put(arg); 89 | address := address + 2 90 | end; 91 | 92 | procedure emit3( 93 | op, arg1, arg2: integer); 94 | begin 95 | put(op); put(arg1); 96 | put(arg2); 97 | address := address + 3 98 | end; 99 | 100 | procedure emit4( 101 | op, arg1, arg2, 102 | arg3: integer); 103 | begin 104 | put(op); put(arg1); 105 | put(arg2); put(arg3); 106 | address := address + 4 107 | end; 108 | 109 | procedure emit5( 110 | op, arg1, arg2, arg3, 111 | arg4: integer); 112 | begin 113 | put(op); put(arg1); 114 | put(arg2); put(arg3); 115 | put(arg4); 116 | address := address + 5 117 | end; 118 | 119 | procedure emit6( 120 | op, arg1, arg2, arg3, 121 | arg4, arg5: integer); 122 | begin 123 | put(op); put(arg1); 124 | put(arg2); put(arg3); 125 | put(arg4); put(arg5); 126 | address := address + 6 127 | end; 128 | 129 | procedure emit7( 130 | op, arg1, arg2, arg3, arg4, 131 | arg5, arg6: integer); 132 | begin 133 | put(op); put(arg1); 134 | put(arg2); put(arg3); 135 | put(arg4); put(arg5); 136 | put(arg6); 137 | address := address + 7 138 | end; 139 | 140 | procedure emitreal( 141 | value: real); 142 | begin 143 | put(realconst2); 144 | putreal(value); 145 | address := address + 3 146 | end; 147 | 148 | procedure emitstring( 149 | length: integer; 150 | value: string); 151 | begin 152 | put(stringconst2); 153 | putstring(length, value); 154 | address := 155 | address + length + 2 156 | end; 157 | 158 | procedure emitcase( 159 | lineno, length: integer; 160 | table: casetable); 161 | begin 162 | put(case2); 163 | putcase(lineno, length, 164 | table); 165 | address := 166 | address + 2*length + 3 167 | end; 168 | 169 | procedure newblock; 170 | begin 171 | if blockno = maxblock then 172 | halt(maxblock5); 173 | blockno := blockno + 1 174 | end; 175 | 176 | function optimize(condition: 177 | boolean): boolean; 178 | begin 179 | optimize := 180 | optimizing and condition 181 | end; 182 | 183 | function templength(labelno: 184 | integer): integer; 185 | begin 186 | { include block link 187 | (or process state) 188 | of length 4 (or 3) } 189 | templength := 190 | table[labelno] + 4 191 | end; 192 | 193 | function jumpdispl(labelno: 194 | integer): integer; 195 | begin 196 | jumpdispl := 197 | table[labelno] - address 198 | end; 199 | 200 | procedure assign( 201 | length: integer); 202 | begin 203 | if optimize(length = 1) 204 | then emit1(ordassign2) 205 | else if optimize(length = 2) 206 | then emit1(realassign2) 207 | else emit2(assign2, length); 208 | nextinstruction 209 | end; 210 | 211 | procedure casex( 212 | lineno, length: integer; 213 | table: casetable); 214 | var i: integer; 215 | begin 216 | for i := 1 to length do 217 | table[i].index := 218 | jumpdispl( 219 | table[i].index); 220 | emitcase(lineno, length, 221 | table); 222 | nextinstruction 223 | end; 224 | 225 | procedure defaddr(labelno: 226 | integer); 227 | begin 228 | table[labelno] := address; 229 | nextinstruction 230 | end; 231 | 232 | procedure defarg(labelno, 233 | value: integer); 234 | begin 235 | table[labelno] := value; 236 | nextinstruction 237 | end; 238 | 239 | procedure endprocess(exitlabel, 240 | lineno: integer); 241 | begin 242 | emit3(endprocess2, 243 | jumpdispl(exitlabel), 244 | lineno); 245 | nextinstruction 246 | end; 247 | 248 | procedure field(displ: integer); 249 | begin 250 | if optimize(displ = 0) 251 | then { empty } 252 | else emit2(field2, displ); 253 | nextinstruction 254 | end; 255 | 256 | procedure forall(templabel, 257 | endlabel, lineno: integer); 258 | begin 259 | newblock; 260 | emit5(forall2, blockno, 261 | templength(templabel), 262 | jumpdispl(endlabel), 263 | lineno); 264 | nextinstruction 265 | end; 266 | 267 | procedure jump(op, labelno: 268 | integer); 269 | begin 270 | { op in [do2, downto2, 271 | enddown2, endto2, 272 | goto2, to2] } 273 | emit2(op, 274 | jumpdispl(labelno)); 275 | nextinstruction 276 | end; 277 | 278 | procedure proccall(level, 279 | labelno: integer); 280 | var displ: integer; 281 | begin 282 | displ := jumpdispl(labelno); 283 | if optimize(level = 1) then 284 | emit2(globalcall2, displ) 285 | else 286 | emit3(proccall2, level, 287 | displ); 288 | nextinstruction 289 | end; 290 | 291 | procedure procedur(paramlength, 292 | varlabel, templabel, 293 | beginlabel, lineno: integer); 294 | begin 295 | newblock; 296 | emit7(procedure2, blockno, 297 | paramlength, 298 | table[varlabel], 299 | templength(templabel), 300 | jumpdispl(beginlabel), 301 | lineno); 302 | nextinstruction 303 | end; 304 | 305 | procedure process(templabel, 306 | endlabel, lineno: integer); 307 | begin 308 | newblock; 309 | emit5(process2, blockno, 310 | templength(templabel), 311 | jumpdispl(endlabel), 312 | lineno); 313 | nextinstruction 314 | end; 315 | 316 | procedure programx(varlabel, 317 | templabel, beginlabel, 318 | lineno: integer); 319 | begin 320 | newblock; 321 | emit6(program2, blockno, 322 | table[varlabel], 323 | templength(templabel), 324 | jumpdispl(beginlabel), 325 | lineno); 326 | nextinstruction 327 | end; 328 | 329 | procedure value(length: integer); 330 | begin 331 | if optimize(length = 1) 332 | then emit1(ordvalue2) 333 | else if optimize(length = 2) 334 | then emit1(realvalue2) 335 | else emit2(value2, length); 336 | nextinstruction 337 | end; 338 | 339 | procedure variable(level, displ: 340 | integer); 341 | begin 342 | if displ >= 0 then 343 | { include block link 344 | of length 4 } 345 | displ := displ + 4; 346 | nextinstruction; 347 | while optimize(op = field2) do 348 | begin 349 | displ := displ + arg1; 350 | nextinstruction 351 | end; 352 | if optimize(level = 0) then 353 | if (op = value2) and 354 | (arg1 = 1) then 355 | begin 356 | emit2(localvalue2, 357 | displ); 358 | nextinstruction 359 | end 360 | else if (op = value2) and 361 | (arg1 = 2) then 362 | begin 363 | emit2(localreal2, 364 | displ); 365 | nextinstruction 366 | end 367 | else emit2(localvar2, displ) 368 | else if optimize(level = 1) then 369 | if (op = value2) and 370 | (arg1 = 1) then 371 | begin 372 | emit2(globalvalue2, 373 | displ); 374 | nextinstruction 375 | end 376 | else emit2(globalvar2, displ) 377 | else 378 | emit3(variable2, level, displ) 379 | end; 380 | 381 | procedure copyinstruction; 382 | begin 383 | if op in noarguments 384 | then emit1(op) 385 | else if op in oneargument 386 | then emit2(op, arg1) 387 | else if op in twoarguments 388 | then emit3(op, arg1, arg2) 389 | else if op in threearguments 390 | then 391 | emit4(op, arg1, arg2, 392 | arg3) 393 | else if op in fourarguments 394 | then 395 | emit5(op, arg1, arg2, 396 | arg3, arg4) 397 | else if op in fivearguments 398 | then 399 | emit6(op, arg1, arg2, 400 | arg3, arg4, arg5) 401 | else if op = realconst2 402 | then emitreal(realarg) 403 | else { op = stringconst2 } 404 | emitstring(arg1, 405 | stringarg); 406 | nextinstruction 407 | end; 408 | 409 | procedure assemble; 410 | begin 411 | blockno := 0; 412 | address := 0; 413 | nextinstruction; 414 | while op <> endprog2 do 415 | if op = assign2 then 416 | assign(arg1) 417 | else if op = case2 then 418 | casex(arg1, arg2, casearg) 419 | else if op = defaddr2 then 420 | defaddr(arg1) 421 | else if op = defarg2 then 422 | defarg(arg1, arg2) 423 | else if op = endprocess2 then 424 | endprocess(arg1, arg2) 425 | else if op = field2 then 426 | field(arg1) 427 | else if op = forall2 then 428 | forall(arg1, arg2, arg3) 429 | else if op in jumps then 430 | jump(op, arg1) 431 | else if op = proccall2 then 432 | proccall(arg1, arg2) 433 | else if op = procedure2 then 434 | procedur(arg1, arg2, arg3, 435 | arg4, arg5) 436 | else if op = process2 then 437 | process(arg1, arg2, arg3) 438 | else if op = program2 then 439 | programx(arg1, arg2, arg3, 440 | arg4) 441 | else if op = value2 then 442 | value(arg1) 443 | else if op = variable2 then 444 | variable(arg1, arg2) 445 | else copyinstruction; 446 | emit1(endprog2) 447 | end; 448 | 449 | procedure initialize; 450 | var labelno: integer; 451 | begin 452 | noarguments := 453 | [and2, endio2, endproc2, 454 | endprog2, eqord2, eqreal2, 455 | eqstring2, float2, 456 | floatleft2, for2, grord2, 457 | grreal2, grstring2, lsord2, 458 | lsreal2, lsstring2, neord2, 459 | nereal2, nestring2, ngord2, 460 | ngreal2, ngstring2, nlord2, 461 | nlreal2, nlstring2, not2, 462 | odd2, or2, parallel2]; 463 | oneargument := 464 | [abs2, absint2, add2, 465 | addreal2, arctan2, assign2, 466 | assume2, checkio2, chr2, 467 | cos2, divide2, divreal2, 468 | do2, downto2, endall2, 469 | enddown2, endparallel2, 470 | endto2, eof2, eoln2, 471 | equal2, exp2, field2, 472 | goto2, ln2, minus2, 473 | minusreal2, modulo2, multiply2, 474 | multreal2, notequal2, open2, 475 | ordconst2, read2, readint2, 476 | readln2, readreal2, result2, 477 | round2, sin2, sqr2, 478 | sqrint2, sqrt2, subreal2, 479 | subtract2, to2, trunc2, 480 | value2, writeln2, defaddr2]; 481 | twoarguments := 482 | [endprocess2, pred2, 483 | proccall2, succ2, variable2, 484 | varparam2, write2, 485 | writebool2, writeint2, 486 | writestring2, defarg2]; 487 | threearguments := 488 | [forall2, process2, 489 | receive2, send2, 490 | writereal2]; 491 | fourarguments := 492 | [index2, program2]; 493 | fivearguments := 494 | [procedure2]; 495 | jumps := 496 | [do2, downto2, enddown2, 497 | endto2, goto2, to2]; 498 | for labelno := 1 to maxlabel 499 | do table[labelno] := 0 500 | end; 501 | 502 | begin 503 | initialize; assemble; 504 | rerun; assemble 505 | end; 506 | -------------------------------------------------------------------------------- /super/common.p: -------------------------------------------------------------------------------- 1 | { SUPERPASCAL COMPILER AND INTERPRETER 2 | COMMON BLOCK 3 | 3 Novemver 1993 4 | Copyright (c) 1993 Per Brinch Hansen } 5 | 6 | const 7 | { compilation options } 8 | 9 | testoptions = false; 10 | restricted = true; 11 | 12 | { software limits } 13 | 14 | maxaddr = 100000; maxblock = 200; 15 | maxbuf = 10000; maxcase = 128; 16 | maxchan = 10000; maxchar = 10000; 17 | maxlabel = 1000; maxlevel = 10; 18 | maxphrase = 30; maxstring = 80; 19 | minreal = 1.0e-307; 20 | maxreal = 1.0e+307; 21 | 22 | { standard identifiers } 23 | 24 | minstandard = 1; 25 | maxstandard = 34; 26 | abs0 = 1; arctan0 = 2; 27 | boolean0 = 3; char0 = 4; 28 | chr0 = 5; cos0 = 6; 29 | eof0 = 7; eoln0 = 8; 30 | exp0 = 9; false0 = 10; 31 | integer0 = 11; ln0 = 12; 32 | maxint0 = 13; maxstring0 = 14; 33 | null0 = 15; odd0 = 16; 34 | open0 = 17; ord0 = 18; 35 | pred0 = 19; read0 = 20; 36 | readln0 = 21; real0 = 22; 37 | receive0 = 23; round0 = 24; 38 | send0 = 25; sin0 = 26; 39 | sqr0 = 27; sqrt0 = 28; 40 | string0 = 29; succ0 = 30; 41 | true0 = 31; trunc0 = 32; 42 | write0 = 33; writeln0 = 34; 43 | 44 | { tokens } 45 | 46 | mintoken = 0; maxtoken = 59; 47 | and1 = 0; array1 = 1; 48 | assume1 = 2; asterisk1 = 3; 49 | bar1 = 4; becomes1 = 5; 50 | begin1 = 6; case1 = 7; 51 | charconst1 = 8; colon1 = 9; 52 | comma1 = 10; const1 = 11; 53 | div1 = 12; do1 = 13; 54 | downto1 = 14; doubledot1 = 15; 55 | else1 = 16; end1 = 17; 56 | endtext1 = 18; equal1 = 19; 57 | for1 = 20; forall1 = 21; 58 | function1 = 22; greater1 = 23; 59 | identifier1 = 24; if1 = 25; 60 | intconst1 = 26; 61 | leftbracket1 = 27; 62 | leftparenthesis1 = 28; 63 | less1 = 29; minus1 = 30; 64 | mod1 = 31; newline1 = 32; 65 | not1 = 33; notequal1 = 34; 66 | notgreater1 = 35; notless1 = 36; 67 | of1 = 37; or1 = 38; 68 | parallel1 = 39; period1 = 40; 69 | plus1 = 41; procedure1 = 42; 70 | program1 = 43; realconst1 = 44; 71 | record1 = 45; repeat1 = 46; 72 | rightbracket1 = 47; 73 | rightparenthesis1 = 48; 74 | semicolon1 = 49; sic1 = 50; 75 | slash1 = 51; stringconst1 = 52; 76 | then1 = 53; to1 = 54; 77 | type1 = 55; until1 = 56; 78 | var1 = 57; while1 = 58; 79 | unknown1 = 59; 80 | 81 | { operation parts } 82 | 83 | minoperation = 0; 84 | maxoperation = 110; 85 | abs2 = 0; absint2 = 1; 86 | add2 = 2; addreal2 = 3; 87 | and2 = 4; arctan2 = 5; 88 | assign2 = 6; assume2 = 7; 89 | case2 = 8; checkio2 = 9; 90 | chr2 = 10; cos2 = 11; 91 | divide2 = 12; divreal2 = 13; 92 | do2 = 14; downto2 = 15; 93 | endall2 = 16; enddown2 = 17; 94 | endio2 = 18; endparallel2 = 19; 95 | endproc2 = 20; endprocess2 = 21; 96 | endprog2 = 22; endto2 = 23; 97 | eof2 = 24; eoln2 = 25; 98 | eqord2 = 26; eqreal2 = 27; 99 | eqstring2 = 28; equal2 = 29; 100 | exp2 = 30; field2 = 31; 101 | float2 = 32; floatleft2 = 33; 102 | for2 = 34; forall2 = 35; 103 | goto2 = 36; grord2 = 37; 104 | grreal2 = 38; grstring2 = 39; 105 | index2 = 40; ln2 = 41; 106 | lsord2 = 42; lsreal2 = 43; 107 | lsstring2 = 44; minus2 = 45; 108 | minusreal2 = 46; modulo2 = 47; 109 | multiply2 = 48; multreal2 = 49; 110 | neord2 = 50; nereal2 = 51; 111 | nestring2 = 52; ngord2 = 53; 112 | ngreal2 = 54; ngstring2 = 55; 113 | nlord2 = 56; nlreal2 = 57; 114 | nlstring2 = 58; not2 = 59; 115 | notequal2 = 60; odd2 = 61; 116 | open2 = 62; or2 = 63; 117 | ordconst2 = 64; parallel2 = 65; 118 | pred2 = 66; proccall2 = 67; 119 | procedure2 = 68; process2 = 69; 120 | program2 = 70; read2 = 71; 121 | readint2 = 72; readln2 = 73; 122 | readreal2 = 74; realconst2 = 75; 123 | receive2 = 76; result2 = 77; 124 | round2 = 78; send2 = 79; 125 | sin2 = 80; sqr2 = 81; 126 | sqrint2 = 82; sqrt2 = 83; 127 | stringconst2 = 84; 128 | subreal2 = 85; subtract2 = 86; 129 | succ2 = 87; to2 = 88; 130 | trunc2 = 89; value2 = 90; 131 | variable2 = 91; varparam2 = 92; 132 | write2 = 93; writebool2 = 94; 133 | writeint2 = 95; writeln2 = 96; 134 | writereal2 = 97; 135 | writestring2 = 98; 136 | globalcall2 = 99; 137 | globalvalue2 = 100; 138 | globalvar2 = 101; 139 | localreal2 = 102; 140 | localvalue2 = 103; 141 | localvar2 = 104; 142 | ordassign2 = 105; 143 | ordvalue2 = 106; 144 | realassign2 = 107; 145 | realvalue2 = 108; 146 | defaddr2 = 109; defarg2 = 110; 147 | 148 | { compile-time errors } 149 | 150 | ambiguous3 = 151 | 'ambiguous identifier '; 152 | block3 = 153 | 'function block error '; 154 | case3 = 155 | 'ambiguous case constant '; 156 | comment3 = 157 | 'incomplete comment '; 158 | forall3 = 159 | 'forall statement error '; 160 | kind3 = 161 | 'identifier kind error '; 162 | number3 = 163 | 'number error '; 164 | parallel3 = 165 | 'parallel statement error '; 166 | parameter3 = 167 | 'function parameter error '; 168 | procedure3 = 169 | 'procedure statement error '; 170 | range3 = 171 | 'index range error '; 172 | recursion3 = 173 | 'recursion error '; 174 | syntax3 = 175 | 'syntax error '; 176 | type3 = 177 | 'type error '; 178 | undefined3 = 179 | 'undefined identifier '; 180 | 181 | { run-time errors } 182 | 183 | assume4 = 184 | 'false assumption '; 185 | case4 = 186 | 'undefined case constant '; 187 | channel4 = 188 | 'undefined channel reference '; 189 | contention4 = 190 | 'channel contention '; 191 | deadlock4 = 192 | 'deadlock '; 193 | range4 = 194 | 'range error '; 195 | type4 = 196 | 'message type error '; 197 | 198 | { software failure } 199 | 200 | maxaddr5 = 201 | 'memory limit exceeded '; 202 | maxblock5 = 203 | 'block limit exceeded '; 204 | maxbuf5 = 205 | 'buffer limit exceeded '; 206 | maxcase5 = 207 | 'case limit exceeded '; 208 | maxchan5 = 209 | 'channel limit exceeded '; 210 | maxchar5 = 211 | 'character limit exceeded '; 212 | maxlabel5 = 213 | 'branch limit exceeded '; 214 | maxlevel5 = 215 | 'nesting limit exceeded '; 216 | maxstring5 = 217 | 'string limit exceeded '; 218 | 219 | { miscellaneous phrases } 220 | 221 | assembled = 222 | 'assembled '; 223 | errorfile = 224 | 'errors '; 225 | fileconflict = 226 | 'use different source and code '; 227 | keyboard = 228 | 'keyboard '; 229 | no = 230 | 'no '; 231 | parsed = 232 | 'parsed '; 233 | scanned = 234 | 'scanned '; 235 | screen = 236 | 'screen '; 237 | yes = 238 | 'yes '; 239 | 240 | { characters and ordinal values } 241 | 242 | apostrophe = '''' ; sp = ' '; 243 | etx = 3; del = 127; nl = 10; 244 | null = 0; 245 | 246 | type 247 | { common types } 248 | 249 | binary = file of integer; 250 | caserecord = 251 | record 252 | value, index: integer 253 | end; 254 | casetable = 255 | array [1..maxcase] of caserecord; 256 | phrase = 257 | packed array [1..maxphrase] of 258 | char; 259 | string = 260 | packed array [1..maxstring] of 261 | char; 262 | { a dual real is used with 263 | an undefined tag field to 264 | convert a real "a" to its 265 | binary representation by 266 | two integers "b" and "c" 267 | (or vice versa) } 268 | dualreal = 269 | record 270 | case split: boolean of 271 | false: (a: real); 272 | true: (b, c: integer) 273 | end; 274 | 275 | { phrase routines } 276 | 277 | function phraselength( 278 | value: phrase): integer; 279 | var i, j: integer; 280 | begin 281 | i := 0; j := maxphrase; 282 | while i < j do 283 | if value[j] = sp 284 | then j := j - 1 285 | else i := j; 286 | phraselength := i 287 | end; 288 | 289 | procedure writephrase( 290 | var outfile: text; 291 | value: phrase); 292 | begin 293 | write(outfile, value: 294 | phraselength(value)) 295 | end; 296 | 297 | procedure readphrase( 298 | var value: phrase); 299 | var ch: char; i: integer; 300 | begin 301 | repeat 302 | while eoln do readln; 303 | read(ch) 304 | until ch <> sp; 305 | value[1] := ch; 306 | for i := 2 to maxphrase do 307 | if not eoln 308 | then read(value[i]) 309 | else value[i] := sp; 310 | while not eoln do read(ch); 311 | readln 312 | end; 313 | 314 | procedure readboolean( 315 | var value: boolean); 316 | var word: phrase; 317 | begin 318 | readphrase(word); 319 | while (word <> yes) 320 | and (word <> no) do 321 | begin 322 | write( 323 | ' yes or no? '); 324 | readphrase(word) 325 | end; 326 | value := (word = yes) 327 | end; 328 | 329 | { string routines } 330 | 331 | function stringlength( 332 | value: string): integer; 333 | var i, j: integer; 334 | begin 335 | i := 0; j := maxstring; 336 | while i < j do 337 | if value[j] = chr(null) 338 | then j := j - 1 339 | else i := j; 340 | stringlength := i 341 | end; 342 | 343 | procedure writestring( 344 | var outfile: text; 345 | value: string; 346 | width: integer); 347 | var i, n: integer; 348 | begin 349 | n := stringlength(value); 350 | if width > n then 351 | for i := 1 to width - n do 352 | write(outfile, sp) 353 | else n := width; 354 | write(outfile, value:n) 355 | end; 356 | -------------------------------------------------------------------------------- /super/compile.p: -------------------------------------------------------------------------------- 1 | { SUPERPASCAL COMPILER 2 | MAIN PROGRAM 3 | 20 August 1993 4 | Copyright (c) 1993 Per Brinch Hansen } 5 | 6 | program main(input, output); 7 | #include "common.p" 8 | #include "scan.p" 9 | #include "parse.p" 10 | #include "assemble.p" 11 | 12 | procedure compile; 13 | label 1 { exit }; 14 | type 15 | table = 16 | array [1..maxbuf] of 17 | integer; 18 | buffer = 19 | record 20 | contents: table; 21 | length: integer 22 | end; 23 | var 24 | sourcename, codename: phrase; 25 | errors, source: text; 26 | code: binary; 27 | inpbuf, outbuf: buffer; 28 | compiled, endline, lineok, 29 | optimizing, testing: boolean; 30 | lineno, pass: integer; 31 | 32 | procedure error(kind: phrase); 33 | var n: integer; 34 | begin 35 | if lineok then 36 | begin 37 | if compiled then 38 | begin 39 | compiled := false; 40 | writeln 41 | end; 42 | n := phraselength(kind); 43 | writeln(errors, 44 | 'line ', lineno:4, sp, 45 | kind:n); 46 | writeln( 47 | 'line ', lineno:4, sp, 48 | kind:n); 49 | lineok := false 50 | end 51 | end; 52 | 53 | procedure halt(kind: phrase); 54 | var n: integer; 55 | begin 56 | if compiled then 57 | begin 58 | compiled := false; 59 | writeln 60 | end; 61 | n := phraselength(kind); 62 | writeln(errors, 63 | 'line ', lineno:4, sp, 64 | kind:n); 65 | writeln( 66 | 'line ', lineno:4, sp, 67 | kind:n); 68 | goto 1 69 | end; 70 | 71 | procedure newline(no: integer); 72 | begin 73 | lineno := no; 74 | lineok := true 75 | end; 76 | 77 | procedure accept(var ch: char); 78 | begin 79 | if eof(source) then 80 | begin 81 | lineno := lineno + 1; 82 | ch := chr(etx) 83 | end 84 | else 85 | begin 86 | if endline then 87 | begin 88 | lineno := lineno + 1; 89 | endline := false; 90 | lineok := true; 91 | if testing then 92 | write(lineno:4, sp) 93 | end; 94 | if eoln(source) then 95 | begin 96 | readln(source); 97 | ch := chr(nl); 98 | endline := true; 99 | if testing then 100 | writeln 101 | end 102 | else 103 | begin 104 | read(source, ch); 105 | if testing then 106 | write(ch) 107 | end 108 | end 109 | end; 110 | 111 | procedure put(value: integer); 112 | begin 113 | if outbuf.length = maxbuf 114 | then halt(maxbuf5); 115 | outbuf.length := 116 | outbuf.length + 1; 117 | outbuf.contents[ 118 | outbuf.length] := value 119 | end; 120 | 121 | procedure get( 122 | var value: integer); 123 | begin 124 | inpbuf.length := 125 | inpbuf.length + 1; 126 | value := inpbuf.contents[ 127 | inpbuf.length]; 128 | if testing then 129 | writeln(pass:1, sp, 130 | value:12) 131 | end; 132 | 133 | procedure getreal( 134 | var value: real); 135 | var dual: dualreal; 136 | begin 137 | dual.split := true; 138 | get(dual.b); 139 | get(dual.c); 140 | dual.split := false; 141 | value := dual.a 142 | end; 143 | 144 | procedure putreal(value: real); 145 | var dual: dualreal; 146 | begin 147 | dual.split := false; 148 | dual.a := value; 149 | dual.split := true; 150 | put(dual.b); 151 | put(dual.c) 152 | end; 153 | 154 | procedure getstring( 155 | var length: integer; 156 | var value: string); 157 | var c, i: integer; 158 | begin 159 | get(length); 160 | for i := 1 to length do 161 | begin 162 | get(c); 163 | value[i] := chr(c) 164 | end; 165 | for i := length + 1 166 | to maxstring do 167 | value[i] := chr(null) 168 | end; 169 | 170 | procedure putstring( 171 | length: integer; 172 | value: string); 173 | var i: integer; 174 | begin 175 | put(length); 176 | for i := 1 to length do 177 | put(ord(value[i])) 178 | end; 179 | 180 | procedure getcase( 181 | var lineno, length: integer; 182 | var table: casetable); 183 | var i: integer; 184 | begin 185 | get(lineno); get(length); 186 | for i := 1 to length do 187 | begin 188 | get(table[i].value); 189 | get(table[i].index) 190 | end 191 | end; 192 | 193 | procedure putcase( 194 | lineno, length: integer; 195 | table: casetable); 196 | var i: integer; 197 | begin 198 | put(lineno); put(length); 199 | for i := 1 to length do 200 | begin 201 | put(table[i].value); 202 | put(table[i].index) 203 | end 204 | end; 205 | 206 | function checksum: integer; 207 | const n = 8191; 208 | var i, sum, x: integer; 209 | begin 210 | sum := 0; 211 | for i := 1 to outbuf.length do 212 | begin 213 | x := outbuf.contents[i]; 214 | sum := 215 | (sum + x mod n) mod n 216 | end; 217 | checksum := sum 218 | end; 219 | 220 | procedure testoutput( 221 | kind: phrase); 222 | const 223 | max = 5 { symbols/line }; 224 | var i, n: integer; 225 | log: text; 226 | begin 227 | if testing then 228 | begin 229 | { nonstandard rewrite } 230 | rewrite(log, kind); 231 | writephrase(log, 232 | sourcename); 233 | write(log, sp); 234 | writephrase(log, kind); 235 | writeln(log); 236 | n := outbuf.length; 237 | for i := 1 to 238 | outbuf.length do 239 | begin 240 | if i mod max = 1 241 | then 242 | writeln(log); 243 | write(log, outbuf. 244 | contents[i]:12) 245 | end; 246 | writeln(log); 247 | writeln(log); 248 | writeln(log, 249 | 'check sum = ', 250 | checksum:4); 251 | writeln 252 | end 253 | end; 254 | 255 | procedure codeoutput; 256 | var i: integer; 257 | begin 258 | { nonstandard rewrite } 259 | rewrite(code, codename); 260 | for i := 1 to outbuf.length do 261 | write(code, 262 | outbuf.contents[i]) 263 | end; 264 | 265 | procedure rerun; 266 | begin 267 | inpbuf.length := 0; 268 | outbuf.length := 0 269 | end; 270 | 271 | procedure firstpass; 272 | begin 273 | write(' source = '); 274 | readphrase(sourcename); 275 | write(' code = '); 276 | readphrase(codename); 277 | if testoptions then 278 | begin 279 | write( 280 | ' test output? '); 281 | readboolean(testing); 282 | write( 283 | ' optimize? '); 284 | readboolean(optimizing); 285 | if testing then writeln 286 | end 287 | else 288 | begin 289 | testing := false; 290 | optimizing := true 291 | end; 292 | compiled := true; 293 | lineno := 0; 294 | { nonstandard rewrite } 295 | rewrite(errors, errorfile); 296 | writephrase(errors, 297 | sourcename); 298 | writeln(errors); 299 | writeln(errors); 300 | if sourcename = codename 301 | then halt(fileconflict); 302 | { nonstandard reset } 303 | reset(source, sourcename); 304 | pass := 1; 305 | outbuf.length := 0; 306 | endline := true; 307 | lineno := 0 308 | end; 309 | 310 | procedure nextpass; 311 | begin 312 | pass := pass + 1; 313 | { swap buffers } 314 | inpbuf := outbuf; 315 | inpbuf.length := 0; 316 | outbuf.length := 0 317 | end; 318 | 319 | procedure exit; 320 | begin 321 | if compiled then 322 | writeln(errors, 323 | 'no errors found') 324 | else writeln 325 | end; 326 | 327 | begin 328 | firstpass; 329 | scan(lineno, accept, put, 330 | putreal, putstring, 331 | error, halt); 332 | if compiled then 333 | begin 334 | testoutput(scanned); 335 | nextpass; 336 | parse(newline, get, put, 337 | getreal, putreal, 338 | getstring, putstring, 339 | putcase, error, halt); 340 | if compiled then 341 | begin 342 | testoutput(parsed); 343 | nextpass; 344 | assemble(optimizing, 345 | get, put, getreal, 346 | putreal, getstring, 347 | putstring, getcase, 348 | putcase, rerun, 349 | halt); 350 | if compiled then 351 | begin 352 | testoutput( 353 | assembled); 354 | codeoutput 355 | end 356 | end 357 | end; 358 | 1: exit 359 | end { compile }; 360 | 361 | begin compile end. 362 | -------------------------------------------------------------------------------- /super/interpret.p: -------------------------------------------------------------------------------- 1 | { SUPERPASCAL INTERPRETER 2 | 20 August 1993 3 | Copyright (c) 1993 Per Brinch Hansen } 4 | 5 | program interpret(input, output); 6 | #include "common.p" 7 | 8 | procedure run( 9 | var codefile: binary; 10 | var inpfile, outfile: text); 11 | const minaddr = 1; 12 | type 13 | store = 14 | array [minaddr..maxaddr] of 15 | integer; 16 | blocktable = 17 | array [1..maxblock] of integer; 18 | channeltable = 19 | array [1..maxchan] of integer; 20 | var 21 | { permanent variables } 22 | b, cmax, p, ready, s, 23 | stackbottom, t: integer; 24 | running: boolean; 25 | st: store; 26 | free: blocktable; 27 | open: channeltable; 28 | 29 | { temporary variables } 30 | bi, blockno, c, i, 31 | j, k, length, level, 32 | lineno, lower, m, n, 33 | pi, si, templength, 34 | typeno, typeno2, upper, 35 | width, x, y: integer; 36 | dx, dy: dualreal; 37 | sx: string; 38 | cx: char; 39 | 40 | { Local procedures in run } 41 | 42 | procedure error(lineno: integer; 43 | kind: phrase); 44 | begin 45 | writeln('line ', lineno:4, sp, 46 | kind:phraselength(kind)); 47 | running := false 48 | end; 49 | 50 | procedure rangeerror( 51 | lineno: integer); 52 | begin 53 | error(lineno, range4) 54 | end; 55 | 56 | procedure memorylimit( 57 | lineno: integer); 58 | begin 59 | error(lineno, maxaddr5) 60 | end; 61 | 62 | procedure load( 63 | var codefile: binary); 64 | var i: integer; 65 | begin 66 | i := minaddr; 67 | while not eof(codefile) 68 | and (i < maxaddr) do 69 | begin 70 | read(codefile, st[i]); 71 | i := i + 1 72 | end; 73 | if not eof(codefile) 74 | then memorylimit(1) 75 | else stackbottom := i 76 | end; 77 | 78 | procedure activate( 79 | bvalue, svalue, pvalue: 80 | integer); 81 | begin 82 | svalue := svalue + 3; 83 | st[svalue - 2] := pvalue; 84 | st[svalue - 1] := bvalue; 85 | st[svalue] := ready; 86 | ready := svalue 87 | end; 88 | 89 | procedure select( 90 | lineno: integer); 91 | begin 92 | if ready = 0 then 93 | error(lineno, deadlock4) 94 | else 95 | begin 96 | s := ready; 97 | ready := st[s]; 98 | b := st[s - 1]; 99 | p := st[s - 2]; 100 | s := s - 3 101 | end 102 | end; 103 | 104 | procedure popstring( 105 | var value: string); 106 | var i: integer; 107 | begin 108 | s := s - maxstring; 109 | for i := 1 to maxstring do 110 | value[i] := chr(st[s + i]) 111 | end; 112 | 113 | begin 114 | load(codefile); 115 | p := minaddr; 116 | running := true; 117 | while running do 118 | case st[p] of 119 | 120 | { VariableAccess = 121 | VariableName 122 | [ ComponentSelector ]* . 123 | VariableName = 124 | "variable" | "varparam" . 125 | ComponentSelector = 126 | Expression "index" | 127 | "field" . } 128 | 129 | variable2{level, displ}: 130 | begin 131 | level := st[p + 1]; 132 | s := s + 1; 133 | x := b; 134 | while level > 0 do 135 | begin 136 | x := st[x]; 137 | level := level - 1 138 | end; 139 | st[s] := x + st[p + 2]; 140 | p := p + 3 141 | end; 142 | 143 | varparam2{level, displ}: 144 | begin 145 | level := st[p + 1]; 146 | s := s + 1; 147 | x := b; 148 | while level > 0 do 149 | begin 150 | x := st[x]; 151 | level := level - 1 152 | end; 153 | st[s] := st[x + st[p + 2]]; 154 | p := p + 3 155 | end; 156 | 157 | index2{lower, upper, length, 158 | lineno}: 159 | begin 160 | lower := st[p + 1]; 161 | i := st[s]; 162 | s := s - 1; 163 | if (i < lower) or 164 | (i > st[p + 2]) then 165 | rangeerror(st[p + 4]) 166 | else 167 | begin 168 | st[s] := st[s] + 169 | (i - lower) * 170 | st[p + 3]; 171 | p := p + 5 172 | end 173 | end; 174 | 175 | field2{displ}: 176 | begin 177 | st[s] := 178 | st[s] + st[p + 1]; 179 | p := p + 2 180 | end; 181 | 182 | { StandardFunctionDesignator = 183 | FileFunctionDesignator | 184 | MathFunctionDesignator . 185 | FileFunctionDesignator = 186 | "eol" | "eoln" . } 187 | 188 | eof2{lineno}: 189 | begin 190 | s := s + 1; 191 | st[s] := 192 | ord(eof(inpfile)); 193 | p := p + 2 194 | end; 195 | 196 | eoln2{lineno}: 197 | begin 198 | s := s + 1; 199 | st[s] := 200 | ord(eoln(inpfile)); 201 | p := p + 2 202 | end; 203 | 204 | { MathFunctionDesignator = 205 | Expression [ "float" ] 206 | MathFunctionIdentifier . 207 | MathFunctionIdentifier = 208 | Abs | "arctan" | "chr" | 209 | "cos" | "exp" | "ln" | 210 | "odd" | "pred" | "round" | 211 | "sin" | Sqr | "sqrt" | 212 | "succ" | "trunc" . 213 | Abs = 214 | "abs" | "absint" . 215 | Sqr = 216 | "sqr" | "sqrint" . } 217 | 218 | float2: 219 | begin 220 | dx.a := st[s]; 221 | s := s + 1; 222 | st[s - 1] := dx.b; 223 | st[s] := dx.c; 224 | p := p + 1 225 | end; 226 | 227 | abs2{lineno}: 228 | begin 229 | dx.b := st[s - 1]; 230 | dx.c := st[s]; 231 | dx.a := abs(dx.a); 232 | st[s - 1] := dx.b; 233 | st[s] := dx.c; 234 | { if overflow then 235 | rangeerror(st[p + 1]) 236 | else } p := p + 2 237 | end; 238 | 239 | absint2{lineno}: 240 | begin 241 | st[s] := abs(st[s]); 242 | { if overflow then 243 | rangeerror(st[p + 1]) 244 | else } p := p + 2 245 | end; 246 | 247 | arctan2{lineno}: 248 | begin 249 | dx.b := st[s - 1]; 250 | dx.c := st[s]; 251 | dx.a := arctan(dx.a); 252 | st[s - 1] := dx.b; 253 | st[s] := dx.c; 254 | { if overflow then 255 | rangeerror(st[p + 1]) 256 | else } p := p + 2 257 | end; 258 | 259 | chr2{lineno}: 260 | begin 261 | x := st[s]; 262 | if (x < null) or (x > del) 263 | then 264 | rangeerror(st[p + 1]) 265 | else p := p + 2 266 | end; 267 | 268 | cos2{lineno}: 269 | begin 270 | dx.b := st[s - 1]; 271 | dx.c := st[s]; 272 | dx.a := cos(dx.a); 273 | st[s - 1] := dx.b; 274 | st[s] := dx.c; 275 | { if overflow then 276 | rangeerror(st[p + 1]) 277 | else } p := p + 2 278 | end; 279 | 280 | exp2{lineno}: 281 | begin 282 | dx.b := st[s - 1]; 283 | dx.c := st[s]; 284 | dx.a := exp(dx.a); 285 | st[s - 1] := dx.b; 286 | st[s] := dx.c; 287 | { if overflow then 288 | rangeerror(st[p + 1]) 289 | else } p := p + 2 290 | end; 291 | 292 | ln2{lineno}: 293 | begin 294 | dx.b := st[s - 1]; 295 | dx.c := st[s]; 296 | dx.a := ln(dx.a); 297 | st[s - 1] := dx.b; 298 | st[s] := dx.c; 299 | { if overflow then 300 | rangeerror(st[p + 1]) 301 | else } p := p + 2 302 | end; 303 | 304 | odd2: 305 | begin 306 | st[s] := ord(odd(st[s])); 307 | p := p + 1 308 | end; 309 | 310 | pred2{minvalue, lineno}: 311 | begin 312 | if st[s] > st[p + 1] then 313 | begin 314 | st[s] := pred(st[s]); 315 | p := p + 3 316 | end 317 | else 318 | rangeerror(st[p + 2]) 319 | end; 320 | 321 | round2{lineno}: 322 | begin 323 | dx.b := st[s - 1]; 324 | dx.c := st[s]; 325 | s := s - 1; 326 | st[s] := round(dx.a); 327 | { if overflow then 328 | rangeerror(st[p + 1]) 329 | else } p := p + 2 330 | end; 331 | 332 | sin2{lineno}: 333 | begin 334 | dx.b := st[s - 1]; 335 | dx.c := st[s]; 336 | dx.a := sin(dx.a); 337 | st[s - 1] := dx.b; 338 | st[s] := dx.c; 339 | { if overflow then 340 | rangeerror(st[p + 1]) 341 | else } p := p + 2 342 | end; 343 | 344 | sqr2{lineno}: 345 | begin 346 | dx.b := st[s - 1]; 347 | dx.c := st[s]; 348 | dx.a := sqr(dx.a); 349 | st[s - 1] := dx.b; 350 | st[s] := dx.c; 351 | { if overflow then 352 | rangeerror(st[p + 1]) 353 | else } p := p + 2 354 | end; 355 | 356 | sqrint2{lineno}: 357 | begin 358 | st[s] := sqr(st[s]); 359 | { if overflow then 360 | rangeerror(st[p + 1]) 361 | else } p := p + 2 362 | end; 363 | 364 | sqrt2{lineno}: 365 | begin 366 | dx.b := st[s - 1]; 367 | dx.c := st[s]; 368 | dx.a := sqrt(dx.a); 369 | st[s - 1] := dx.b; 370 | st[s] := dx.c; 371 | { if overflow then 372 | rangeerror(st[p + 1]) 373 | else } p := p + 2 374 | end; 375 | 376 | succ2{maxvalue, lineno}: 377 | begin 378 | if st[s] < st[p + 1] then 379 | begin 380 | st[s] := succ(st[s]); 381 | p := p + 3 382 | end 383 | else 384 | rangeerror(st[p + 2]) 385 | end; 386 | 387 | trunc2{lineno}: 388 | begin 389 | dx.b := st[s - 1]; 390 | dx.c := st[s]; 391 | s := s - 1; 392 | st[s] := trunc(dx.a); 393 | { if overflow then 394 | rangeerror(st[p + 1]) 395 | else } p := p + 2 396 | end; 397 | 398 | { FunctionDesignator = 399 | "result" 400 | ActualParameterPart 401 | "proccall" | 402 | StandardFunctionDesignator . 403 | ActualParameterPart = 404 | [ ActualParameter ]* . 405 | ActualParameter = 406 | Expression [ "float" ] | 407 | VariableAccess . } 408 | 409 | result2{length}: 410 | begin 411 | s := s + st[p + 1]; 412 | p := p + 2 413 | end; 414 | 415 | proccall2{level, displ}: 416 | begin 417 | level := st[p + 1]; 418 | s := s + 1; 419 | x := b; 420 | while level > 0 do 421 | begin 422 | x := st[x]; 423 | level := level - 1 424 | end; 425 | st[s] := x; 426 | st[s + 2] := p + 3; 427 | p := p + st[p + 2] 428 | end; 429 | 430 | { ConstantFactor = 431 | "ordconst"| "realconst" | 432 | "strconst" . } 433 | 434 | ordconst2{value}: 435 | begin 436 | s := s + 1; 437 | st[s] := st[p + 1]; 438 | p := p + 2 439 | end; 440 | 441 | realconst2{value}: 442 | begin 443 | st[s + 1] := st[p + 1]; 444 | st[s + 2] := st[p + 2]; 445 | s := s + 2; 446 | p := p + 3 447 | end; 448 | 449 | stringconst2{length, value}: 450 | begin 451 | length := st[p + 1]; 452 | for i := 1 to length do 453 | st[s + i] := 454 | st[p + i + 1]; 455 | for i := length + 1 456 | to maxstring do 457 | st[s + i] := null; 458 | s := s + maxstring; 459 | p := p + length + 2 460 | end; 461 | 462 | { Factor = 463 | ConstantFactor | 464 | VariableAccess "value" | 465 | FunctionDesignator | 466 | Expression | 467 | Factor [ "not" ] . } 468 | 469 | value2{length}: 470 | begin 471 | length := st[p + 1]; 472 | x := st[s]; 473 | for i := 0 to 474 | length - 1 do 475 | st[s + i] := 476 | st[x + i]; 477 | s := s + length - 1; 478 | p := p + 2 479 | end; 480 | 481 | not2: 482 | begin 483 | if st[s] = ord(true) 484 | then 485 | st[s] := ord(false) 486 | else 487 | st[s] := ord(true); 488 | p := p + 1 489 | end; 490 | 491 | { Term = 492 | Factor [ Factor [ Float ] 493 | MultiplyingOperator ]* . 494 | Float = 495 | "floatleft" | "float" . 496 | MultiplyingOperator = 497 | Multiply | Divide | 498 | "modulo" | "and" . 499 | Multiply = 500 | "multiply" | "multreal" . 501 | Divide = 502 | "divide" | "divreal" . } 503 | 504 | floatleft2: 505 | begin 506 | dx.a := st[s - 2]; 507 | s := s + 1; 508 | st[s] := st[s - 1]; 509 | st[s - 1] := st[s - 2]; 510 | st[s - 3] := dx.b; 511 | st[s - 2] := dx.c; 512 | p := p + 1 513 | end; 514 | 515 | multiply2{lineno}: 516 | begin 517 | s := s - 1; 518 | st[s] := 519 | st[s] * st[s + 1]; 520 | { if overflow then 521 | rangeerror(st[p + 1]) 522 | else } p := p + 2 523 | end; 524 | 525 | divide2{lineno}: 526 | begin 527 | s := s - 1; 528 | st[s] := 529 | st[s] div st[s + 1]; 530 | { if overflow then 531 | rangeerror(st[p + 1]) 532 | else } p := p + 2 533 | end; 534 | 535 | modulo2{lineno}: 536 | begin 537 | s := s - 1; 538 | st[s] := 539 | st[s] mod st[s + 1]; 540 | { if overflow then 541 | rangeerror(st[p + 1]) 542 | else } p := p + 2 543 | end; 544 | 545 | multreal2{lineno}: 546 | begin 547 | dy.b := st[s - 1]; 548 | dy.c := st[s]; 549 | s := s - 2; 550 | dx.b := st[s - 1]; 551 | dx.c := st[s]; 552 | dx.a := dx.a * dy.a; 553 | st[s - 1] := dx.b; 554 | st[s] := dx.c; 555 | { if overflow then 556 | rangeerror(st[p + 1]) 557 | else } p := p + 2 558 | end; 559 | 560 | divreal2{lineno}: 561 | begin 562 | dy.b := st[s - 1]; 563 | dy.c := st[s]; 564 | s := s - 2; 565 | dx.b := st[s - 1]; 566 | dx.c := st[s]; 567 | dx.a := dx.a / dy.a; 568 | st[s - 1] := dx.b; 569 | st[s] := dx.c; 570 | { if overflow then 571 | rangeerror(st[p + 1]) 572 | else } p := p + 2 573 | end; 574 | 575 | and2: 576 | begin 577 | s := s - 1; 578 | if st[s] = ord(true) 579 | then 580 | st[s] := st[s + 1]; 581 | p := p + 1 582 | end; 583 | 584 | { SimpleExpression = 585 | Term [ Sign ] 586 | [ Term [ Float ] 587 | AddingOperator ]* . 588 | Sign = 589 | Empty | Minus . 590 | Minus = 591 | "minus" | "minusreal" . 592 | AddingOperator = 593 | Add | Subtract | "or" . 594 | Add = 595 | "add" | "addreal" . 596 | Subtract = 597 | "subtract" | 598 | "subreal" . } 599 | 600 | minus2{(lineno}: 601 | begin 602 | st[s] := - st[s]; 603 | { if overflow then 604 | rangeerror(st[p + 1]) 605 | else } p := p + 2 606 | end; 607 | 608 | minusreal2{lineno}: 609 | begin 610 | dx.b := st[s - 1]; 611 | dx.c := st[s]; 612 | dx.a := - dx.a; 613 | st[s - 1] := dx.b; 614 | st[s] := dx.c; 615 | { if overflow then 616 | rangeerror(st[p + 1]) 617 | else } p := p + 2 618 | end; 619 | 620 | add2{lineno}: 621 | begin 622 | s := s - 1; 623 | st[s] := 624 | st[s] + st[s + 1]; 625 | { if overflow then 626 | rangeerror(st[p + 1]) 627 | else } p := p + 2 628 | end; 629 | 630 | subtract2{lineno}: 631 | begin 632 | s := s - 1; 633 | st[s] := 634 | st[s] - st[s + 1]; 635 | { if overflow then 636 | rangeerror(st[p + 1]) 637 | else } p := p + 2 638 | end; 639 | 640 | addreal2{lineno}: 641 | begin 642 | dy.b := st[s - 1]; 643 | dy.c := st[s]; 644 | s := s - 2; 645 | dx.b := st[s - 1]; 646 | dx.c := st[s]; 647 | dx.a := dx.a + dy.a; 648 | st[s - 1] := dx.b; 649 | st[s] := dx.c; 650 | { if overflow then 651 | rangeerror(st[p + 1]) 652 | else } p := p + 2 653 | end; 654 | 655 | subreal2{lineno}: 656 | begin 657 | dy.b := st[s - 1]; 658 | dy.c := st[s]; 659 | s := s - 2; 660 | dx.b := st[s - 1]; 661 | dx.c := st[s]; 662 | dx.a := dx.a - dy.a; 663 | st[s - 1] := dx.b; 664 | st[s] := dx.c; 665 | { if overflow then 666 | rangeerror(st[p + 1]) 667 | else } p := p + 2 668 | end; 669 | 670 | or2: 671 | begin 672 | s := s - 1; 673 | if st[s] = ord(false) then 674 | st[s] := st[s + 1]; 675 | p := p + 1 676 | end; 677 | 678 | { Expression = SimpleExpression 679 | [ SimpleExpression [ Float ] 680 | RelationalOperator ] . 681 | RelationalOperator = 682 | Less | Equal | Greater | 683 | NotGreater | NotEqual | 684 | NotLess. 685 | Less = 686 | "lsord" | "lsreal" | 687 | "lsstring" . 688 | Equal = 689 | "eqord" | "eqreal" | 690 | "eqstrig" | "equal" . 691 | Greater = 692 | "grord" | "grreal" | 693 | "grstring" . 694 | NotGreater = 695 | "ngord" | "ngreal" | 696 | "ngstring" . 697 | NotEqual = 698 | "neord" | "nereal" | 699 | "nestring" | "notequal" . 700 | NotLess = 701 | "nlord" | "nlreal" | 702 | "nlstring" . } 703 | 704 | lsord2: 705 | begin 706 | s := s - 1; 707 | st[s] := 708 | ord(st[s] < st[s + 1]); 709 | p := p + 1 710 | end; 711 | 712 | eqord2: 713 | begin 714 | s := s - 1; 715 | st[s] := 716 | ord(st[s] = st[s + 1]); 717 | p := p + 1 718 | end; 719 | 720 | grord2: 721 | begin 722 | s := s - 1; 723 | st[s] := 724 | ord(st[s] > st[s + 1]); 725 | p := p + 1 726 | end; 727 | 728 | ngord2: 729 | begin 730 | s := s - 1; 731 | st[s] := 732 | ord(st[s] <= st[s + 1]); 733 | p := p + 1 734 | end; 735 | 736 | neord2: 737 | begin 738 | s := s - 1; 739 | st[s] := 740 | ord(st[s] <> st[s + 1]); 741 | p := p + 1 742 | end; 743 | 744 | nlord2: 745 | begin 746 | s := s - 1; 747 | st[s] := 748 | ord(st[s] >= st[s + 1]); 749 | p := p + 1 750 | end; 751 | 752 | lsreal2: 753 | begin 754 | dy.b := st[s - 1]; 755 | dy.c := st[s]; 756 | s := s - 3; 757 | dx.b := st[s]; 758 | dx.c := st[s + 1]; 759 | st[s] := ord(dx.a < dy.a); 760 | p := p + 1 761 | end; 762 | 763 | eqreal2: 764 | begin 765 | dy.b := st[s - 1]; 766 | dy.c := st[s]; 767 | s := s - 3; 768 | dx.b := st[s]; 769 | dx.c := st[s + 1]; 770 | st[s] := ord(dx.a = dy.a); 771 | p := p + 1 772 | end; 773 | 774 | grreal2: 775 | begin 776 | dy.b := st[s - 1]; 777 | dy.c := st[s]; 778 | s := s - 3; 779 | dx.b := st[s]; 780 | dx.c := st[s + 1]; 781 | st[s] := ord(dx.a > dy.a); 782 | p := p + 1 783 | end; 784 | 785 | ngreal2: 786 | begin 787 | dy.b := st[s - 1]; 788 | dy.c := st[s]; 789 | s := s - 3; 790 | dx.b := st[s]; 791 | dx.c := st[s + 1]; 792 | st[s] := ord(dx.a <= dy.a); 793 | p := p + 1 794 | end; 795 | 796 | nereal2: 797 | begin 798 | dy.b := st[s - 1]; 799 | dy.c := st[s]; 800 | s := s - 3; 801 | dx.b := st[s]; 802 | dx.c := st[s + 1]; 803 | st[s] := ord(dx.a <> dy.a); 804 | p := p + 1 805 | end; 806 | 807 | nlreal2: 808 | begin 809 | dy.b := st[s - 1]; 810 | dy.c := st[s]; 811 | s := s - 3; 812 | dx.b := st[s]; 813 | dx.c := st[s + 1]; 814 | st[s] := ord(dx.a >= dy.a); 815 | p := p + 1 816 | end; 817 | 818 | lsstring2: 819 | begin 820 | y := s - maxstring + 1; 821 | s := y - maxstring; 822 | i := 0; 823 | while (i < maxstring - 1) 824 | and 825 | (st[s + i] = st[y + i]) 826 | do i := i + 1; 827 | st[s] := ord(st[s + i] < 828 | st[y + i]); 829 | p := p + 1 830 | end; 831 | 832 | eqstring2: 833 | begin 834 | y := s - maxstring + 1; 835 | s := y - maxstring; 836 | i := 0; 837 | while (i < maxstring - 1) 838 | and 839 | (st[s + i] = st[y + i]) 840 | do i := i + 1; 841 | st[s] := ord(st[s + i] = 842 | st[y + i]); 843 | p := p + 1 844 | end; 845 | 846 | grstring2: 847 | begin 848 | y := s - maxstring + 1; 849 | s := y - maxstring; 850 | i := 0; 851 | while (i < maxstring - 1) 852 | and 853 | (st[s + i] = st[y + i]) 854 | do i := i + 1; 855 | st[s] := ord(st[s + i] > 856 | st[y + i]); 857 | p := p + 1 858 | end; 859 | 860 | ngstring2: 861 | begin 862 | y := s - maxstring + 1; 863 | s := y - maxstring; 864 | i := 0; 865 | while (i < maxstring - 1) 866 | and 867 | (st[s + i] = st[y + i]) 868 | do i := i + 1; 869 | st[s] := ord(st[s + i] <= 870 | st[y + i]); 871 | p := p + 1 872 | end; 873 | 874 | nestring2: 875 | begin 876 | y := s - maxstring + 1; 877 | s := y - maxstring; 878 | i := 0; 879 | while (i < maxstring - 1) 880 | and 881 | (st[s + i] = st[y + i]) 882 | do i := i + 1; 883 | st[s] := ord(st[s + i] <> 884 | st[y + i]); 885 | p := p + 1 886 | end; 887 | 888 | nlstring2: 889 | begin 890 | y := s - maxstring + 1; 891 | s := y - maxstring; 892 | i := 0; 893 | while (i < maxstring - 1) 894 | and 895 | (st[s + i] = st[y + i]) 896 | do i := i + 1; 897 | st[s] := ord(st[s + i] >= 898 | st[y + i]); 899 | p := p + 1 900 | end; 901 | 902 | equal2{length}: 903 | begin 904 | length := st[p + 1]; 905 | y := s - length + 1; 906 | s := y - length; 907 | i := 0; 908 | while (i < length - 1) and 909 | (st[s + i] = st[y + i]) 910 | do i := i + 1; 911 | st[s] := ord(st[s + i] = 912 | st[y + i]); 913 | p := p + 2 914 | end; 915 | 916 | notequal2{length}: 917 | begin 918 | length := st[p + 1]; 919 | y := s - length + 1; 920 | s := y - length; 921 | i := 0; 922 | while (i < length - 1) and 923 | (st[s + i] = st[y + i]) 924 | do i := i + 1; 925 | st[s] := ord(st[s + i] <> 926 | st[y + i]); 927 | p := p + 2 928 | end; 929 | 930 | { AssignmentStatement = 931 | VariableAccess Expression 932 | [ "float" ] "assign" . } 933 | 934 | assign2{length}: 935 | begin 936 | length := st[p + 1]; 937 | s := s - length - 1; 938 | x := st[s + 1]; 939 | y := s + 2; 940 | for i := 0 to 941 | length - 1 do 942 | st[x + i] := 943 | st[y + i]; 944 | p := p + 2 945 | end; 946 | 947 | { ReadStatement = 948 | ReadParameters | 949 | [ ReadParameters ] 950 | "readln" . 951 | ReadParameters = 952 | ReadParameter 953 | [ ReadParameter ]* . 954 | ReadParameter = 955 | VariableAccess Read . 956 | Read = 957 | "read" | "readint" | 958 | "readreal" . } 959 | 960 | read2{lineno}: 961 | begin 962 | read(inpfile, cx); 963 | st[st[s]] := ord(cx); 964 | s := s - 1; 965 | p := p + 2 966 | end; 967 | 968 | readint2{lineno}: 969 | begin 970 | read(inpfile, 971 | st[st[s]]); 972 | s := s - 1; 973 | p := p + 2 974 | end; 975 | 976 | readreal2{lineno}: 977 | begin 978 | read(inpfile, dx.a); 979 | y := st[s]; 980 | s := s - 1; 981 | st[y] := dx.b; 982 | st[y + 1] := dx.c; 983 | p := p + 2 984 | end; 985 | 986 | readln2{lineno}: 987 | begin 988 | readln(inpfile); 989 | p := p + 2 990 | end; 991 | 992 | { WriteStatement = 993 | WriteParameters | 994 | [ WriteParameters ] 995 | "writeln" . 996 | WriteParameters = 997 | WriteParameter 998 | [ WriteParameter ]* . 999 | WriteParameter = 1000 | Expression 1001 | [ TotalWidth 1002 | [ FracDigits ] ] 1003 | "writereal" | 1004 | Expression 1005 | [ TotalWidth ] 1006 | OtherWrite . 1007 | OtherWrite = 1008 | "write" | "writebool" | 1009 | "writeint" | 1010 | "writestring" . 1011 | TotalWidth = 1012 | Expression . 1013 | FracDigits = 1014 | Expression . } 1015 | 1016 | write2{option, lineno}: 1017 | begin 1018 | if st[p + 1] = ord(true) 1019 | then 1020 | begin 1021 | write(outfile, 1022 | chr(st[s - 1]): 1023 | st[s]); 1024 | s := s - 2 1025 | end 1026 | else 1027 | begin 1028 | write(outfile, 1029 | chr(st[s])); 1030 | s := s - 1 1031 | end; 1032 | p := p + 3 1033 | end; 1034 | 1035 | writebool2{option, lineno}: 1036 | begin 1037 | if st[p + 1] = ord(true) 1038 | then 1039 | begin 1040 | write(outfile, 1041 | (st[s - 1] = 1) 1042 | :st[s]); 1043 | s := s - 2 1044 | end 1045 | else 1046 | begin 1047 | write(outfile, 1048 | st[s] = 1); 1049 | s := s - 1 1050 | end; 1051 | p := p + 3 1052 | end; 1053 | 1054 | writeint2{option, lineno}: 1055 | begin 1056 | if st[p + 1] = ord(true) 1057 | then 1058 | begin 1059 | write(outfile, 1060 | st[s - 1]: 1061 | st[s]); 1062 | s := s - 2 1063 | end 1064 | else 1065 | begin 1066 | write(outfile, 1067 | st[s]); 1068 | s := s - 1 1069 | end; 1070 | p := p + 3 1071 | end; 1072 | 1073 | writereal2{option1, option2, 1074 | lineno}: 1075 | begin 1076 | if st[p + 1] = ord(true) 1077 | then 1078 | if st[p + 2] = 1079 | ord(true) then 1080 | begin 1081 | s := s - 4; 1082 | dx.b := 1083 | st[s + 1]; 1084 | dx.c := 1085 | st[s + 2]; 1086 | m := 1087 | st[s + 3]; 1088 | n := 1089 | st[s + 4]; 1090 | write(outfile, 1091 | dx.a:m:n) 1092 | end 1093 | else 1094 | begin 1095 | s := s - 3; 1096 | dx.b := 1097 | st[s + 1]; 1098 | dx.c := 1099 | st[s + 2]; 1100 | m := 1101 | st[s + 3]; 1102 | write(outfile, 1103 | dx.a:m) 1104 | end 1105 | else 1106 | begin 1107 | s := s - 2; 1108 | dx.b := st[s + 1]; 1109 | dx.c := st[s + 2]; 1110 | write(outfile, 1111 | dx.a); 1112 | end; 1113 | p := p + 4 1114 | end; 1115 | 1116 | writestring2{option, lineno}: 1117 | begin 1118 | if st[p + 1] = ord(true) 1119 | then 1120 | begin 1121 | { write(outfile, 1122 | sx:width) } 1123 | width := st[s]; 1124 | s := s - 1; 1125 | popstring(sx); 1126 | writestring(outfile, 1127 | sx, width) 1128 | end 1129 | else 1130 | begin 1131 | { write(outfile, sx) } 1132 | popstring(sx); 1133 | writestring(outfile, 1134 | sx, 1135 | stringlength(sx)) 1136 | end; 1137 | p := p + 3 1138 | end; 1139 | 1140 | writeln2{lineno}: 1141 | begin 1142 | writeln(outfile); 1143 | p := p + 2 1144 | end; 1145 | 1146 | { OpenStatement = 1147 | OpenParameters . 1148 | OpenParameters = 1149 | OpenParameter 1150 | [ OpenParameter ]* . 1151 | OpenParameter = 1152 | VariableAccess "open" . } 1153 | 1154 | open2{lineno}: 1155 | begin 1156 | cmax := cmax + 1; 1157 | if cmax > maxchan then 1158 | error(st[p + 1], 1159 | maxchan5) 1160 | else 1161 | begin 1162 | open[cmax] := 0; 1163 | st[st[s]] := cmax; 1164 | s := s - 1; 1165 | p := p + 2 1166 | end 1167 | end; 1168 | 1169 | { ReceiveStatement = 1170 | ReceiveParameters . 1171 | ReceiveParameters = 1172 | ChannelExpression 1173 | "checkio" 1174 | InputVariableList 1175 | "endio" . 1176 | ChannelExpression = 1177 | Expression . 1178 | InputVariableList = 1179 | InputVariableAccess 1180 | [ InputVariableAccess ]* 1181 | . 1182 | InputVariableAccess = 1183 | VariableAccess 1184 | "receive" . } 1185 | 1186 | checkio2{lineno}: 1187 | begin 1188 | c := st[s]; 1189 | if (c < 1) or (c > cmax) 1190 | then 1191 | error(st[p + 1], 1192 | channel4) 1193 | else p := p + 2 1194 | end; 1195 | 1196 | endio2: 1197 | begin 1198 | s := s - 1; 1199 | p := p + 1 1200 | end; 1201 | 1202 | receive2{typeno, length, 1203 | lineno}: 1204 | begin 1205 | typeno := st[p + 1]; 1206 | length := st[p + 2]; 1207 | lineno := st[p + 3]; 1208 | c := st[s - 1]; 1209 | si := open[c]; 1210 | if si = 0 then 1211 | begin 1212 | s := s + 3; 1213 | st[s - 2] := -typeno; 1214 | st[s - 1] := p + 4; 1215 | st[s] := b; 1216 | open[c] := s; 1217 | select(lineno) 1218 | end 1219 | else 1220 | begin 1221 | typeno2 := st[si - 2]; 1222 | if typeno = typeno2 then 1223 | begin 1224 | pi := st[si - 1]; 1225 | bi := st[si]; 1226 | si := 1227 | si - length - 3; 1228 | x := st[s] - 1; 1229 | s := s - 1; 1230 | for i := 1 to length 1231 | do 1232 | st[x + i] := 1233 | st[si + i]; 1234 | open[c] := 0; 1235 | activate(bi, si, pi); 1236 | p := p + 4 1237 | end 1238 | else if typeno2 < 0 then 1239 | error(lineno, 1240 | contention4) 1241 | else 1242 | error(lineno, type4) 1243 | end 1244 | end; 1245 | 1246 | { SendStatement = 1247 | SendParameters . 1248 | SendParameters = 1249 | ChannelExpression 1250 | "checkio" 1251 | OutputExpressionList 1252 | "endio" . 1253 | OutputExpressionList = 1254 | OutputExpression 1255 | [ OutputExpression ]* . 1256 | OutputExpression = 1257 | Expression "send" . } 1258 | 1259 | send2{typeno, length, 1260 | lineno}: 1261 | begin 1262 | typeno := st[p + 1]; 1263 | length := st[p + 2]; 1264 | lineno := st[p + 3]; 1265 | c := st[s - length]; 1266 | si := open[c]; 1267 | if si = 0 then 1268 | begin 1269 | s := s + 3; 1270 | st[s - 2] := typeno; 1271 | st[s - 1] := p + 4; 1272 | st[s] := b; 1273 | open[c] := s; 1274 | select(lineno) 1275 | end 1276 | else 1277 | begin 1278 | typeno2 := st[si - 2]; 1279 | if typeno = -typeno2 then 1280 | begin 1281 | pi := st[si - 1]; 1282 | bi := st[si]; 1283 | si := si - 4; 1284 | x := st[si + 1] - 1; 1285 | s := s - length; 1286 | for i := 1 to length 1287 | do 1288 | st[x + i] := 1289 | st[s + i]; 1290 | open[c] := 0; 1291 | activate(bi, si, pi); 1292 | p := p + 4 1293 | end 1294 | else if typeno2 > 0 then 1295 | error(lineno, 1296 | contention4) 1297 | else 1298 | error(lineno, type4) 1299 | end 1300 | end; 1301 | 1302 | { ProcedureStatement = 1303 | ActualParameterPart 1304 | "proccall" | 1305 | StandardProcedureStatement . 1306 | StandardProcedureStatement = 1307 | ReadStatement | 1308 | WriteStatement | 1309 | OpenStatement | 1310 | ReceiveStatement | 1311 | SendStatement . 1312 | IfStatement = 1313 | Expression "do" Statement 1314 | [ "goto" Statement ] . 1315 | WhileStatement = 1316 | Expression "do" 1317 | Statement "goto" . 1318 | RepeatStatement = 1319 | StatementSequence 1320 | Expression "do" . } 1321 | 1322 | do2{displ}: 1323 | begin 1324 | if st[s] = ord(true) then 1325 | p := p + 2 1326 | else p := p + st[p + 1]; 1327 | s := s - 1 1328 | end; 1329 | 1330 | goto2{displ}: 1331 | p := p + st[p + 1]; 1332 | 1333 | { ForStatement = 1334 | ForClause ForOption . 1335 | ForClause = 1336 | VariableAccess 1337 | Expression "for" . 1338 | ForOption = 1339 | UpClause | DownClause . 1340 | UpClause = 1341 | Expression "to" 1342 | Statement "endto" . 1343 | DownClause = 1344 | Expression "downto" 1345 | Statement "enddown" . } 1346 | 1347 | for2: 1348 | begin 1349 | st[st[s - 1]] := st[s]; 1350 | s := s - 1; 1351 | p := p + 1 1352 | end; 1353 | 1354 | to2{displ}: 1355 | begin 1356 | if st[st[s - 1]] <= st[s] 1357 | then p := p + 2 1358 | else 1359 | begin 1360 | s := s - 2; 1361 | p := p + st[p + 1] 1362 | end 1363 | end; 1364 | 1365 | endto2{disp}: 1366 | begin 1367 | x := st[s - 1]; 1368 | st[x] := st[x] + 1; 1369 | p := p + st[p + 1] 1370 | end; 1371 | 1372 | downto2{displ}: 1373 | begin 1374 | if st[st[s - 1]] >= st[s] 1375 | then p := p + 2 1376 | else 1377 | begin 1378 | s := s - 2; 1379 | p := p + st[p + 1] 1380 | end 1381 | end; 1382 | 1383 | enddown2{displ}: 1384 | begin 1385 | x := st[s - 1]; 1386 | st[x] := st[x] - 1; 1387 | p := p + st[p + 1] 1388 | end; 1389 | 1390 | { CaseStatement = 1391 | Expression "goto" 1392 | CaseList "case" . 1393 | CaseList = 1394 | StatementSequence . } 1395 | 1396 | case2{ 1397 | lineno, length, table}: 1398 | begin 1399 | x := st[s]; 1400 | s := s - 1; 1401 | { binary search } 1402 | i := 1; 1403 | j := st[p + 2]; 1404 | while i < j do 1405 | begin 1406 | k := 1407 | (i + j) div 2; 1408 | m := p + 2*k + 1; 1409 | if st[m] < x 1410 | then i := k + 1 1411 | else j := k 1412 | end; 1413 | m := p + 2*i + 1; 1414 | if st[m] = x then 1415 | p := p + st[m + 1] 1416 | else 1417 | error(st[p + 1], 1418 | case4) 1419 | end; 1420 | 1421 | { ParallelStatement = 1422 | "parallel" 1423 | ProcessStatementList 1424 | "endparallel" . 1425 | ProcessStatementList = 1426 | ProcessStatement 1427 | [ ProcessStatement ]* . 1428 | ProcessStatement = 1429 | "process" 1430 | StatementSequence 1431 | "endprocess" . } 1432 | 1433 | parallel2: 1434 | begin 1435 | s := s + 1; 1436 | st[s] := 0; 1437 | p := p + 1 1438 | end; 1439 | 1440 | endparallel2{lineno}: 1441 | select(st[p + 1]); 1442 | 1443 | process2{blockno, 1444 | templength, displ, 1445 | lineno}: 1446 | begin 1447 | st[s] := st[s] + 1; 1448 | blockno := st[p + 1]; 1449 | bi := free[blockno]; 1450 | if bi = 0 then 1451 | begin 1452 | bi := t + 1; 1453 | t := 1454 | bi + st[p + 2] + 4 1455 | end 1456 | else 1457 | free[blockno] := 1458 | st[bi]; 1459 | if t > maxaddr then 1460 | memorylimit(st[p + 4]) 1461 | else 1462 | begin 1463 | st[bi] := b; 1464 | st[bi + 1] := s; 1465 | si := bi + 4; 1466 | st[si] := blockno; 1467 | activate(bi, si, 1468 | p + 5); 1469 | p := p + st[p + 3] 1470 | end 1471 | end; 1472 | 1473 | endprocess2{displ, lineno}: 1474 | begin 1475 | blockno := st[s]; 1476 | x := b; 1477 | b := st[x]; 1478 | s := st[x + 1]; 1479 | st[x] := free[blockno]; 1480 | free[blockno] := x; 1481 | st[s] := st[s] - 1; 1482 | if st[s] > 0 then 1483 | select(st[p + 2]) 1484 | else 1485 | begin 1486 | s := s - 1; 1487 | p := p + st[p + 1] 1488 | end 1489 | end; 1490 | 1491 | { ForallStatement = 1492 | IndexVariableDeclaration 1493 | "forall" Statement 1494 | "endall" . 1495 | IndexVariableDeclaration = 1496 | Expression Expression . } 1497 | 1498 | forall2{blockno, 1499 | templength, displ, 1500 | lineno}: 1501 | begin 1502 | upper := st[s]; 1503 | lower := st[s - 1]; 1504 | if lower <= upper then 1505 | begin 1506 | s := s - 1; 1507 | st[s] := 1508 | upper - lower + 1; 1509 | blockno := 1510 | st[p + 1]; 1511 | templength := 1512 | st[p + 2]; 1513 | lineno := st[p + 4]; 1514 | for i := lower to 1515 | upper do 1516 | begin 1517 | bi := 1518 | free[blockno]; 1519 | if bi = 0 then 1520 | begin 1521 | bi := t + 1; 1522 | t := bi + 1523 | templength + 5 1524 | end 1525 | else 1526 | free[blockno] := 1527 | st[bi]; 1528 | if t > maxaddr then 1529 | memorylimit(lineno) 1530 | else 1531 | begin 1532 | st[bi] := b; 1533 | st[bi + 1] := s; 1534 | st[bi + 4] := i; 1535 | si := bi + 5; 1536 | st[si] := 1537 | blockno; 1538 | activate(bi, si, 1539 | p + 5) 1540 | end 1541 | end; 1542 | select(lineno) 1543 | end 1544 | else { lower > upper } 1545 | begin 1546 | s := s - 2; 1547 | p := p + st[p + 3] 1548 | end 1549 | end; 1550 | 1551 | endall2{lineno}: 1552 | begin 1553 | blockno := st[s]; 1554 | x := b; 1555 | b := st[x]; 1556 | s := st[x + 1]; 1557 | st[x] := free[blockno]; 1558 | free[blockno] := x; 1559 | st[s] := st[s] - 1; 1560 | if st[s] > 0 then 1561 | select(st[p + 2]) 1562 | else 1563 | begin 1564 | s := s - 1; 1565 | p := p + 2 1566 | end 1567 | end; 1568 | 1569 | { AssumeStatement = 1570 | Expression "assume" . } 1571 | 1572 | assume2{lineno}: 1573 | begin 1574 | x := st[s]; 1575 | s := s - 1; 1576 | if x = ord(false) then 1577 | error(st[p + 1], 1578 | assume4) 1579 | else p := p + 2 1580 | end; 1581 | 1582 | { Statement = 1583 | AssignmentStatement | 1584 | ProcedureStatement | 1585 | IfStatement | 1586 | WhileStatement | 1587 | RepeatStatement | 1588 | ForStatement | 1589 | CaseStatement | 1590 | CompoundStatement | 1591 | ParallelStatement | 1592 | ForallStatement | 1593 | AssumeStatement | 1594 | EmptyStatement . 1595 | EmptyStatement = . 1596 | StatementSequence = 1597 | Statement [ Statement ]* . 1598 | CompoundStatement = 1599 | StatementSequence . 1600 | Block = 1601 | [ ProcedureDeclaration ]* 1602 | CompoundStatement . 1603 | ProcedureDeclaration = 1604 | "procedure" Block 1605 | "endproc" . } 1606 | 1607 | procedure2{blockno, 1608 | paramlength, varlength, 1609 | templength, displ, 1610 | lineno}: 1611 | begin 1612 | st[s + 1] := 1613 | s - st[p + 2] - 1; 1614 | st[s + 3] := b; 1615 | b := s; 1616 | blockno := st[p + 1]; 1617 | s := free[blockno]; 1618 | if s = 0 then 1619 | begin 1620 | s := t + 1; 1621 | t := s + st[p + 4]; 1622 | if t > maxaddr then 1623 | memorylimit( 1624 | st[p + 6]) 1625 | end 1626 | else 1627 | free[blockno] := st[s]; 1628 | st[s] := blockno; 1629 | p := p + st[p + 5] 1630 | end; 1631 | 1632 | endproc2: 1633 | begin 1634 | blockno := st[s]; 1635 | x := s; 1636 | s := st[b + 1]; 1637 | p := st[b + 2]; 1638 | b := st[b + 3]; 1639 | st[x] := free[blockno]; 1640 | free[blockno] := x 1641 | end; 1642 | 1643 | { Program = 1644 | "program" Block 1645 | "endprog" . } 1646 | 1647 | program2{blockno, 1648 | varlength, templength, 1649 | displ, lineno}: 1650 | begin 1651 | for i := 1 to maxblock 1652 | do free[i] := 0; 1653 | ready := 0; 1654 | cmax := 0; 1655 | b := stackbottom; 1656 | s := b + st[p + 2] + 4; 1657 | t := s + st[p + 3]; 1658 | if t > maxaddr then 1659 | memorylimit(st[p + 5]) 1660 | else p := p + st[p + 4] 1661 | end; 1662 | 1663 | endprog2: 1664 | running := false; 1665 | 1666 | { localvar(displ) = 1667 | variable(0, displ) . } 1668 | 1669 | localvar2{displ}: 1670 | begin 1671 | s := s + 1; 1672 | st[s] := b + st[p + 1]; 1673 | p := p + 2 1674 | end; 1675 | 1676 | { localvalue(displ) = 1677 | localvar(displ) 1678 | value(1) . } 1679 | 1680 | localvalue2{displ}: 1681 | begin 1682 | s := s + 1; 1683 | st[s] := 1684 | st[b + st[p + 1]]; 1685 | p := p + 2 1686 | end; 1687 | 1688 | { localreal(displ) = 1689 | localvar(displ) 1690 | value(2) . } 1691 | 1692 | localreal2{displ}: 1693 | begin 1694 | x := b + st[p + 1]; 1695 | s := s + 2; 1696 | st[s - 1] := st[x]; 1697 | st[s] := st[x + 1]; 1698 | p := p + 2 1699 | end; 1700 | 1701 | { globalvar(displ) = 1702 | variable(1, displ) . } 1703 | 1704 | globalvar2{displ}: 1705 | begin 1706 | s := s + 1; 1707 | st[s] := 1708 | st[b] + st[p + 1]; 1709 | p := p + 2 1710 | end; 1711 | 1712 | { globalvalue(displ) = 1713 | globalvar(displ) 1714 | value(1) . } 1715 | 1716 | globalvalue2{displ}: 1717 | begin 1718 | s := s + 1; 1719 | st[s] := st[ 1720 | st[b] + st[p + 1]]; 1721 | p := p + 2 1722 | end; 1723 | 1724 | { ordvalue = 1725 | value(1) . } 1726 | 1727 | ordvalue2: 1728 | begin 1729 | st[s] := st[st[s]]; 1730 | p := p + 1 1731 | end; 1732 | 1733 | { realvalue = 1734 | value(2) . } 1735 | 1736 | realvalue2: 1737 | begin 1738 | x := st[s]; 1739 | s := s + 1; 1740 | st[s - 1] := st[x]; 1741 | st[s] := st[x + 1]; 1742 | p := p + 1 1743 | end; 1744 | 1745 | { ordassign = 1746 | assign(1) . } 1747 | 1748 | ordassign2: 1749 | begin 1750 | st[st[s - 1]] := st[s]; 1751 | s := s - 2; 1752 | p := p + 1 1753 | end; 1754 | 1755 | { realassign = 1756 | assign(2) . } 1757 | 1758 | realassign2: 1759 | begin 1760 | s := s - 3; 1761 | x := st[s + 1]; 1762 | st[x] := st[s + 2]; 1763 | st[x + 1] := st[s + 3]; 1764 | p := p + 1 1765 | end; 1766 | 1767 | { globalcall(displ) = 1768 | proccall(1, displ) . } 1769 | 1770 | globalcall2{displ}: 1771 | begin 1772 | s := s + 1; 1773 | st[s] := st[b]; 1774 | st[s + 2] := p + 2; 1775 | p := p + st[p + 1] 1776 | end 1777 | 1778 | end 1779 | end { run }; 1780 | 1781 | procedure readtime( 1782 | var t: integer); 1783 | begin 1784 | { A nonstandard function reads 1785 | the processor time in ms } 1786 | t := clock 1787 | end; 1788 | 1789 | procedure writetime( 1790 | var outfile: text; 1791 | t1, t2: integer); 1792 | begin 1793 | { Outputs the time interval 1794 | t2 - t1 ms in seconds } 1795 | writeln(outfile); 1796 | writeln(outfile, 1797 | (t2 - t1 + 500) div 1000:1, 1798 | ' s') 1799 | end; 1800 | 1801 | procedure runtime( 1802 | var codefile: binary; 1803 | var inpfile, outfile: text); 1804 | var t1, t2: integer; 1805 | begin 1806 | readtime(t1); 1807 | run(codefile, inpfile, outfile); 1808 | readtime(t2); 1809 | writetime(outfile, t1, t2) 1810 | end; 1811 | 1812 | procedure openoutput( 1813 | var codefile: binary; 1814 | var inpfile: text; 1815 | outname: phrase); 1816 | var outfile: text; 1817 | begin 1818 | if outname = screen then 1819 | begin 1820 | writeln(output); 1821 | runtime(codefile, 1822 | inpfile, output); 1823 | writeln(output) 1824 | end 1825 | else 1826 | begin 1827 | { nonstandard rewrite } 1828 | rewrite(outfile, outname); 1829 | runtime(codefile, 1830 | inpfile, outfile) 1831 | end 1832 | end; 1833 | 1834 | procedure openinput( 1835 | var codefile: binary; 1836 | inpname, outname: phrase); 1837 | var inpfile: text; 1838 | begin 1839 | if inpname = keyboard then 1840 | openoutput(codefile, 1841 | input, outname) 1842 | else 1843 | begin 1844 | { nonstandard reset } 1845 | reset(inpfile, inpname); 1846 | openoutput(codefile, 1847 | inpfile, outname) 1848 | end 1849 | end; 1850 | 1851 | procedure start; 1852 | var codename, inpname, 1853 | outname: phrase; 1854 | codefile: binary; 1855 | select: boolean; 1856 | begin 1857 | write(' code = '); 1858 | readphrase(codename); 1859 | write(' select files? '); 1860 | readboolean(select); 1861 | if select then 1862 | begin 1863 | write(' input = '); 1864 | readphrase(inpname); 1865 | write(' output = '); 1866 | readphrase(outname); 1867 | { nonstandard reset } 1868 | reset(codefile, codename); 1869 | openinput(codefile, 1870 | inpname, outname) 1871 | end 1872 | else 1873 | begin 1874 | { nonstandard reset } 1875 | reset(codefile, codename); 1876 | writeln(output); 1877 | runtime(codefile, input, 1878 | output); 1879 | writeln(output) 1880 | end 1881 | end; 1882 | 1883 | begin start end. 1884 | -------------------------------------------------------------------------------- /super/notes.tex: -------------------------------------------------------------------------------- 1 | % THE SUPERPASCAL SOFTWARE NOTES 2 | % PER BRINCH HANSEN 3 | % School of Computer and Information Science 4 | % Syracuse University, Syracuse, NY 13244, USA 5 | % 29 October 1993 6 | % Copyright(c) 1993 Per Brinch Hansen 7 | 8 | % LATEX PREAMBLE 9 | \documentstyle[twoside,11pt]{article} 10 | \pagestyle{myheadings} 11 | \setlength{\topmargin}{7mm} 12 | \setlength{\textheight}{200mm} 13 | \setlength{\textwidth}{140mm} 14 | \setlength{\oddsidemargin}{14mm} 15 | \setlength{\evensidemargin}{12mm} 16 | \newcommand{\acknowledgements} 17 | {\section*{Acknowledgements} 18 | \addcontentsline{toc}{section} 19 | {Acknowledgements} 20 | } 21 | \newcommand{\blank} 22 | {\mbox{\hspace{1.8em}}} 23 | \newcommand{\blankline} 24 | {\medskip} 25 | \newcommand{\Copyright} 26 | {Copyright {\copyright}} 27 | \newcommand{\entry} 28 | {\bibitem{}} 29 | \newcommand{\example} 30 | {{\it Example:}} 31 | \newcommand{\examples} 32 | {{\it Examples:}} 33 | \newcommand{\mytitle}[3] 34 | % [title,month,year] 35 | {\markboth{Per Brinch Hansen}{#1} 36 | \thispagestyle{empty} 37 | \begin{center} 38 | {\Large\bf #1}\\ 39 | % TITLE 40 | \blankline 41 | PER BRINCH HANSEN 42 | \footnote{ 43 | \Copyright #3 % Year 44 | Per Brinch Hansen. All rights reserved.}\\ 45 | \blankline 46 | {\it 47 | School of Computer and Information Science \\ 48 | Syracuse University, Syracuse, NY 13244, USA\\ 49 | } 50 | \blankline 51 | #2 #3\\ 52 | % Month Year 53 | \end{center} 54 | } 55 | \newcommand{\Superpascal} 56 | {\it SuperPascal} 57 | \newenvironment{grammar} 58 | {\begin{small}} 59 | {\end{small}} 60 | \newenvironment{myabstract} 61 | {\begin{rm} 62 | \noindent{\bf Abstract:}} 63 | {\end{rm}} 64 | \newenvironment{mybibliography}[1] 65 | % [widestlabel] 66 | {\begin{small} 67 | \begin{thebibliography}{#1} 68 | \addcontentsline{toc} 69 | {section}{References}} 70 | { \end{thebibliography} 71 | \end{small}} 72 | \newenvironment{mykeywords} 73 | {\begin{small} 74 | \noindent{\bf Key Words:}} 75 | {\end{small}} 76 | \newenvironment{mytabular}[1] 77 | % [columns] 78 | {\begin{small} 79 | \begin{center} 80 | \begin{tabular}{#1}} 81 | { \end{tabular} 82 | \end{center} 83 | \end{small}} 84 | \newenvironment{program}[1] 85 | % [width] 86 | {\begin{center} 87 | \begin{minipage}{#1}} 88 | { \end{minipage} 89 | \end{center}} 90 | % Program Indentation 91 | \newcommand{\PA} 92 | {\noindent} 93 | \newcommand{\PB} 94 | {\mbox{\hspace{1em}}} 95 | \newcommand{\PC} 96 | {\mbox{\hspace{2em}}} 97 | \newcommand{\PD} 98 | {\mbox{\hspace{3em}}} 99 | \newcommand{\PE} 100 | {\mbox{\hspace{4em}}} 101 | 102 | % DOCUMENT TEXT 103 | \begin{document} 104 | 105 | \mytitle{The SuperPascal Software Notes} 106 | {November}{1993} 107 | 108 | \begin{myabstract} 109 | These notes describe the {\Superpascal} software, define 110 | the terms and conditions for its use, and explain how 111 | you compile the {\Superpascal} compiler and interpreter. 112 | \end{myabstract} 113 | 114 | 115 | \section{Definitions} 116 | 117 | \subsection{Software} 118 | 119 | The {\it SuperPascal} software (hereafter {\it Software}) is 120 | educational software written by Per Brinch Hansen (hereafter 121 | {\it PBH}). The {\it Software} consists of the {\it Manuals}, 122 | {\it Programs}, and {\it Scripts} for the programming 123 | language {\Superpascal} invented by {\it PBH}. The {\it 124 | Software} is stored as text in 11 files (hereafter {\it Files}). 125 | 126 | 127 | \subsection{Manuals} 128 | 129 | The {\it Manuals}, written by {\it PBH}, are stored as {\LaTeX} 130 | text in 3 {\it Files}: 131 | 132 | \begin{itemize} 133 | \item 134 | {\it report.tex:} ``The programming language SuperPascal'' 135 | [Brinch Hansen 1993a]. 136 | \item 137 | {\it user.tex:} ``The SuperPascal user manual'' [Brinch 138 | Hansen 1993b]. 139 | \item 140 | {\it notes.tex:} ``The SuperPascal software notes'' [The 141 | present notes]. 142 | \end{itemize} 143 | 144 | 145 | \subsection{Programs} 146 | 147 | The {\it Programs}, written by {\it PBH}, are a {\Superpascal} 148 | compiler and interpreter (hereafter {\it Compiler} and {\it 149 | Interpreter}). The {\it Programs} are based on the Pascal 150 | compiler and interpreter described and listed in [Brinch 151 | Hansen 1985]. The {\it Programs} are written in Pascal for 152 | Sun3 and Sun4 workstations running Unix. 153 | 154 | The {\it Programs} are stored as Pascal text in 6 {\it Files} 155 | (hereafter {\it Program Files}): 156 | 157 | \begin{itemize} 158 | \item 159 | {\it common.p:} The common declarations used by the 160 | {\it Compiler} and {\it Interpreter}. 161 | \item 162 | {\it scan.p:} The {\it Compiler} procedure that performs 163 | lexical analysis. 164 | \item 165 | {\it parse.p:} The {\it Compiler} procedure that performs 166 | syntax, scope, and type analysis. 167 | \item 168 | {\it assemble.p:} The {\it Compiler} procedure that 169 | assembles interpreted code. 170 | \item 171 | {\it compile.p:} The {\it Compiler} program. 172 | \item 173 | {\it interpret.p:} The {\it Interpreter} program. 174 | \end{itemize} 175 | 176 | 177 | \subsection{Scripts} 178 | 179 | The {\it Scripts} are Unix shell scripts stored as text in 2 180 | {\it Files}: 181 | 182 | \begin{itemize} 183 | \item 184 | {\it sun3.user:} A shell script for compilation of the 185 | {\it Programs} on a Sun3 workstation under Unix. 186 | \item 187 | {\it sun4.user:} A shell script for compilation of the 188 | {\it Programs} on a Sun4 workstation under Unix. 189 | \end{itemize} 190 | 191 | 192 | \section{Terms and Conditions} 193 | 194 | \begin{it} 195 | THE MANUALS ARE COPYRIGHTED BY PBH. THE PROGRAMS ARE IN THE 196 | PUBLIC DOMAIN. YOU CAN OBTAIN THE SOFTWARE BY ANONYMOUS FTP. 197 | THE SOFTWARE IS NOT GUARANTEED FOR A PARTICULAR PURPOSE. PBH 198 | SUPPLIES THE SOFTWARE ``AS IS'' WITHOUT ANY WARRANTIES OR 199 | REPRESENTATIONS AND DOES NOT ACCEPT ANY LIABILITIES WITH 200 | RESPECT TO THE SOFTWARE. 201 | YOU (THE USER) ARE RESPONSIBLE FOR SELECTING THE SOFTWARE, AND 202 | FOR THE USE AND RESULTS OBTAINED FROM THE SOFTWARE. YOUR USE 203 | OF THE SOFTWARE INDICATES YOUR ACCEPTANCE OF THESE TERMS AND 204 | CONDITIONS. 205 | \end{it} 206 | 207 | 208 | \section{Software Limits} 209 | 210 | The {\it Program File common.p} (hereafter {\it Common 211 | Declarations}) defines common constants, types, functions, and 212 | procedures used by the {\it Programs}. The limits of software 213 | arrays are defined by common constants (hereafter {\it Software 214 | Limits}). If the {\it Software Limits} are too small for 215 | compilation or execution of a user program, these limits must 216 | be increased by editing the {\it Common Declarations} and 217 | recompiling the {\it Programs}. 218 | 219 | 220 | \section{Include Commands} 221 | 222 | The {\it Program File compile.p} contains the following {\it 223 | include commands}: 224 | 225 | \begin{program}{10.0em} 226 | {\PA}{\#}include "common.p" \\ 227 | {\PA}{\#}include "scan.p" \\ 228 | {\PA}{\#}include "parse.p" \\ 229 | {\PA}{\#}include "assemble.p"\\ 230 | \end{program} 231 | 232 | These commands ensure that Pascal compilation of the {\it 233 | Compiler} also includes the {\it Common Declarations} and 234 | the {\it Compiler} procedures. 235 | 236 | The {\it Program File interpret.p} contains the {\it 237 | include} command: 238 | 239 | \begin{center} 240 | {\#}include "common.p" 241 | \end{center} 242 | 243 | This command ensures that Pascal compilation of the 244 | {\it Interpreter} also includes the {\it Common 245 | Declarations}. 246 | 247 | 248 | \section{Nonstandard Pascal} 249 | 250 | The {\it Programs} use the following nonstandard 251 | statements, which are Sun extensions of Pascal [Sun 252 | Microsystems 1986]: 253 | 254 | \begin{mytabular}{lll} 255 | \hline 256 | Program File & Procedure & Nonstandard statement \\ 257 | \hline 258 | compile.p & testoutput & rewrite(log, kind) \\ 259 | compile.p & codeoutput & rewrite(code, codename) \\ 260 | compile.p & firstpass & rewrite(errors, errorfile)\\ 261 | compile.p & firstpass & reset(source, sourcename) \\ 262 | interpret.p & readtime & t := clock \\ 263 | interpret.p & openoutput & rewrite(outfile, outname) \\ 264 | interpret.p & openinput & reset(inpfile, inpname) \\ 265 | interpret.p & start & reset(codefile, codename) \\ 266 | \hline 267 | \end{mytabular} 268 | 269 | The rest of the {\it Program Files} conform to {\it ISO 270 | Level 1 Standard Pascal} [British Standards Institute 1982]. 271 | 272 | 273 | \section{Program Compilation} 274 | 275 | When you have obtained the {\it Files}, the first step is 276 | is to compile the {\it Programs}. 277 | 278 | On a {\it Sun3} you compile the {\it Programs} by typing the 279 | Unix command: 280 | 281 | \begin{center} 282 | csh sun3.user 283 | \end{center} 284 | 285 | The {\it Script sun3.user} contains the Unix commands: 286 | 287 | \begin{program}{16.7em} 288 | {\PA}echo Compiling Sun3 SuperPascal \\ 289 | {\PA}pc --s --H --O --f68881 --o sc compile.p \\ 290 | {\PA}pc --s --H --O --f68881 --o sr interpret.p\\ 291 | \end{program} 292 | 293 | The {\it Programs} are compiled with the following Sun3 294 | options: 295 | 296 | \begin{itemize} 297 | \item 298 | {\it --s:} Check the Pascal standard. 299 | \item 300 | {\it --H:} Check pointers (but not subranges). 301 | \item 302 | {\it --O:} Optimize the code. 303 | \item 304 | {\it --f68881:} Generate code for the Motorola 68881 305 | floating-point processor. 306 | \end{itemize} 307 | 308 | On a {\it Sun4} you compile the {\it Programs} by typing 309 | the Unix command: 310 | 311 | \begin{center} 312 | csh sun4.user 313 | \end{center} 314 | 315 | The {\it Script sun4.user} contains the Unix commands: 316 | 317 | \begin{program}{15.7em} 318 | {\PA}echo Compiling Sun4 SuperPascal \\ 319 | {\PA}pc --s --H --O --cg89 --o sc compile.p \\ 320 | {\PA}pc --s --H --O --cg89 --o sr interpret.p\\ 321 | \end{program} 322 | 323 | The {\it Programs} are compiled with the following Sun4 324 | options: 325 | 326 | \begin{itemize} 327 | \item 328 | {\it --s:} Check the Pascal standard. 329 | \item 330 | {\it --H:} Check pointers (but not subranges). 331 | \item 332 | {\it --O:} Optimize the code. 333 | \item 334 | {\it --cg89:} Generate code for any Sun4. 335 | \end{itemize} 336 | 337 | The {\it --s} option causes the Sun Pascal compilers to 338 | display warning mesages about the nonstandard Pascal 339 | statements used in the {\it Programs}. 340 | 341 | A compilation of the {\it Programs} takes 3--5 minutes 342 | and produces two {\it Executable Files} [Brinch Hansen 343 | 1993b]: 344 | 345 | \begin{itemize} 346 | \item 347 | {\it sc:} An executable {\it Compiler}. 348 | \item 349 | {\it sr:} An executable {\it Interpreter}. 350 | \end{itemize} 351 | 352 | If you are not using {\Superpascal} on a Sun3 or Sun4, try 353 | the following if the {\it Programs} cannot be compiled 354 | directly: 355 | 356 | \begin{itemize} 357 | \item 358 | Change or omit the compilation options in the {\it 359 | Scripts}. 360 | \item 361 | Change or omit the nonstandard statements in the 362 | {\it Program Files}. 363 | \item 364 | Include the {\it Common Declarations} in each of the 365 | other {\it Program Files}. These {\it Program Files} 366 | can then be compiled separately and linked together. 367 | \end{itemize} 368 | 369 | 370 | \begin{mybibliography}{5} 371 | \entry 372 | Brinch Hansen, P. (1985) {\it Brinch Hansen on Pascal 373 | Compilers.} Prentice-Hall, Englewood Cliffs, NJ. 374 | \entry 375 | Brinch Hansen, P. (1993a) The programming language 376 | SuperPascal. School of Computer and Information Science, 377 | Syracuse University, Syracuse, NY. 378 | \entry 379 | Brinch Hansen, P. (1993b) The SuperPascal user manual. 380 | School of Computer and Information Science, Syracuse 381 | University, Syracuse, NY. 382 | \entry 383 | British Standards Institute (1982) {\it Specification 384 | for Computer Programming Language Pascal.} BS 6192. 385 | \entry 386 | Sun Microsystems (1986) {\it Pascal Programmer's Guide.} 387 | Mountain View, CA. 388 | \end{mybibliography} 389 | 390 | \end{document} 391 | -------------------------------------------------------------------------------- /super/readthis.tex: -------------------------------------------------------------------------------- 1 | % ANONYMOUS FTP OF THE SUPERPASCAL SOFTWARE 2 | % PER BRINCH HANSEN 3 | % School of Computer and Information Science 4 | % Syracuse University, Syracuse, NY 13244, USA 5 | % 29 October 1993 6 | % Copyright(c) 1993 Per Brinch Hansen 7 | 8 | % LATEX PREAMBLE 9 | \documentstyle[twoside,11pt]{article} 10 | \pagestyle{myheadings} 11 | \setlength{\topmargin}{7mm} 12 | \setlength{\textheight}{200mm} 13 | \setlength{\textwidth}{140mm} 14 | \setlength{\oddsidemargin}{14mm} 15 | \setlength{\evensidemargin}{12mm} 16 | \newcommand{\acknowledgements} 17 | {\section*{Acknowledgements} 18 | \addcontentsline{toc}{section} 19 | {Acknowledgements} 20 | } 21 | \newcommand{\blank} 22 | {\mbox{\hspace{1.8em}}} 23 | \newcommand{\blankline} 24 | {\medskip} 25 | \newcommand{\Copyright} 26 | {Copyright {\copyright}} 27 | \newcommand{\entry} 28 | {\bibitem{}} 29 | \newcommand{\example} 30 | {{\it Example:}} 31 | \newcommand{\examples} 32 | {{\it Examples:}} 33 | \newcommand{\mytitle}[3] 34 | % [title,month,year] 35 | {\markboth{PER BRINCH HANSEN}{#1} 36 | \thispagestyle{empty} 37 | \begin{center} 38 | {\Large\bf #1}\\ 39 | % TITLE 40 | \blankline 41 | PER BRINCH HANSEN\\ 42 | \blankline 43 | {\it 44 | School of Computer and Information Science \\ 45 | Syracuse University, Syracuse, NY 13244, USA\\ 46 | } 47 | \blankline 48 | #2 #3\\ 49 | % Month Year 50 | \end{center} 51 | } 52 | \newcommand{\Superpascal} 53 | {\it SuperPascal} 54 | \newenvironment{grammar} 55 | {\begin{small}} 56 | {\end{small}} 57 | \newenvironment{myabstract} 58 | {\begin{rm} 59 | \noindent{\bf Abstract:}} 60 | {\end{rm}} 61 | \newenvironment{mybibliography}[1] 62 | % [widestlabel] 63 | {\begin{small} 64 | \begin{thebibliography}{#1} 65 | \addcontentsline{toc} 66 | {section}{References}} 67 | { \end{thebibliography} 68 | \end{small}} 69 | \newenvironment{mykeywords} 70 | {\begin{small} 71 | \noindent{\bf Key Words:}} 72 | {\end{small}} 73 | \newenvironment{mytabular}[1] 74 | % [columns] 75 | {\begin{small} 76 | \begin{center} 77 | \begin{tabular}{#1}} 78 | { \end{tabular} 79 | \end{center} 80 | \end{small}} 81 | \newenvironment{program}[1] 82 | % [width] 83 | {\begin{center} 84 | \begin{minipage}{#1}} 85 | { \end{minipage} 86 | \end{center}} 87 | % Program Indentation 88 | \newcommand{\PA} 89 | {\noindent} 90 | \newcommand{\PB} 91 | {\mbox{\hspace{1em}}} 92 | \newcommand{\PC} 93 | {\mbox{\hspace{2em}}} 94 | \newcommand{\PD} 95 | {\mbox{\hspace{3em}}} 96 | \newcommand{\PE} 97 | {\mbox{\hspace{4em}}} 98 | 99 | % DOCUMENT TEXT 100 | \begin{document} 101 | 102 | \mytitle{ANONYMOUS FTP OF THE SUPERPASCAL SOFTWARE} 103 | {November}{1993} 104 | 105 | \noindent 106 | These instructions describe the {\Superpascal} software, 107 | define the terms and conditions for its use, and explain how 108 | you obtain the software by anonymous FTP. 109 | 110 | \begin{center} 111 | {\bf DEFINITIONS} 112 | \end{center} 113 | 114 | \noindent 115 | The {\it SuperPascal} software (hereafter {\it Software}) is 116 | educational software written by Per Brinch Hansen (hereafter 117 | {\it PBH}). The {\it Software} consists of the {\it Manuals}, 118 | {\it Programs}, and {\it Scripts} for the programming 119 | language {\Superpascal} invented by {\it PBH}. The {\it 120 | Software} is stored as text in 11 files (hereafter {\it 121 | Files}). 122 | 123 | The {\it Manuals}, written by {\it PBH}, are stored as {\LaTeX} 124 | text in 3 {\it Files}: 125 | 126 | \begin{itemize} 127 | \item 128 | {\it report.tex:} ``The programming language SuperPascal.'' 129 | \item 130 | {\it user.tex:} ``The SuperPascal user manual.'' 131 | \item 132 | {\it notes.tex:} ``The SuperPascal software notes.'' 133 | \end{itemize} 134 | 135 | The {\it Programs}, written by {\it PBH}, are a {\Superpascal} 136 | compiler and interpreter (hereafter {\it Compiler} and {\it 137 | Interpreter}). The {\it Programs} are written in Pascal for 138 | Sun3 and Sun4 workstations running Unix. The {\it Programs} 139 | are stored as Pascal text in 6 {\it Files}: 140 | 141 | \begin{itemize} 142 | \item 143 | {\it common.p:} The common declarations used by the 144 | {\it Compiler} and {\it Interpreter}. 145 | \item 146 | {\it scan.p:} The {\it Compiler} procedure that performs 147 | lexical analysis. 148 | \item 149 | {\it parse.p:} The {\it Compiler} procedure that performs 150 | syntax, scope, and type analysis. 151 | \item 152 | {\it assemble.p:} The {\it Compiler} procedure that 153 | assembles interpreted code. 154 | \item 155 | {\it compile.p:} The {\it Compiler} program. 156 | \item 157 | {\it interpret.p:} The {\it Interpreter} program. 158 | \end{itemize} 159 | 160 | The {\it Scripts} are Unix shell scripts stored as text in 2 161 | {\it Files}: 162 | 163 | \begin{itemize} 164 | \item 165 | {\it sun3.user:} A shell script for compilation of the 166 | {\it Programs} on a Sun3 workstation under Unix. 167 | \item 168 | {\it sun4.user:} A shell script for compilation of the 169 | {\it Programs} on a Sun4 workstation under Unix. 170 | \end{itemize} 171 | 172 | \begin{center} 173 | {\bf TERMS AND CONDITIONS} 174 | \end{center} 175 | 176 | \begin{it} 177 | \noindent 178 | THE MANUALS ARE COPYRIGHTED BY PBH. THE PROGRAMS ARE IN THE 179 | PUBLIC DOMAIN. YOU CAN OBTAIN THE SOFTWARE BY ANONYMOUS FTP. 180 | THE SOFTWARE IS NOT GUARANTEED FOR A PARTICULAR PURPOSE. PBH 181 | SUPPLIES THE SOFTWARE ``AS IS'' WITHOUT ANY WARRANTIES OR 182 | REPRESENTATIONS AND DOES NOT ACCEPT ANY LIABILITIES WITH 183 | RESPECT TO THE SOFTWARE. 184 | YOU (THE USER) ARE RESPONSIBLE FOR SELECTING THE SOFTWARE, AND 185 | FOR THE USE AND RESULTS OBTAINED FROM THE SOFTWARE. YOUR USE 186 | OF THE SOFTWARE INDICATES YOUR ACCEPTANCE OF THESE TERMS AND 187 | CONDITIONS. 188 | \end{it} 189 | 190 | \begin{center} 191 | {\bf FILE TRANSFER PROCEDURE} 192 | \end{center} 193 | 194 | \noindent 195 | To obtain the software, use anonymous FTP from the directory 196 | {\it pbh@top.cis.syr.edu}. If your local machine runs Unix, 197 | follow these steps to copy the files: 198 | 199 | \blankline 200 | 201 | Create an empty directory on your local machine by typing 202 | 203 | \begin{center} 204 | mkdir clone 205 | \end{center} 206 | 207 | Enter the local directory by typing 208 | 209 | \begin{center} 210 | cd clone 211 | \end{center} 212 | 213 | Select the remote machine by typing 214 | 215 | \begin{center} 216 | ftp top.cis.syr.edu 217 | \end{center} 218 | 219 | When prompted for your name, type 220 | 221 | \begin{center} 222 | anonymous 223 | \end{center} 224 | 225 | When prompted for your password, type your 226 | 227 | \begin{center} 228 | $<$e-mail address$>$ 229 | \end{center} 230 | 231 | Enter the remote ftp directory by typing 232 | 233 | \begin{center} 234 | cd pbh 235 | \end{center} 236 | 237 | Copy a shell archive that contains the {\it Files} by 238 | typing 239 | 240 | \begin{center} 241 | get software.shar 242 | \end{center} 243 | 244 | Leave the remote machine by typing 245 | 246 | \begin{center} 247 | bye 248 | \end{center} 249 | 250 | Split the archive into {\it Files} by typing 251 | 252 | \begin{center} 253 | sh software.shar 254 | \end{center} 255 | 256 | Your local directory should now contain the Files. 257 | 258 | \begin{center} 259 | {\bf HOW TO GET STARTED} 260 | \end{center} 261 | 262 | \noindent 263 | Transform the {\LaTeX} files into PostScript files and 264 | print the {\it Manuals}. Read ``The SuperPascal software 265 | notes" which explain how you compile the {\it Programs} 266 | on Sun3 and Sun4 workstations. Compile the {\it Programs} 267 | into two executable files: 268 | 269 | \begin{program}{14.1em} 270 | {\PA}sc{\blank}An executable {\it Compiler}. \\ 271 | {\PA}sr{\blank}An executable {\it Interpreter}.\\ 272 | \end{program} 273 | 274 | Then read "The programming language SuperPascal" and "The 275 | SuperPascal user manual." 276 | 277 | \end{document} 278 | -------------------------------------------------------------------------------- /super/scan.p: -------------------------------------------------------------------------------- 1 | { SUPERPASCAL COMPILER 2 | SCANNER 3 | 28 October 1993 4 | Copyright (c) 1993 Per Brinch Hansen } 5 | 6 | procedure scan(var lineno: integer; 7 | procedure accept(var value: char); 8 | procedure put(value: integer); 9 | procedure putreal(value: real); 10 | procedure putstring( 11 | length: integer; 12 | value: string); 13 | procedure error(kind: phrase); 14 | procedure halt(kind: phrase)); 15 | const 16 | maxkey = 631; maxshort = 10; 17 | type 18 | charset = set of char; 19 | short = 20 | packed array [1..maxshort] of 21 | char; 22 | spellingtable = 23 | array [1..maxchar] of char; 24 | wordpointer = ^ wordrecord; 25 | wordrecord = 26 | record 27 | nextword: wordpointer; 28 | symbol: boolean; 29 | index, length, lastchar: 30 | integer 31 | end; 32 | hashtable = 33 | array [1..maxkey] of wordpointer; 34 | var 35 | ch: char; afterperiod: boolean; 36 | alphanumeric, capitalletters, 37 | digits, endcomment, endline, 38 | invisible, letters, radix, 39 | separators, smallletters: charset; 40 | spelling: spellingtable; 41 | characters, identifiers: integer; 42 | hash: hashtable; 43 | nulstring: string; 44 | 45 | { INPUT } 46 | 47 | procedure nextchar; 48 | var skipped: boolean; 49 | begin 50 | repeat 51 | accept(ch); 52 | if (ch < chr(null)) 53 | or (ch > chr(del)) 54 | then 55 | skipped := true 56 | else 57 | skipped := ch in invisible 58 | until not skipped 59 | end; 60 | 61 | { OUTPUT } 62 | 63 | procedure emit1(sym: integer); 64 | begin put(sym) end; 65 | 66 | procedure emit2( 67 | sym, arg: integer); 68 | begin 69 | put(sym); put(arg) 70 | end; 71 | 72 | procedure emitreal(value: real); 73 | begin 74 | put(realconst1); 75 | putreal(value) 76 | end; 77 | 78 | procedure emitstring( 79 | length: integer; 80 | value: string); 81 | begin 82 | put(stringconst1); 83 | putstring(length, value) 84 | end; 85 | 86 | { WORD SYMBOLS AND IDENTIFIERS } 87 | 88 | function key(text: string; 89 | length: integer): integer; 90 | const w = 32641 { 32768 - 127 }; 91 | n = maxkey; 92 | var i, sum: integer; 93 | begin 94 | sum := 0; i := 1; 95 | while i <= length do 96 | begin 97 | sum := (sum + ord(text[i])) 98 | mod w; 99 | i := i + 1 100 | end; 101 | key := sum mod n + 1 102 | end; 103 | 104 | procedure insert( 105 | symbol: boolean; text: string; 106 | length, index, keyno: integer); 107 | var pointer: wordpointer; 108 | m, n: integer; 109 | begin 110 | { insert word in 111 | spelling table } 112 | characters := 113 | characters + length; 114 | if characters > maxchar then 115 | halt(maxchar5); 116 | m := length; 117 | n := characters - m; 118 | while m > 0 do 119 | begin 120 | spelling[m + n] := text[m]; 121 | m := m - 1 122 | end; 123 | { insert word in a word list } 124 | new(pointer); 125 | pointer^.nextword := 126 | hash[keyno]; 127 | pointer^.symbol := symbol; 128 | pointer^.index := index; 129 | pointer^.length := length; 130 | pointer^.lastchar := 131 | characters; 132 | hash[keyno] := pointer 133 | end; 134 | 135 | function found(text: string; 136 | length: integer; 137 | pointer: wordpointer): boolean; 138 | var same: boolean; m, n: integer; 139 | begin 140 | if pointer^.length = length then 141 | begin 142 | same := true; m := length; 143 | n := pointer^.lastchar - m; 144 | while same and (m > 0) do 145 | begin 146 | same := text[m] = 147 | spelling[m + n]; 148 | m := m - 1 149 | end 150 | end 151 | else same := false; 152 | found := same 153 | end; 154 | 155 | procedure declare( 156 | shorttext: short; 157 | index: integer; 158 | symbol: boolean); 159 | var i, length: integer; 160 | text: string; 161 | begin 162 | length := maxshort; 163 | while shorttext[length] = sp 164 | do length := length - 1; 165 | for i := 1 to length do 166 | text[i] := shorttext[i]; 167 | insert(symbol, text, length, 168 | index, key(text, length)) 169 | end; 170 | 171 | procedure search( 172 | text: string; 173 | length: integer; 174 | var symbol: boolean; 175 | var index: integer); 176 | var keyno: integer; 177 | pointer: wordpointer; 178 | done: boolean; 179 | begin 180 | keyno := key(text, length); 181 | pointer := hash[keyno]; 182 | done := false; 183 | while not done do 184 | if pointer = nil then 185 | begin 186 | symbol := false; 187 | identifiers := 188 | identifiers + 1; 189 | index := identifiers; 190 | insert(false, text, 191 | length, index, keyno); 192 | done := true 193 | end 194 | else if 195 | found(text, length, pointer) 196 | then 197 | begin 198 | symbol := pointer^.symbol; 199 | index := pointer^.index; 200 | done := true 201 | end 202 | else 203 | pointer := pointer^.nextword 204 | end; 205 | 206 | { WordSymbol = 207 | "and" | "array" | "assume" | 208 | "begin" | "case" | "const" | 209 | "div" | "do" | "downto" | 210 | "else" | "end" | "for" | 211 | "forall" | "function" | "if" | 212 | "mod" | "not" | "of" | "or" | 213 | "parallel" | "procedure" | 214 | "program" | "record" | 215 | "repeat" | "sic" | "then" | 216 | "to" | "type" | "until" | 217 | "var" | "while" . 218 | UnusedWord = 219 | "file" | "goto" | "in" | 220 | "label" | "nil" | "packed" | 221 | "set" | "with" . } 222 | 223 | procedure initialize; 224 | var i: integer; 225 | begin 226 | digits := ['0'..'9']; 227 | capitalletters := ['A'..'Z']; 228 | smallletters := ['a'..'z']; 229 | letters := 230 | capitalletters + smallletters; 231 | alphanumeric := letters + digits; 232 | endcomment := ['}', chr(etx)]; 233 | endline := [chr(nl), chr(etx)]; 234 | invisible := 235 | [chr(0)..chr(31), chr(127)] 236 | - [chr(nl), chr(etx)]; 237 | radix := ['e', 'E']; 238 | separators := [sp, chr(nl), '{']; 239 | for i := 1 to maxkey do 240 | hash[i] := nil; 241 | for i := 1 to maxstring do 242 | nulstring[i] := chr(null); 243 | characters := 0; 244 | { insert word symbols } 245 | declare('and ', and1, 246 | true); 247 | declare('array ', array1, 248 | true); 249 | declare('assume ', assume1, 250 | true); 251 | declare('begin ', begin1, 252 | true); 253 | declare('case ', case1, 254 | true); 255 | declare('const ', const1, 256 | true); 257 | declare('div ', div1, 258 | true); 259 | declare('do ', do1, 260 | true); 261 | declare('downto ', downto1, 262 | true); 263 | declare('else ', else1, 264 | true); 265 | declare('end ', end1, 266 | true); 267 | declare('file ', unknown1, 268 | true); 269 | declare('for ', for1, 270 | true); 271 | declare('forall ', forall1, 272 | true); 273 | declare('function ', function1, 274 | true); 275 | declare('goto ', unknown1, 276 | true); 277 | declare('if ', if1, 278 | true); 279 | declare('in ', unknown1, 280 | true); 281 | declare('label ', unknown1, 282 | true); 283 | declare('mod ', mod1, 284 | true); 285 | declare('nil ', unknown1, 286 | true); 287 | declare('not ', not1, 288 | true); 289 | declare('of ', of1, 290 | true); 291 | declare('or ', or1, 292 | true); 293 | declare('packed ', unknown1, 294 | true); 295 | declare('parallel ', parallel1, 296 | true); 297 | declare('procedure ', procedure1, 298 | true); 299 | declare('program ', program1, 300 | true); 301 | declare('record ', record1, 302 | true); 303 | declare('repeat ', repeat1, 304 | true); 305 | declare('set ', unknown1, 306 | true); 307 | declare('sic ', sic1, 308 | true); 309 | declare('then ', then1, 310 | true); 311 | declare('to ', to1, 312 | true); 313 | declare('type ', type1, 314 | true); 315 | declare('until ', until1, 316 | true); 317 | declare('var ', var1, 318 | true); 319 | declare('while ', while1, 320 | true); 321 | declare('with ', unknown1, 322 | true); 323 | { insert standard identifiers } 324 | declare('abs ', abs0, 325 | false); 326 | declare('arctan ', arctan0, 327 | false); 328 | declare('boolean ', boolean0, 329 | false); 330 | declare('char ', char0, 331 | false); 332 | declare('chr ', chr0, 333 | false); 334 | declare('cos ', cos0, 335 | false); 336 | declare('eof ', eof0, 337 | false); 338 | declare('eoln ', eoln0, 339 | false); 340 | declare('exp ', exp0, 341 | false); 342 | declare('false ', false0, 343 | false); 344 | declare('integer ', integer0, 345 | false); 346 | declare('ln ', ln0, 347 | false); 348 | declare('maxint ', maxint0, 349 | false); 350 | declare('maxstring ', maxstring0, 351 | false); 352 | declare('null ', null0, 353 | false); 354 | declare('odd ', odd0, 355 | false); 356 | declare('open ', open0, 357 | false); 358 | declare('ord ', ord0, 359 | false); 360 | declare('pred ', pred0, 361 | false); 362 | declare('read ', read0, 363 | false); 364 | declare('readln ', readln0, 365 | false); 366 | declare('real ', real0, 367 | false); 368 | declare('receive ', receive0, 369 | false); 370 | declare('round ', round0, 371 | false); 372 | declare('send ', send0, 373 | false); 374 | declare('sin ', sin0, 375 | false); 376 | declare('sqr ', sqr0, 377 | false); 378 | declare('sqrt ', sqrt0, 379 | false); 380 | declare('string ', string0, 381 | false); 382 | declare('succ ', succ0, 383 | false); 384 | declare('true ', true0, 385 | false); 386 | declare('trunc ', trunc0, 387 | false); 388 | declare('write ', write0, 389 | false); 390 | declare('writeln ', writeln0, 391 | false); 392 | identifiers := maxstandard; 393 | afterperiod := false 394 | end; 395 | 396 | { LEXICAL ANALYSIS } 397 | 398 | { Comment = 399 | LeftBrace [ CommentElement ]* 400 | RightBrace . 401 | CommentElement = 402 | GraphicCharacter | NewLine | 403 | Comment . } 404 | 405 | procedure comment; 406 | begin 407 | (* ch = '{' *) nextchar; 408 | while not (ch in endcomment) do 409 | if ch = '{' then comment 410 | else 411 | begin 412 | if ch = chr(nl) then 413 | begin 414 | nextchar; 415 | emit2(newline1, lineno) 416 | end 417 | else nextchar 418 | end; 419 | if ch = '}' then nextchar 420 | else error(comment3) 421 | end; 422 | 423 | { Word = 424 | WordSymbol | Identifier . 425 | Identifier = 426 | Letter [ Letter | Digit ]* . } 427 | 428 | procedure word; 429 | var symbol: boolean; text: string; 430 | length, index: integer; 431 | begin 432 | { ch in letters } 433 | length := 0; 434 | while ch in alphanumeric do 435 | begin 436 | { convert a capital letter 437 | (if any) to lower case } 438 | if ch in capitalletters then 439 | ch := chr(ord(ch) + 440 | ord('a') - ord('A')); 441 | if length = maxstring then 442 | halt(maxstring5); 443 | length := length + 1; 444 | text[length] := ch; 445 | nextchar; 446 | end; 447 | search(text, length, symbol, 448 | index); 449 | if symbol then emit1(index) 450 | else emit2(identifier1, index) 451 | end; 452 | 453 | function scaled(r: real; 454 | s: integer): real; 455 | { scaled(r,s) = r*(10**s) } 456 | var max, min: real; 457 | begin 458 | max := maxreal / 10.0; 459 | while s > 0 do 460 | begin 461 | if r <= max then 462 | r := r * 10.0 463 | else error(number3); 464 | s := s - 1 465 | end; 466 | min := 10.0 * minreal; 467 | while s < 0 do 468 | begin 469 | if r >= min then 470 | r := r / 10.0 471 | else r := 0.0; 472 | s := s + 1 473 | end; 474 | scaled := r 475 | end; 476 | 477 | { DigitSequence = 478 | Digit [ Digit ]* . } 479 | 480 | procedure digitsequence( 481 | var r: real; 482 | var n: integer); 483 | { r := digitsequence; 484 | n := length(r) } 485 | var d: real; 486 | begin 487 | r := 0.0; n := 0; 488 | if ch in digits then 489 | while ch in digits do 490 | begin 491 | d := ord(ch) - ord('0'); 492 | r := 10.0 * r + d; 493 | n := n + 1; 494 | nextchar 495 | end 496 | else error(number3) 497 | end; 498 | 499 | { UnsignedScaleFactor = 500 | DigitSequence . } 501 | 502 | procedure unsignedscalefactor( 503 | var s: integer); 504 | { s := scalefactor } 505 | var r: real; n: integer; 506 | begin 507 | digitsequence(r, n); 508 | if r > maxint then 509 | begin 510 | error(number3); 511 | s := 0 512 | end 513 | else s := trunc(r) 514 | end; 515 | 516 | { ScaleFactor = 517 | [ Sign ] 518 | UnsignedScaleFactor . 519 | Sign = 520 | "+" | "-" . } 521 | 522 | procedure scalefactor( 523 | var s: integer); 524 | { s := scalefactor } 525 | begin 526 | if ch = '+' then 527 | begin 528 | nextchar; 529 | unsignedscalefactor(s) 530 | end 531 | else if ch = '-' then 532 | begin 533 | nextchar; 534 | unsignedscalefactor(s); 535 | s := - s 536 | end 537 | else unsignedscalefactor(s) 538 | end; 539 | 540 | { UnsignedInteger = 541 | DigitSequence . } 542 | 543 | procedure unsignedinteger( 544 | r: real); 545 | var i: integer; 546 | begin 547 | if r > maxint then 548 | begin 549 | error(number3); 550 | i := 0 551 | end 552 | else i := trunc(r); 553 | emit2(intconst1, i) 554 | end; 555 | 556 | { UnsignedNumber = 557 | UnsignedReal | 558 | UnsignedInteger . 559 | UnsignedReal = 560 | IntegerPart RealOption . 561 | IntegerPart = 562 | DigitSequence . 563 | RealOption = 564 | "." FractionalPart 565 | [ ScalingPart ] | 566 | ScalingPart . 567 | FractionalPart = 568 | DigitSequence . 569 | ScalingPart = 570 | Radix ScaleFactor . 571 | Radix = 572 | "e" | "E" . } 573 | 574 | procedure unsignednumber; 575 | var i, f, r: real; 576 | s, n: integer; 577 | begin 578 | digitsequence(i, n); 579 | if ch = '.' then 580 | begin 581 | nextchar; 582 | if ch = '.' then 583 | begin 584 | { input = i.. 585 | and ch = '.' } 586 | unsignedinteger(i); 587 | afterperiod := true 588 | end 589 | else 590 | begin 591 | digitsequence(f, n); 592 | r := i + scaled(f, -n); 593 | { r = i.f } 594 | if ch in radix then 595 | begin 596 | nextchar; 597 | scalefactor(s); 598 | r := scaled(r, s) 599 | {r = i.f*(10**s) } 600 | end; 601 | emitreal(r) 602 | end 603 | end 604 | else if ch in radix then 605 | begin 606 | nextchar; 607 | scalefactor(s); 608 | r := scaled(i, s); 609 | { r = i*(10**s) } 610 | emitreal(r) 611 | end 612 | else unsignedinteger(i) 613 | end; 614 | 615 | { StringElement = 616 | StringCharacter | 617 | ApostropheImage . 618 | ApostropheImage = 619 | "''" . } 620 | 621 | procedure stringelement( 622 | var text: string; 623 | var length: integer); 624 | begin 625 | if length = maxstring then 626 | halt(maxstring5); 627 | length := length + 1; 628 | text[length] := ch; 629 | nextchar 630 | end; 631 | 632 | { CharacterString = 633 | "'" StringElements "'" . 634 | StringElements = 635 | StringElement 636 | [ StringElement ]* . } 637 | 638 | procedure characterstring; 639 | type state = 640 | (extend, accept, reject); 641 | var length: integer; s: state; 642 | text: string; 643 | begin 644 | { ch = apostrophe } 645 | text := nulstring; 646 | length := 0; 647 | nextchar; s := extend; 648 | while s = extend do 649 | if ch in endline then 650 | s := reject 651 | else if ch = apostrophe then 652 | begin 653 | nextchar; 654 | if ch = apostrophe then 655 | stringelement(text, 656 | length) 657 | else s := accept 658 | end 659 | else 660 | stringelement(text, length); 661 | if (s = accept) and (length > 0) 662 | then 663 | if length = 1 then 664 | emit2(charconst1, 665 | ord(text[1])) 666 | else 667 | emitstring(length, text) 668 | else emit1(unknown1) 669 | end; 670 | 671 | { TokenField = 672 | [ Separator ]* Token . 673 | Token = 674 | Literal | Identifier | 675 | SpecialSymbol | UnknownToken | 676 | EndText . 677 | Literal = 678 | UnsignedNumber | 679 | CharacterString . 680 | SpecialSymbol = 681 | "(" | ")" | "*" | "+" | "," | 682 | "-" | "." | "/" | ":" | ";" | 683 | "<" | "=" | ">" | "[" | "]" | 684 | ".." | ":=" | "<=" | "<>" | 685 | ">=" | "|" | WordSymbol . 686 | UnknownToken = 687 | UnusedWord | UnusedCharacter . 688 | UnusedCharacter = 689 | "!" | """ | "#" | "$" | "%" | 690 | "&" | "?" | "@" | "\" | "^" | 691 | "_" | "`" | "~" . } 692 | 693 | procedure nexttoken; 694 | begin 695 | while ch in separators do 696 | if ch = sp then nextchar 697 | else if ch = chr(nl) then 698 | begin 699 | nextchar; 700 | emit2(newline1, lineno) 701 | end 702 | else (* ch = '{' *) comment; 703 | if ch in letters then word 704 | else if ch in digits then 705 | unsignednumber 706 | else if ch = apostrophe then 707 | characterstring 708 | else if ch = '+' then 709 | begin 710 | emit1(plus1); 711 | nextchar 712 | end 713 | else if ch = '-' then 714 | begin 715 | emit1(minus1); 716 | nextchar 717 | end 718 | else if ch = '*' then 719 | begin 720 | emit1(asterisk1); 721 | nextchar; 722 | end 723 | else if ch = '/' then 724 | begin 725 | emit1(slash1); 726 | nextchar 727 | end 728 | else if ch = '<' then 729 | begin 730 | nextchar; 731 | if ch = '=' then 732 | begin 733 | emit1(notgreater1); 734 | nextchar 735 | end 736 | else if ch = '>' then 737 | begin 738 | emit1(notequal1); 739 | nextchar 740 | end 741 | else emit1(less1) 742 | end 743 | else if ch = '=' then 744 | begin 745 | emit1(equal1); 746 | nextchar 747 | end 748 | else if ch = '>' then 749 | begin 750 | nextchar; 751 | if ch = '=' then 752 | begin 753 | emit1(notless1); 754 | nextchar 755 | end 756 | else emit1(greater1) 757 | end 758 | else if ch = ':' then 759 | begin 760 | nextchar; 761 | if ch = '=' then 762 | begin 763 | emit1(becomes1); 764 | nextchar 765 | end 766 | else emit1(colon1) 767 | end 768 | else if ch = '(' then 769 | begin 770 | emit1(leftparenthesis1); 771 | nextchar 772 | end 773 | else if ch = ')' then 774 | begin 775 | emit1(rightparenthesis1); 776 | nextchar 777 | end 778 | else if ch = '[' then 779 | begin 780 | emit1(leftbracket1); 781 | nextchar 782 | end 783 | else if ch = ']' then 784 | begin 785 | emit1(rightbracket1); 786 | nextchar 787 | end 788 | else if ch = ',' then 789 | begin 790 | emit1(comma1); 791 | nextchar 792 | end 793 | else if ch = '.' then 794 | if afterperiod then 795 | begin 796 | emit1(doubledot1); 797 | nextchar; 798 | afterperiod := false 799 | end 800 | else 801 | begin 802 | nextchar; 803 | if ch = '.' then 804 | begin 805 | emit1(doubledot1); 806 | nextchar 807 | end 808 | else emit1(period1) 809 | end 810 | else if ch = ';' then 811 | begin 812 | emit1(semicolon1); 813 | nextchar 814 | end 815 | else if ch = '|' then 816 | begin 817 | emit1(bar1); 818 | nextchar 819 | end 820 | else if ch <> chr(etx) then 821 | begin 822 | emit1(unknown1); 823 | nextchar 824 | end 825 | end; 826 | 827 | { Program = 828 | TokenField [ TokenField ]* . } 829 | 830 | begin 831 | initialize; nextchar; 832 | emit2(newline1, lineno); 833 | while ch <> chr(etx) do 834 | nexttoken; 835 | emit1(endtext1) 836 | end; 837 | -------------------------------------------------------------------------------- /super/sun3.user: -------------------------------------------------------------------------------- 1 | echo Compiling Sun3 SuperPascal: 2 | pc -s -H -O -f68881 -o sc compile.p 3 | pc -s -H -O -f68881 -o sr interpret.p 4 | -------------------------------------------------------------------------------- /super/sun4.user: -------------------------------------------------------------------------------- 1 | echo Compiling Sun4 SuperPascal: 2 | pc -s -H -O -cg89 -o sc compile.p 3 | pc -s -H -O -cg89 -o sr interpret.p 4 | -------------------------------------------------------------------------------- /super/user.tex: -------------------------------------------------------------------------------- 1 | % THE SUPERPASCAL USER MANUAL 2 | % PER BRINCH HANSEN 3 | % School of Computer and Information Science 4 | % Syracuse University, Syracuse, NY 13244, USA 5 | % 28 October 1993 6 | % Copyright(c) 1993 Per Brinch Hansen 7 | 8 | % LATEX PREAMBLE 9 | \documentstyle[twoside,11pt]{article} 10 | \pagestyle{myheadings} 11 | \setlength{\topmargin}{7mm} 12 | \setlength{\textheight}{200mm} 13 | \setlength{\textwidth}{140mm} 14 | \setlength{\oddsidemargin}{14mm} 15 | \setlength{\evensidemargin}{12mm} 16 | \newcommand{\acknowledgements} 17 | {\section*{Acknowledgements} 18 | \addcontentsline{toc}{section} 19 | {Acknowledgements} 20 | } 21 | \newcommand{\blank} 22 | {\mbox{\hspace{1.8em}}} 23 | \newcommand{\blankline} 24 | {\medskip} 25 | \newcommand{\Copyright} 26 | {Copyright {\copyright}} 27 | \newcommand{\entry} 28 | {\bibitem{}} 29 | \newcommand{\example} 30 | {{\it Example:}} 31 | \newcommand{\examples} 32 | {{\it Examples:}} 33 | \newcommand{\mytitle}[3] 34 | % [title,month,year] 35 | {\markboth{Per Brinch Hansen}{#1} 36 | \thispagestyle{empty} 37 | \begin{center} 38 | {\Large\bf #1}\\ 39 | % TITLE 40 | \blankline 41 | PER BRINCH HANSEN 42 | \footnote{ 43 | \Copyright #3 % Year 44 | Per Brinch Hansen. All rights reserved.}\\ 45 | \blankline 46 | {\it 47 | School of Computer and Information Science \\ 48 | Syracuse University, Syracuse, NY 13244, USA\\ 49 | } 50 | \blankline 51 | #2 #3\\ 52 | % Month Year 53 | \end{center} 54 | } 55 | \newcommand{\Superpascal} 56 | {\it SuperPascal} 57 | \newenvironment{grammar} 58 | {\begin{small}} 59 | {\end{small}} 60 | \newenvironment{myabstract} 61 | {\begin{rm} 62 | \noindent{\bf Abstract:}} 63 | {\end{rm}} 64 | \newenvironment{mybibliography}[1] 65 | % [widestlabel] 66 | {\begin{small} 67 | \begin{thebibliography}{#1} 68 | \addcontentsline{toc} 69 | {section}{References}} 70 | { \end{thebibliography} 71 | \end{small}} 72 | \newenvironment{mykeywords} 73 | {\begin{small} 74 | \noindent{\bf Key Words:}} 75 | {\end{small}} 76 | \newenvironment{mytabular}[1] 77 | % [columns] 78 | {\begin{small} 79 | \begin{center} 80 | \begin{tabular}{#1}} 81 | { \end{tabular} 82 | \end{center} 83 | \end{small}} 84 | \newenvironment{program}[1] 85 | % [width] 86 | {\begin{center} 87 | \begin{minipage}{#1}} 88 | { \end{minipage} 89 | \end{center}} 90 | % Program Indentation 91 | \newcommand{\PA} 92 | {\noindent} 93 | \newcommand{\PB} 94 | {\mbox{\hspace{1em}}} 95 | \newcommand{\PC} 96 | {\mbox{\hspace{2em}}} 97 | \newcommand{\PD} 98 | {\mbox{\hspace{3em}}} 99 | \newcommand{\PE} 100 | {\mbox{\hspace{4em}}} 101 | 102 | % DOCUMENT TEXT 103 | \begin{document} 104 | 105 | \mytitle{The SuperPascal User Manual} 106 | {November}{1993} 107 | 108 | \begin{myabstract} 109 | This report explains how you compile and run {\Superpascal} 110 | programs [Brinch Hansen 1993a]. 111 | \end{myabstract} 112 | 113 | 114 | \section{Command Aliases} 115 | 116 | If you are using {\Superpascal} under Unix, please define the 117 | following command aliases in the file .{\it cshrc} in your 118 | home directory: 119 | 120 | \begin{program}{23.5em} 121 | {\PA}alias sc $<${\it path name of an executable compiler sc}$>$ \\ 122 | {\PA}alias sr $<${\it path name of an executable interpreter sr}$>$\\ 123 | \end{program} 124 | 125 | 126 | \section{Program Compilation} 127 | 128 | You compile a {\Superpascal} program by typing the command 129 | 130 | \begin{center} 131 | {\it sc} 132 | \end{center} 133 | 134 | \noindent 135 | followed by a return. When the message 136 | 137 | \begin{center} 138 | source = 139 | \end{center} 140 | 141 | \noindent 142 | appears, type the name of a program textfile followed by a 143 | return. After the message 144 | 145 | \begin{center} 146 | code = 147 | \end{center} 148 | 149 | \noindent 150 | type the name of a new program codefile followed by a 151 | return. 152 | 153 | \blankline 154 | 155 | \example 156 | 157 | \begin{program}{10.5em} 158 | {\PA}{\it sc} \\ 159 | {\PB}source = {\it sortprogram}\\ 160 | {\PB}code = {\it sortcode} \\ 161 | \end{program} 162 | 163 | If the compiler finds errors in a program text, the errors 164 | are reported both on the screen and in the textfile {\it 165 | errors}, but no program code is output. 166 | 167 | 168 | \section{Program Execution} 169 | 170 | You run a compiled {\Superpascal} program by typing the 171 | command 172 | 173 | \begin{center} 174 | {\it sr} 175 | \end{center} 176 | 177 | \noindent 178 | followed by a return. When the message 179 | 180 | \begin{center} 181 | code = 182 | \end{center} 183 | 184 | \noindent 185 | appears, type the name of a program codefile followed by a 186 | return. After the message 187 | 188 | \begin{center} 189 | select files? 190 | \end{center} 191 | 192 | \noindent 193 | you have a choice: 194 | 195 | \blankline 196 | 197 | 1.~If you type {\it no} followed by a return, the program 198 | will be executed with text input from the {\it keyboard} 199 | and text output on the {\it screen}. 200 | 201 | \blankline 202 | 203 | 2.~If you type {\it yes} followed by a return, you will 204 | first be asked to name the input file: 205 | 206 | \begin{center} 207 | input = 208 | \end{center} 209 | 210 | \noindent 211 | Type the name of an existing textfile or the word {\it 212 | keyboard} followed by a return. Finally, you will be asked 213 | to name the output: 214 | 215 | \begin{center} 216 | output = 217 | \end{center} 218 | 219 | \noindent 220 | Type the name of a new textfile or the word {\it screen} 221 | followed by a return. 222 | 223 | \blankline 224 | 225 | \examples 226 | 227 | \begin{program}{8.1em} 228 | {\PA}{\it sr} \\ 229 | {\PB}code = {\it sortcode} \\ 230 | {\PB}select files? {\it no} \\ 231 | {\PA} \\ 232 | {\PA}{\it sr} \\ 233 | {\PB}code = {\it sortcode} \\ 234 | {\PB}select files? {\it yes}\\ 235 | {\PB}input = {\it testdata} \\ 236 | {\PB}output = {\it screen} \\ 237 | \end{program} 238 | 239 | 240 | \section{Compile-time Errors} 241 | 242 | During compilation, the following program errors are 243 | reported: 244 | 245 | \begin{itemize} 246 | \item 247 | {\it Ambiguous case constant:} Two case constants denote 248 | the same value. 249 | \item 250 | {\it Ambiguous identifier:} A program, a function 251 | declaration, a procedure declaration, or a record type 252 | introduces two named entities with the same identifier. 253 | \item 254 | {\it Forall statement error:} In a restricted {\it forall} 255 | statement, the element statement uses a target variable. 256 | \item 257 | {\it Function block error:} A procedure statement occurs 258 | in the statement part of a function block. 259 | \item 260 | {\it Function parameter error:} A function uses an 261 | explicit or implicit variable parameter. 262 | \item 263 | {\it Identifier kind error:} A named entity of the wrong 264 | kind is used in some context. (Constants, types, fields, 265 | variables, functions and procedures are different kinds of 266 | named entities.) 267 | \item 268 | {\it Incomplete comment:} The closing delimiter \} of a 269 | comment is missing. 270 | \item 271 | {\it Index range error:} The index range of an array type 272 | has a lower bound that exceeds the upper bound. 273 | \item 274 | {\it Number error:} A constant denotes a number outside 275 | the range of integers or reals. 276 | \item 277 | {\it Parallel statement error:} In a restricted parallel 278 | statement, a target variable of one process statement is 279 | also a target or an expression variable of another process 280 | statement. 281 | \item 282 | {\it Procedure statement error:} In a restricted procedure 283 | statement, an entire variable is used more than once as a 284 | restricted actual parameter. 285 | \item 286 | {\it Recursion error:} A recursive function or procedure 287 | uses an implicit parameter. 288 | \item 289 | {\it Syntax error:} The program syntax is incorrect. 290 | \item 291 | {\it Type error:} The type of an operand is incompatible 292 | with its use. 293 | \item 294 | {\it Undefined identifier:} An identifier is used without 295 | being defined. 296 | \end{itemize} 297 | 298 | 299 | \section{Run-time Errors} 300 | 301 | During program execution, the following program errors are 302 | reported: 303 | 304 | \begin{itemize} 305 | \item 306 | {\it Channel contention:} Two processes both attemp to 307 | send or receive through the same channel. 308 | \item 309 | {\it Deadlock:} Every process is delayed by a send or 310 | receive operation, but none of these operations match. 311 | \item 312 | {\it False assumption:} An assume statement denotes a 313 | false assumption. 314 | \item 315 | {\it Message type error}: Two processes attempt to 316 | communicate through the same channel, but the output 317 | expression and the input variable are of different message 318 | types. 319 | \item 320 | {\it Range error:} The value of an index expression or a 321 | {\it chr, pred,} or {\it succ} function designator is out 322 | of range. 323 | \item 324 | {\it Undefined case constant:} A case expression does not 325 | denote a case constant. 326 | \item 327 | {\it Undefined channel reference:} A channel expression 328 | does not denote a channel. 329 | \end{itemize} 330 | 331 | 332 | \section{Software Limits} 333 | 334 | If a program is too large to be compiled or run, the software 335 | displays one of the following messages and stops. Each 336 | message indicates that the limit of a particular software 337 | array type has been exceeded: 338 | 339 | \begin{itemize} 340 | \item 341 | {\it Block limit exceeded:} The total number of blocks 342 | defined by the program and its function declarations, 343 | procedure declarations, {\it forall} statements, and 344 | process statements exceeds the limit {\it maxblock}. 345 | \item 346 | {\it Branch limit exceeded:} The total number of branches 347 | denoted by all statements in the program exceeds the limit 348 | {\it maxlabel}. 349 | \item 350 | {\it Buffer limit exceeded:} The size of the compiled code 351 | exceeds the limit {\it maxbuf}. 352 | \item 353 | {\it Case limit exceeded:} The number of case constants 354 | exceeds the limit {\it maxcase}. 355 | \item 356 | {\it Channel limit exceeded:} The number of channels 357 | opened exceeds the limit {\it maxchan}. 358 | \item 359 | {\it Character limit exceeded:} The total number of 360 | characters in all word symbols and identifiers exceeds the 361 | limit {\it maxchar}. 362 | \item 363 | {\it Memory limit exceeded:} The program execution exceeds 364 | the limit {\it maxaddr}. 365 | \item 366 | {\it Nesting limit exceeded:} The level of nesting of the 367 | program and its function declarations, procedure 368 | declarations, parallel statements, and {\it forall} 369 | statements exceeds the limit {\it maxlevel}. 370 | \item 371 | {\it String limit exceeded:} The number of characters in a 372 | word symbol, an identifier, or a character string exceeds 373 | the limit {\it maxstring}. 374 | \end{itemize} 375 | 376 | The standard {\it software limits} are: 377 | 378 | \begin{mytabular}{llrllr} 379 | maxaddr & = & 100000 & maxchar & = & 10000 \\ 380 | maxblock & = & 200 & maxlabel & = & 1000 \\ 381 | maxbuf & = & 10000 & maxlevel & = & 10 \\ 382 | maxcase & = & 128 & maxstring & = & 80 \\ 383 | maxchan & = & 10000 & & & \\ 384 | \end{mytabular} 385 | 386 | If these limits are too small for compilation or execution of 387 | a program, the limits must be increased by editing a common 388 | declaration file and recompiling both the compiler and the 389 | interpreter [Brinch Hansen 1993b]. 390 | 391 | \begin{mybibliography}{2} 392 | \entry 393 | Brinch Hansen, P. (1993a) The programming language 394 | SuperPascal. School of Computer and Information Science, 395 | Syracuse University, Syracuse, NY. 396 | \entry 397 | Brinch Hansen, P. (1993b) The SuperPascal software notes. 398 | School of Computer and Information Science, Syracuse 399 | University, Syracuse, NY. 400 | \end{mybibliography} 401 | 402 | \end{document} 403 | -------------------------------------------------------------------------------- /xdp/compsamp.bat: -------------------------------------------------------------------------------- 1 | for %%f in (samples\*.pas) do xdp %%f %1 2 | pause 3 | -------------------------------------------------------------------------------- /xdp/readme.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nickelsworth/pascal/7a376f389fcad25c41a35825deddad82e97d52c6/xdp/readme.txt -------------------------------------------------------------------------------- /xdp/samples/cannabis.pas: -------------------------------------------------------------------------------- 1 | // Cannabola plot program 2 | 3 | 4 | program Cannabis; 5 | 6 | 7 | 8 | const 9 | dt0 = 0.003; 10 | scale = 120; 11 | 12 | 13 | var 14 | r, rold, rdot, t, dt, x, y: Real; 15 | 16 | 17 | begin 18 | SetScreenMode($10); // 640 x 350 pixels, 16 colors 19 | 20 | t := 0; 21 | dt := dt0; 22 | rold := 0; 23 | 24 | while t <= 2 * pi do 25 | begin 26 | r := (1 + sin(t)) * (1 + 0.9 * cos(8 * t)) * (1 + 0.1 * cos(24 * t)) * (0.5 + 0.05 * cos(200 * t)); 27 | 28 | x := r * cos(t); 29 | y := r * sin(t); 30 | 31 | rdot := abs(r - rold) / dt; 32 | 33 | dt := dt0 / (1 + rdot); 34 | 35 | PutPixel(320 + Round(scale * x), 290 - Round(scale * y), 10); 36 | 37 | t := t + dt; 38 | rold := r; 39 | end; 40 | 41 | repeat until KeyPressed; 42 | SetScreenMode($03); 43 | end. -------------------------------------------------------------------------------- /xdp/samples/clock.pas: -------------------------------------------------------------------------------- 1 | // Clock demo program 2 | 3 | 4 | program Clock; 5 | 6 | 7 | 8 | const 9 | LHr = 60; 10 | LMn = 100; 11 | LSec = 120; 12 | RTickStart = 130; 13 | RTickEnd = 160; 14 | LTail = -10; 15 | RClock = 170; 16 | 17 | 18 | 19 | var 20 | Time: Integer; 21 | Hr, Mn, Sec, HrOld, MnOld, SecOld: Real; 22 | 23 | 24 | 25 | 26 | 27 | procedure DrawArrow(Value, Rmin, Rmax: Real; Positions: Integer; Color: Integer); 28 | var 29 | Angle: Real; 30 | begin 31 | Angle := Pi / 2 - 2 * Pi * Value / Positions; 32 | Line(320 + Round(Rmin * cos(Angle)), 175 - Round(Rmin * sin(Angle)), 33 | 320 + Round(Rmax * cos(Angle)), 175 - Round(Rmax * sin(Angle)), Color); 34 | end; 35 | 36 | 37 | 38 | procedure DrawDigits(Value: Integer; R: Real; Positions: Integer; Color: Integer); 39 | var 40 | Angle: Real; 41 | Digits: string; 42 | begin 43 | Angle := Pi / 2 - 2 * Pi * Value / Positions; 44 | IStr(Value, Digits); 45 | OutTextXY(320 + Round(R * cos(Angle)), 175 - Round(R * sin(Angle)), Color, Digits); 46 | end; 47 | 48 | 49 | 50 | 51 | var 52 | TickIndex: Integer; 53 | 54 | 55 | 56 | begin 57 | SetScreenMode($10); // 640 x 350 pixels, 16 colors 58 | 59 | Circle(320, 175, Round(RClock), 15); 60 | 61 | for TickIndex := 0 to 11 do 62 | DrawArrow(TickIndex, RTickStart, RTickEnd, 12, 15); // Draw long ticks 63 | 64 | for TickIndex := 0 to 59 do 65 | DrawArrow(TickIndex, RTickStart + 20, RTickEnd, 60, 15); // Draw short ticks 66 | 67 | repeat 68 | Time := Round(Timer / 1573032 * 86400); 69 | 70 | Hr := Time / 3600; 71 | Mn := (Time mod 3600) / 60; 72 | Sec := (Time mod 3600) mod 60; 73 | 74 | if Sec <> SecOld then 75 | begin 76 | DrawArrow(SecOld, LTail, LSec, 60, 0 ); // Erase old arrow 77 | DrawArrow(Sec, LTail, LSec, 60, 14); // Draw new arrow 78 | 79 | DrawArrow(MnOld, LTail, LMn, 60, 0 ); // Erase old arrow 80 | DrawArrow(Mn, LTail, LMn, 60, 13); // Draw new arrow 81 | 82 | DrawArrow(HrOld, LTail, LHr, 12, 0 ); // Erase old arrow 83 | DrawArrow(Hr, LTail, LHr, 12, 10); // Draw new arrow 84 | 85 | // Refresh hour digits 86 | for TickIndex := 1 to 12 do 87 | DrawDigits(TickIndex, RTickStart - 20, 12, 15); 88 | end; 89 | 90 | HrOld := Hr; MnOld := Mn; SecOld := Sec; 91 | until KeyPressed; 92 | 93 | 94 | SetScreenMode($03); 95 | end. 96 | 97 | -------------------------------------------------------------------------------- /xdp/samples/eq.dat: -------------------------------------------------------------------------------- 1 | Example. Reference solution: x = (-32, 17, 5, -14, 9, 77, 26) 2 | 7 3 | 25.614 -63.142 -38.836 -18.205 -74.554 -98.818 -64.683 -11794.102 4 | -9.677 11.028 -78.284 -6.888 56.992 -79.873 -73.671 -7350.587 5 | -51.427 24.076 70.244 -69.468 21.93 72.647 90.342 11518.809 6 | 20.945 60.902 -69.023 47.597 -85.542 49.466 -94.432 -62.607 7 | 16.921 82.31 -84.13 65.338 30.77 -23.976 -88.814 -4355.97 8 | -1.11 45.532 28.197 74.669 -79.037 10.561 -73.67 -1908.373 9 | 48.148 -36.996 9.018 -39.984 -54.582 91.142 72.861 6856.28 10 | -------------------------------------------------------------------------------- /xdp/samples/eqerr.dat: -------------------------------------------------------------------------------- 1 | Example. Zero on the diagonal 2 | 7 3 | 0 -63.142 -38.836 -18.205 -74.554 -98.818 -64.683 -11794.102 4 | -9.677 11.028 -78.284 -6.888 56.992 -79.873 -73.671 -7350.587 5 | -51.427 24.076 70.244 -69.468 21.93 72.647 90.342 11518.809 6 | 20.945 60.902 -69.023 47.597 -85.542 49.466 -94.432 -62.607 7 | 16.921 82.31 -84.13 65.338 30.77 -23.976 -88.814 -4355.97 8 | -1.11 45.532 28.197 74.669 -79.037 10.561 -73.67 -1908.373 9 | 48.148 -36.996 9.018 -39.984 -54.582 91.142 72.861 6856.28 10 | -------------------------------------------------------------------------------- /xdp/samples/factor.pas: -------------------------------------------------------------------------------- 1 | // Factorization demo 2 | 3 | 4 | program Factor; 5 | 6 | 7 | 8 | var 9 | LowBound, HighBound, Number, Dividend, Divisor, MaxDivisor: Integer; 10 | DivisorFound: Boolean; 11 | 12 | 13 | begin 14 | WriteLn; 15 | WriteLn('Integer factorization demo'); 16 | WriteLn; 17 | Write('From number: '); ReadLn(LowBound); 18 | Write('To number : '); ReadLn(HighBound); 19 | WriteLn; 20 | 21 | if LowBound < 2 then 22 | begin 23 | WriteLn('Numbers should be greater than 2'); 24 | ReadLn; 25 | Halt(1); 26 | end; 27 | 28 | for Number := LowBound to HighBound do 29 | begin 30 | Write(Number, ' = '); 31 | 32 | Dividend := Number; 33 | while Dividend > 1 do 34 | begin 35 | MaxDivisor := IMin(Round(Sqrt(Dividend)), Dividend - 1); 36 | Divisor := 1; 37 | DivisorFound := FALSE; 38 | 39 | while (Divisor <= MaxDivisor) and not DivisorFound do 40 | begin 41 | Inc(Divisor); 42 | if Dividend mod Divisor = 0 then DivisorFound := TRUE; 43 | end; 44 | 45 | if not DivisorFound then Divisor := Dividend; // Prime number 46 | 47 | Write(Divisor, ' '); 48 | Dividend := Dividend div Divisor; 49 | end; // while 50 | 51 | WriteLn; 52 | end; // for 53 | 54 | WriteLn; 55 | WriteLn('Done.'); 56 | 57 | ReadLn; 58 | end. 59 | -------------------------------------------------------------------------------- /xdp/samples/fft.pas: -------------------------------------------------------------------------------- 1 | // Fast Fourier Transform demo program 2 | 3 | 4 | program FFT; 5 | 6 | 7 | 8 | const 9 | DataLength = 512; 10 | 11 | 12 | 13 | type 14 | Complex = record 15 | Re, Im: Real; 16 | end; 17 | 18 | TData = array [0..DataLength - 1] of Real; 19 | TComplexData = array [0..DataLength - 1] of Complex; 20 | 21 | PData = ^TData; 22 | 23 | 24 | 25 | var 26 | x, S: TData; 27 | Twiddle: TComplexData; 28 | 29 | 30 | 31 | 32 | procedure CAdd(var a, b, c: Complex); 33 | begin 34 | c.Re := a.Re + b.Re; 35 | c.Im := a.Im + b.Im; 36 | end; 37 | 38 | 39 | 40 | 41 | procedure CSub(var a, b, c: Complex); 42 | begin 43 | c.Re := a.Re - b.Re; 44 | c.Im := a.Im - b.Im; 45 | end; 46 | 47 | 48 | 49 | 50 | procedure CMul(var a, b, c: Complex); 51 | begin 52 | c.Re := a.Re * b.Re - a.Im * b.Im; 53 | c.Im := a.Re * b.Im + a.Im * b.Re; 54 | end; 55 | 56 | 57 | 58 | 59 | function CAbs(var a: Complex): Real; 60 | begin 61 | CAbs := sqrt(a.Re * a.Re + a.Im * a.Im); 62 | end; 63 | 64 | 65 | 66 | 67 | procedure GetFFT(var x: TData; var FFT: TComplexData; Depth: Integer); 68 | var 69 | k, HalfLen, Step: Integer; 70 | FFTEven, FFTOdd: TComplexData; 71 | FFTOddTwiddled: Complex; 72 | xShiftedPtr: PData; 73 | 74 | begin 75 | HalfLen := DataLength shr (Depth + 1); 76 | Step := 1 shl Depth; 77 | 78 | if HalfLen = 0 then 79 | begin 80 | FFT[0].Re := x[0]; 81 | FFT[0].Im := 0; 82 | end 83 | else 84 | begin 85 | xShiftedPtr := @x[Step]; 86 | 87 | GetFFT(x, FFTEven, Depth + 1); 88 | GetFFT(xShiftedPtr^, FFTOdd, Depth + 1); 89 | 90 | for k := 0 to HalfLen - 1 do 91 | begin 92 | CMul(FFTOdd[k], Twiddle[k * Step], FFTOddTwiddled); 93 | 94 | CAdd(FFTEven[k], FFTOddTwiddled, FFT[k]); 95 | CSub(FFTEven[k], FFTOddTwiddled, FFT[k + HalfLen]); 96 | end; // for 97 | end; // else 98 | 99 | end; 100 | 101 | 102 | 103 | 104 | procedure Spectrum(var x, S: TData); 105 | var 106 | FFT: TComplexData; 107 | i: Integer; 108 | begin 109 | for i := 0 to DataLength - 1 do 110 | begin 111 | Twiddle[i].Re := cos(2 * Pi * i / DataLength); 112 | Twiddle[i].Im := -sin(2 * Pi * i / DataLength); 113 | end; 114 | 115 | GetFFT(x, FFT, 0); 116 | 117 | for i := 0 to DataLength - 1 do 118 | S[i] := CAbs(FFT[i]); 119 | 120 | end; 121 | 122 | 123 | 124 | 125 | const 126 | x01 = 50; y01 = 100; scale = 4.0; 127 | x02 = 50; y02 = 300; 128 | 129 | 130 | 131 | var 132 | Amp, Period: array [0..4] of Real; 133 | Phase: Real; 134 | i, j: Integer; 135 | Ch: Char; 136 | 137 | 138 | 139 | begin 140 | Randomize; 141 | 142 | repeat 143 | SetScreenMode($10); // 640 x 350 pixels, 16 colors 144 | 145 | Line(x01, y01, x01 + 540, y01, 12); // Time axis 146 | OutTextXY(x01 + 550, y01, 15, 'Time'); 147 | 148 | Line(x01, y01 - 50, x01, y01 + 50, 12); // Signal axis 149 | OutTextXY(x01, y01 - 60, 15, 'Signal'); 150 | 151 | Line(x02, y02, x02 + 270, y02, 12); // Frequency axis 152 | OutTextXY(x02 + 280, y02, 15, 'Frequency'); 153 | 154 | Line(x02, y02 - 100, x02, y02, 12); // Amplitude axis 155 | OutTextXY(x02, y02 - 110, 15, 'Magnitude'); 156 | 157 | for j := 0 to 4 do 158 | begin 159 | Amp[j] := (Random - 0.5) * 40; 160 | Period[j] := 2 + abs(Random - 0.5) * 40; 161 | end; 162 | 163 | for i := 0 to DataLength - 1 do 164 | begin 165 | Phase := 2 * Pi * i; 166 | 167 | x[i] := Amp[0] / 2; 168 | 169 | for j := 1 to 4 do 170 | x[i] := x[i] + Amp[j] * sin(Phase / Period[j]); 171 | 172 | if i > 0 then Line(x01 + i - 1, y01 - Round(x[i - 1]), x01 + i, y01 - Round(x[i]), 10); 173 | end; // for 174 | 175 | Spectrum(x, S); 176 | 177 | for i := 0 to DataLength shr 1 - 1 do 178 | Line(x02 + i, y02, x02 + i, y02 - Round(scale * S[i] * 2 / DataLength), 9); 179 | 180 | Line(x02 - 2, y02 - Round(scale * abs(Amp[0])), 181 | x02 + 2, y02 - Round(scale * abs(Amp[0])), 14); 182 | 183 | for j := 1 to 4 do 184 | Line(x02 + Round(DataLength / Period[j]) - 2, y02 - Round(scale * abs(Amp[j])), 185 | x02 + Round(DataLength / Period[j]) + 2, y02 - Round(scale * abs(Amp[j])), 14); 186 | 187 | Read(Ch); 188 | until Ch = #27; 189 | 190 | SetScreenMode($03); 191 | end. 192 | 193 | 194 | -------------------------------------------------------------------------------- /xdp/samples/fractal.pas: -------------------------------------------------------------------------------- 1 | // Mandelbrot set fragment plot program 2 | 3 | 4 | program Fractal; 5 | 6 | 7 | 8 | const 9 | ReCmax = 0.08; ReCmin = -0.66; 10 | ImCmax = -0.3; ImCmin = -1.25; 11 | 12 | Inf = 200; 13 | MaxPoints = 45; 14 | 15 | Scale = 320; 16 | 17 | 18 | 19 | function ScreenX(x: Real): Integer; 20 | begin 21 | Result := 410 + Round(Scale * x); 22 | end; 23 | 24 | 25 | 26 | function ScreenY(y: Real): Integer; 27 | begin 28 | Result := 420 + Round(Scale * y); 29 | end; 30 | 31 | 32 | 33 | var 34 | ReC, ImC, ReZ, ImZ, ReZnew, ImZnew: Real; 35 | i, x, y, xmin, ymin, xmax, ymax: SmallInt; 36 | color: ShortInt; 37 | IsInf: Boolean; 38 | Palette: array [0..8] of ShortInt; 39 | 40 | 41 | 42 | begin 43 | // Custom palette 44 | Palette[0] := 4 ; Palette[1] := 12; Palette[2] := 13; 45 | Palette[3] := 14; Palette[4] := 10; Palette[5] := 2 ; 46 | Palette[6] := 3 ; Palette[7] := 1 ; Palette[8] := 0 ; 47 | 48 | SetScreenMode($10); // 640 x 350 pixels, 16 colors 49 | 50 | // Border lines 51 | xmin := ScreenX(ReCmin) - 1; ymin := ScreenY(ImCmin) - 1; 52 | xmax := ScreenX(ReCmax) + 1; ymax := ScreenY(ImCmax) + 1; 53 | 54 | Line(xmin, ymin, xmax, ymin, 15); 55 | Line(xmin, ymax, xmax, ymax, 15); 56 | Line(xmin, ymin, xmin, ymax, 15); 57 | Line(xmax, ymin, xmax, ymax, 15); 58 | 59 | // Mandelbrot set construction 60 | ReC := ReCmin; 61 | 62 | while ReC <= ReCmax do 63 | begin 64 | ImC := ImCmin; 65 | 66 | while ImC <= ImCmax do 67 | begin 68 | ReZ := 0; ImZ := 0; 69 | IsInf := FALSE; 70 | color := 0; 71 | i := 1; 72 | 73 | while (i <= MaxPoints) and not IsInf do 74 | begin 75 | ReZnew := ReZ * ReZ - ImZ * ImZ + ReC; 76 | ImZnew := 2 * ReZ * ImZ + ImC; 77 | 78 | if (abs(ReZnew) > Inf) or (abs(ImZnew) > Inf) then 79 | begin 80 | IsInf := TRUE; 81 | color := Palette[8 - (i - 1) div 5]; 82 | end; 83 | 84 | ReZ := ReZnew; ImZ := ImZnew; 85 | Inc(i); 86 | end; // while i... 87 | 88 | PutPixel(ScreenX(ReC), ScreenY(ImC), color); 89 | 90 | ImC := ImC + 0.001; 91 | end; // while ImC... 92 | 93 | ReC := ReC + 0.001; 94 | end; // while ReC... 95 | 96 | repeat until KeyPressed; 97 | SetScreenMode($03); 98 | end. 99 | -------------------------------------------------------------------------------- /xdp/samples/gauss.inc: -------------------------------------------------------------------------------- 1 | // Implementation of Gauss' method for linear systems 2 | 3 | 4 | 5 | const 6 | MAXSIZE = 10; 7 | 8 | 9 | type 10 | TVector = array [1..MAXSIZE] of Real; 11 | TMatrix = array [1..MAXSIZE] of TVector; 12 | 13 | 14 | 15 | procedure Error(const E: string); forward; // To be defined in the main module 16 | 17 | 18 | 19 | procedure SolveLinearSystem(var T: TMatrix; var x: TVector; m: Integer); 20 | var 21 | i, j, k: Integer; 22 | s: Real; 23 | 24 | procedure TriangularizeMatrix(var T: TMatrix; m: Integer); 25 | var 26 | i, j, k: Integer; 27 | r: Real; 28 | begin 29 | for k := 1 to m - 1 do 30 | for i := k + 1 to m do 31 | begin 32 | if T[k, k] = 0 then Error('Diagonal element is zero'); 33 | 34 | r := -T[i, k] / T[k, k]; 35 | 36 | for j := k to m + 1 do 37 | T[i, j] := T[i, j] + r * T[k, j]; 38 | end; 39 | end; 40 | 41 | begin 42 | TriangularizeMatrix(T, m); 43 | 44 | for i := m downto 1 do 45 | begin 46 | s := T[i, m + 1]; 47 | for j := m downto i + 1 do 48 | s := s - T[i, j] * x[j]; 49 | 50 | if T[i, i] = 0 then Error('Singular matrix'); 51 | 52 | x[i] := s / T[i, i]; 53 | end; // for 54 | 55 | end; 56 | 57 | -------------------------------------------------------------------------------- /xdp/samples/inserr.pas: -------------------------------------------------------------------------------- 1 | // Inertial navigation system error estimator demo 2 | 3 | 4 | program INSErr; 5 | 6 | 7 | {$I samples\kalman.inc} 8 | 9 | 10 | 11 | const 12 | g = 9.81; 13 | Re = 6378e3; 14 | dt = 0.1; 15 | A = 100.0; 16 | beta = 1e-4; 17 | deg = pi / 180; 18 | hr = 3600; 19 | tstop = 2 * hr; 20 | 21 | 22 | 23 | type 24 | TModel = record 25 | dV, Phi, omegaDr, z: Real; 26 | end; 27 | 28 | 29 | 30 | 31 | function GaussRnd(m, sigma: Real): Real; 32 | var 33 | s: Real; 34 | i: SmallInt; 35 | begin 36 | s := 0; 37 | 38 | for i := 1 to 12 do 39 | s := s + Random; 40 | 41 | Result := m + sigma * (s - 6); 42 | end; 43 | 44 | 45 | 46 | 47 | procedure InitModel(var M: TModel); 48 | begin 49 | M.dV := 0; 50 | M.Phi := GaussRnd(0, 0.1 * deg); 51 | M.omegaDr := GaussRnd(0, 0.5 * deg / hr); 52 | end; 53 | 54 | 55 | 56 | procedure ExecuteModel(var M: TModel); 57 | var 58 | dVdot, Phidot, omegaDrdot: Real; 59 | begin 60 | dVdot := -g * M.Phi; 61 | Phidot := M.dV / Re + M.omegaDr; 62 | omegaDrdot := -beta * M.omegaDr + A * sqrt(2 * beta) * GaussRnd(0, 0.0000001); 63 | 64 | M.dV := M.dV + dVdot * dt; 65 | M.Phi := M.Phi + Phidot * dt; 66 | M.omegaDr := M.omegaDr + omegaDrdot * dt; 67 | 68 | M.z := M.dV + GaussRnd(0, 3.0); 69 | end; 70 | 71 | 72 | 73 | procedure InitSchulerKF(var KF: TKalmanFilter; Q, R: Real); 74 | begin 75 | {The following error model is used: 76 | 77 | dV' := -g F; 78 | F' := dV / R + wdr; 79 | wdr' := -b wdr + A sqrt(2b) w; 80 | 81 | z := dV + v.} 82 | 83 | KF.n := 3; KF.m := 1; KF.s := 1; 84 | 85 | KF.Phi[1, 1] := 1; KF.Phi[1, 2] := -g * dt; KF.Phi[1, 3] := 0; 86 | KF.Phi[2, 1] := dt / Re; KF.Phi[2, 2] := 1; KF.Phi[2, 3] := dt; 87 | KF.Phi[3, 1] := 0; KF.Phi[3, 2] := 0; KF.Phi[3, 3] := 1 - beta * dt; 88 | 89 | KF.H[1, 1] := 1; KF.H[1, 2] := 0; KF.H[1, 3] := 0; 90 | 91 | KF.G[1, 1] := 0; 92 | KF.G[2, 1] := 0; 93 | KF.G[3, 1] := A * sqrt(2 * beta) * dt; 94 | 95 | KF.Q[1, 1] := Q; 96 | 97 | KF.R[1, 1] := R; 98 | 99 | KF.x[1, 1] := 0; KF.x[2, 1] := 0; KF.x[3, 1] := 0; 100 | 101 | KF.P[1, 1] := 1; KF.P[1, 2] := 0; KF.P[1, 3] := 0; 102 | KF.P[2, 1] := 0; KF.P[2, 2] := 1; KF.P[2, 3] := 0; 103 | KF.P[3, 1] := 0; KF.P[3, 2] := 0; KF.P[3, 3] := 1; 104 | end; 105 | 106 | 107 | 108 | 109 | const 110 | x0 = 50; scalex = 540 / (tstop / dt); 111 | y01 = 60; scaley1 = 1; 112 | y02 = 170; scaley2 = 100; 113 | y03 = 280; scaley3 = 10; 114 | 115 | 116 | 117 | var 118 | Model: TModel; 119 | Filter: TKalmanFilter; 120 | 121 | i, screenx: Integer; 122 | Ch: Char; 123 | rand: Real; 124 | 125 | 126 | 127 | begin 128 | Randomize; 129 | 130 | repeat 131 | SetScreenMode($10); // 640 x 350 pixels, 16 colors 132 | 133 | Line(x0, y01, x0 + 540, y01, 12); // t axis 134 | OutTextXY(x0 + 550, y01, 15, 'Time'); 135 | 136 | Line(x0, y01 - 40, x0, y01 + 40, 12); // dV axis 137 | OutTextXY(x0, y01 - 50, 15, 'Velocity Error'); 138 | 139 | Line(x0, y02, x0 + 540, y02, 12); // t axis 140 | OutTextXY(x0 + 550, y02, 15, 'Time'); 141 | 142 | Line(x0, y02 - 40, x0, y02 + 40, 12); // Phi axis 143 | OutTextXY(x0, y02 - 50, 15, 'Angle Error'); 144 | 145 | Line(x0, y03, x0 + 540, y03, 12); // t axis 146 | OutTextXY(x0 + 550, y03, 15, 'Time'); 147 | 148 | Line(x0, y03 - 40, x0, y03 + 40, 12); // omegaDr axis 149 | OutTextXY(x0, y03 - 50, 15, 'Gyro Drift'); 150 | 151 | InitModel(Model); 152 | InitSchulerKF(Filter, 1e-10, 1e6); 153 | 154 | for i := 0 to Round(tstop / dt) do 155 | begin 156 | ExecuteModel(Model); 157 | Filter.z[1, 1] := Model.z; 158 | ExecuteFilter(Filter); 159 | 160 | screenx := x0 + Round(scalex * i); 161 | 162 | PutPixel(screenx, y01 - Round(scaley1 * Model.z ), 5); 163 | 164 | PutPixel(screenx, y01 - Round(scaley1 * Model.dV ), 9); 165 | PutPixel(screenx, y02 - Round(scaley2 * Model.Phi / deg ), 9); 166 | PutPixel(screenx, y03 - Round(scaley3 * Model.omegaDr / (deg / hr)), 9); 167 | 168 | if i * dt > 0.01 * tstop then 169 | begin 170 | PutPixel(screenx, y01 - Round(scaley1 * Filter.x[1, 1] ), 14); 171 | PutPixel(screenx, y02 - Round(scaley2 * Filter.x[2, 1] / deg ), 14); 172 | PutPixel(screenx, y03 - Round(scaley3 * Filter.x[3, 1] / (deg / hr)), 14); 173 | end; 174 | 175 | end; // for 176 | 177 | Read(Ch); 178 | until Ch = #27; 179 | 180 | SetScreenMode($03); 181 | end. 182 | -------------------------------------------------------------------------------- /xdp/samples/kalman.inc: -------------------------------------------------------------------------------- 1 | // Kalman filter implementation 2 | 3 | 4 | 5 | const 6 | MAXORDER = 3; 7 | 8 | 9 | 10 | type 11 | TMatrix = array [1..MAXORDER, 1..MAXORDER] of Real; 12 | 13 | TKalmanFilter = record 14 | n, m, s: SmallInt; 15 | x, xapri, z: TMatrix; 16 | Phi, G, H, Q, R, P, Papri, K: TMatrix; 17 | end; 18 | 19 | 20 | 21 | 22 | 23 | procedure Transpose(m, n: SmallInt; var C, CT: TMatrix); 24 | var 25 | i, j: SmallInt; 26 | begin 27 | for i := 1 to m do 28 | for j := 1 to n do 29 | CT[j, i] := C[i, j]; 30 | end; 31 | 32 | 33 | 34 | 35 | // C = C1 + C2 36 | procedure Add(m, n: SmallInt; var C1, C2, C: TMatrix); 37 | var 38 | i, j: SmallInt; 39 | begin 40 | for i := 1 to m do 41 | for j := 1 to n do 42 | C[i, j] := C1[i, j] + C2[i, j]; 43 | end; 44 | 45 | 46 | 47 | 48 | // C = C1 - C2 49 | procedure Sub(m, n: SmallInt; var C1, C2, C: TMatrix); 50 | var 51 | i, j: SmallInt; 52 | begin 53 | for i := 1 to m do 54 | for j := 1 to n do 55 | C[i, j] := C1[i, j] - C2[i, j]; 56 | end; 57 | 58 | 59 | 60 | 61 | // C = C1 * C2 62 | procedure Mult(m1, n1, n2: SmallInt; var C1, C2, C: TMatrix); 63 | var 64 | i, j, k: SmallInt; 65 | begin 66 | for i := 1 to m1 do 67 | for j := 1 to n2 do 68 | begin 69 | C[i, j] := 0; 70 | for k := 1 to n1 do 71 | C[i, j] := C[i, j] + C1[i, k] * C2[k, j]; 72 | end; 73 | end; 74 | 75 | 76 | 77 | 78 | // Cs = B * C * BT 79 | // mm mn nn nm 80 | procedure Similarity(m, n: SmallInt; var B, C, Cs: TMatrix); 81 | var 82 | BT, BC: TMatrix; 83 | begin 84 | Mult(m, n, n, B, C, BC); 85 | Transpose(m, n, B, BT); 86 | Mult(m, n, m, BC, BT, Cs); 87 | end; 88 | 89 | 90 | 91 | 92 | procedure Identity(n: SmallInt; var E: TMatrix); 93 | var 94 | i, j: SmallInt; 95 | begin 96 | for i := 1 to n do 97 | for j := 1 to n do 98 | if i = j then E[i, j] := 1 else E[i, j] := 0; 99 | end; 100 | 101 | 102 | 103 | 104 | procedure Inverse(m: SmallInt; var C, Cinv: TMatrix); 105 | var 106 | big, fabval, pivinv, temp: Real; 107 | i, j, k, l, ll, irow, icol: SmallInt; 108 | indxc, indxr, ipiv: array [1..MAXORDER] of SmallInt; 109 | 110 | begin 111 | for i := 1 to m do 112 | for j := 1 to m do 113 | Cinv[i, j] := C[i, j]; 114 | 115 | for j := 1 to m do 116 | ipiv[j] := 0; 117 | 118 | icol := 1; irow := 1; 119 | 120 | for i := 1 to m do 121 | begin 122 | big := 0; 123 | 124 | for j := 1 to m do 125 | if ipiv[j] <> 1 then 126 | for k := 1 to m do 127 | begin 128 | if ipiv[k] = 0 then 129 | begin 130 | if Cinv[j, k] < 0 then fabval := -Cinv[j, k] else fabval := Cinv[j, k]; 131 | 132 | if fabval >= big then 133 | begin 134 | big := fabval; 135 | irow := j; 136 | icol := k; 137 | end; 138 | end // if 139 | else 140 | begin 141 | // Singular matrix 142 | end; // else 143 | end; // for 144 | 145 | Inc(ipiv[icol]); 146 | 147 | if irow <> icol then 148 | for l := 1 to m do 149 | begin 150 | temp := Cinv[irow, l]; 151 | Cinv[irow, l] := Cinv[icol, l]; 152 | Cinv[icol, l] := temp; 153 | end; 154 | 155 | indxr[i] := irow; 156 | indxc[i] := icol; 157 | 158 | pivinv := 1 / Cinv[icol, icol]; 159 | Cinv[icol, icol] := 1; 160 | 161 | for l := 1 to m do 162 | Cinv[icol, l] := Cinv[icol, l] * pivinv; 163 | 164 | for ll := 1 to m do 165 | if ll <> icol then 166 | begin 167 | temp := Cinv[ll, icol]; 168 | Cinv[ll, icol] := 0; 169 | for l := 1 to m do Cinv[ll, l] := Cinv[ll, l] - Cinv[icol, l] * temp; 170 | end; // for 171 | end; // for 172 | 173 | for l := m downto 1 do 174 | begin 175 | if indxr[l] <> indxc[l] then 176 | for k := 1 to m do 177 | begin 178 | temp := Cinv[k, indxr[l]]; 179 | Cinv[k, indxr[l]] := Cinv[k, indxc[l]]; 180 | Cinv[k, indxc[l]] := temp; 181 | end; // for 182 | end; //for 183 | end; 184 | 185 | 186 | 187 | 188 | procedure ExecuteFilter(var KF: TKalmanFilter); 189 | var 190 | PhiPPhiT, GQGT, HT, HPapriHT, HPapriHTplusR, HPapriHTplusRinv, PapriHT, Hxapri, nu, Knu, KH, EminusKH, E: TMatrix; 191 | begin 192 | {All variable names correspond to the notation in the book: 193 | Salychev O. S. Applied Inertial Navigation 194 | 'apri' means 'a priori' and stands for 'k/k-1'} 195 | 196 | // A priori state vector estimate 197 | Mult(KF.n, KF.n, 1, KF.Phi, KF.x, KF.xapri); 198 | 199 | // A priori variance matrix 200 | Similarity(KF.n, KF.n, KF.Phi, KF.P, PhiPPhiT); 201 | Similarity(KF.n, KF.s, KF.G, KF.Q, GQGT); 202 | 203 | Add(KF.n, KF.n, PhiPPhiT, GQGT, KF.Papri); 204 | 205 | // Gain matrix 206 | Similarity(KF.m, KF.n, KF.H, KF.Papri, HPapriHT); 207 | Add(KF.m, KF.m, HPapriHT, KF.R, HPapriHTplusR); 208 | Inverse(KF.m, HPapriHTplusR, HPapriHTplusRinv); 209 | 210 | Transpose(KF.m, KF.n, KF.H, HT); 211 | Mult(KF.n, KF.n, KF.m, KF.Papri, HT, PapriHT); 212 | 213 | Mult(KF.n, KF.m, KF.m, PapriHT, HPapriHTplusRinv, KF.K); 214 | 215 | // A posteriori state vector estimate 216 | Mult(KF.m, KF.n, 1, KF.H, KF.xapri, Hxapri); 217 | Sub(KF.m, 1, KF.z, Hxapri, nu); 218 | Mult(KF.n, KF.m, 1, KF.K, nu, Knu); 219 | 220 | Add(KF.n, 1, KF.xapri, Knu, KF.x); 221 | 222 | // A posteriori variance matrix 223 | Mult(KF.n, KF.m, KF.n, KF.K, KF.H, KH); 224 | Identity(KF.n, E); 225 | Sub(KF.n, KF.n, E, KH, EminusKH); 226 | 227 | Mult(KF.n, KF.n, KF.n, EminusKH, KF.Papri, KF.P); 228 | end; 229 | 230 | -------------------------------------------------------------------------------- /xdp/samples/life.pas: -------------------------------------------------------------------------------- 1 | // The Game of Life 2 | 3 | 4 | program Life; 5 | 6 | 7 | 8 | const 9 | VideoBufOrigin = $A0000000; 10 | Width = 320; 11 | Height = 200; 12 | FieldSize = 100; 13 | 14 | 15 | type 16 | TVideoBuf = array [0..Height - 1, 0..Width - 1] of ShortInt; 17 | PVideoBuf = ^TVideoBuf; 18 | TField = array [1..FieldSize * FieldSize] of Boolean; 19 | 20 | 21 | var 22 | VideoBuf: PVideoBuf; 23 | Fld: TField; 24 | 25 | 26 | 27 | function ind(i, j: Integer): Integer; // Linear index of a cell modulo field size 28 | begin 29 | while i > FIELDSIZE do i := i - FIELDSIZE; 30 | while i < 1 do i := i + FIELDSIZE; 31 | while j > FIELDSIZE do j := j - FIELDSIZE; 32 | while j < 1 do j := j + FIELDSIZE; 33 | 34 | Result := FIELDSIZE * (i - 1) + j; 35 | end; 36 | 37 | 38 | 39 | 40 | procedure Redraw; 41 | const 42 | OriginX = Width div 2 - FieldSize div 2; 43 | OriginY = Height div 2 - FieldSize div 2; 44 | 45 | var 46 | i, j: Integer; 47 | clr: ShortInt; 48 | 49 | begin 50 | for i := 1 to FieldSize do 51 | for j := 1 to FieldSize do 52 | begin 53 | if Fld[ind(i, j)] then clr := 14 else clr := 1; 54 | VideoBuf^[OriginY + j, OriginX + i] := clr; 55 | end; 56 | 57 | end; // Redraw 58 | 59 | 60 | 61 | 62 | procedure Init; 63 | var 64 | i, j: Integer; 65 | begin 66 | Randomize; 67 | 68 | for i := 1 to FieldSize do 69 | for j := 1 to FieldSize do 70 | Fld[ind(i, j)] := Random > 0.5; 71 | end; // Init 72 | 73 | 74 | 75 | 76 | procedure Regenerate; 77 | var 78 | NextFld: TField; 79 | i, j, ni, nj, n: Integer; 80 | begin 81 | 82 | for i := 1 to FieldSize do 83 | for j := 1 to FieldSize do 84 | begin 85 | // Count cell neighbors 86 | n := 0; 87 | for ni := i - 1 to i + 1 do 88 | for nj := j - 1 to j + 1 do 89 | if Fld[ind(ni, nj)] and not ((ni = i) and (nj = j)) then Inc(n); 90 | 91 | // Bear or kill the current cell in the next generation 92 | if Fld[ind(i, j)] then 93 | NextFld[ind(i, j)] := (n > 1) and (n < 4) // Kill the cell or keep it alive 94 | else 95 | NextFld[ind(i, j)] := n = 3; // Bear the cell or keep it dead 96 | end; // for j... 97 | 98 | // Make new generation 99 | for i := 1 to FieldSize do 100 | for j := 1 to FieldSize do 101 | Fld[ind(i, j)] := NextFld[ind(i, j)]; 102 | 103 | end; // Regenerate 104 | 105 | 106 | 107 | 108 | var 109 | Ch: Char; 110 | 111 | begin 112 | // Create initial population 113 | Init; 114 | 115 | // Set graphics mode 116 | SetScreenMode($13); // 320 x 200, 256 colors 117 | VideoBuf := PVideoBuf(VideoBufOrigin); 118 | 119 | // Run simulation 120 | repeat 121 | Redraw; 122 | Regenerate; 123 | until KeyPressed; 124 | 125 | SetScreenMode($03); 126 | end. 127 | 128 | 129 | 130 | -------------------------------------------------------------------------------- /xdp/samples/lineq.pas: -------------------------------------------------------------------------------- 1 | // Linear equations solver 2 | 3 | 4 | program LinEq; 5 | 6 | 7 | 8 | {$I samples\gauss.inc} 9 | 10 | 11 | 12 | procedure Error; 13 | begin 14 | WriteLn; 15 | WriteLn('Error: ', E, '.'); 16 | ReadLn; 17 | Halt(1); 18 | end; 19 | 20 | 21 | 22 | var 23 | A: TMatrix; 24 | x: TVector; 25 | m, i, j: Integer; 26 | 27 | DatName, Comment: string; 28 | DatFile: Text; 29 | Err: Integer; 30 | 31 | 32 | 33 | begin 34 | WriteLn; 35 | WriteLn('Linear equations solver'); 36 | WriteLn; 37 | Write('File name : '); ReadLn(DatName); 38 | WriteLn; 39 | 40 | Reset(DatFile, DatName); 41 | Err := IOResult; 42 | if Err <> 0 then 43 | begin 44 | WriteLn('Unable to open file: ', DatName, ' (error code ', Err, ')'); 45 | ReadLn; 46 | Halt(1); 47 | end; 48 | 49 | ReadLn(DatFile, Comment); 50 | WriteLn('Comment : ', Comment); 51 | WriteLn; 52 | 53 | ReadLn(DatFile, m); 54 | WriteLn('System order: ', m); 55 | WriteLn; 56 | 57 | WriteLn('Augmented ', m, ' x ', m + 1, ' matrix: '); 58 | WriteLn; 59 | 60 | for i := 1 to m do 61 | begin 62 | for j := 1 to m + 1 do 63 | begin 64 | Read(DatFile, A[i, j]); 65 | Write(A[i, j], ' '); 66 | end; 67 | ReadLn(DatFile); 68 | WriteLn; 69 | end; 70 | 71 | Close(DatFile); 72 | 73 | SolveLinearSystem(A, x, m); 74 | 75 | WriteLn; 76 | WriteLn('Triangularized matrix:'); 77 | WriteLn; 78 | 79 | for i := 1 to m do 80 | begin 81 | for j := 1 to m + 1 do 82 | Write(A[i, j], ' '); 83 | WriteLn; 84 | end; 85 | 86 | WriteLn; 87 | WriteLn('Solution: '); 88 | WriteLn; 89 | 90 | for i := 1 to m do 91 | WriteLn('x', i, ' = ', x[i]); 92 | 93 | WriteLn; 94 | WriteLn('Done.'); 95 | ReadLn; 96 | end. 97 | -------------------------------------------------------------------------------- /xdp/samples/list.pas: -------------------------------------------------------------------------------- 1 | // Linked list operations demo 2 | 3 | 4 | program List; 5 | 6 | 7 | 8 | type 9 | PPerson = ^TPerson; 10 | 11 | TPerson = record 12 | Next: PPerson; 13 | Name, Surname: string; 14 | Born: SmallInt; 15 | end; 16 | 17 | 18 | var 19 | Head, Node, NewNode: PPerson; 20 | ch: Char; 21 | 22 | 23 | 24 | begin 25 | WriteLn; 26 | WriteLn('Linked list operations demo'); 27 | WriteLn; 28 | 29 | New(Node); 30 | Head := Node; 31 | 32 | 33 | // Fill the list 34 | repeat 35 | Write('Add new record? (Y/N): '); ReadLn(ch); 36 | WriteLn; 37 | 38 | if (ch = 'y') or (ch = 'Y') then 39 | begin 40 | New(NewNode); 41 | Node^.Next := NewNode; 42 | Node := NewNode; 43 | Node^.Next := nil; 44 | Write('Name : '); ReadLn(Node^.Name); 45 | Write('Surname : '); ReadLn(Node^.Surname); 46 | Write('Born in : '); ReadLn(Node^.Born); 47 | WriteLn; 48 | end; 49 | until (ch = 'n') or (ch = 'N'); 50 | 51 | 52 | WriteLn; 53 | WriteLn('Record list: '); 54 | WriteLn; 55 | 56 | 57 | // Traverse the list 58 | Node := Head^.Next; 59 | 60 | while Node <> nil do 61 | begin 62 | WriteLn(Node^.Name, ' ', Node^.Surname, ', b. ', Node^.Born); 63 | Node := Node^.Next; 64 | end; 65 | 66 | 67 | // Clear the list 68 | Node := Head; 69 | 70 | while Node <> nil do 71 | begin 72 | NewNode := Node^.Next; 73 | Dispose(Node); 74 | Node := NewNode; 75 | end; 76 | 77 | WriteLn; 78 | WriteLn('Done.'); 79 | 80 | ReadLn; 81 | end. 82 | 83 | 84 | 85 | 86 | -------------------------------------------------------------------------------- /xdp/samples/palette.pas: -------------------------------------------------------------------------------- 1 | // Graphics palette usage demo 2 | 3 | 4 | program Palette; 5 | 6 | 7 | 8 | const 9 | VideoBufOrigin = $A0000000; 10 | Width = 320; 11 | Height = 200; 12 | 13 | 14 | type 15 | TVideoBuf = array [0..Height - 1, 0..Width - 1] of ShortInt; 16 | PVideoBuf = ^TVideoBuf; 17 | 18 | 19 | procedure SetPalette; 20 | var 21 | i: Integer; 22 | begin 23 | for i := 0 to 255 do 24 | begin 25 | OutP($3C8, i); 26 | OutP($3C9, i div 8); // Red 27 | OutP($3C9, i div 8); // Green 28 | OutP($3C9, i div 4); // Blue 29 | end; 30 | end; 31 | 32 | 33 | var 34 | x, y, i: Integer; 35 | Color: ShortInt; 36 | VideoBuf: PVideoBuf; 37 | 38 | 39 | begin 40 | SetScreenMode($13); // 320 x 200, 256 colors 41 | SetPalette; 42 | 43 | VideoBuf := PVideoBuf(VideoBufOrigin); 44 | 45 | i := 0; 46 | repeat 47 | for x := 0 to Width - 1 do 48 | for y := 0 to Height - 1 do 49 | begin 50 | Color := Round(127.5 * (1 + sin(0.01 * (x + y + i)))) mod 256; 51 | VideoBuf^[y, x] := Color; 52 | end; 53 | Inc(i); 54 | until KeyPressed; 55 | 56 | SetScreenMode($03); 57 | end. -------------------------------------------------------------------------------- /xdp/samples/sort.pas: -------------------------------------------------------------------------------- 1 | // Sorting demo 2 | 3 | 4 | program Sort; 5 | 6 | 7 | 8 | const 9 | DataLength = 60; 10 | 11 | 12 | 13 | type 14 | TNumber = Integer; 15 | 16 | TData = array [1..DataLength] of TNumber; 17 | PData = ^TData; 18 | 19 | 20 | 21 | procedure Swap(var x, y: TNumber); 22 | var 23 | buf: TNumber; 24 | begin 25 | buf := x; 26 | x := y; 27 | y := buf; 28 | end; 29 | 30 | 31 | 32 | 33 | function Partition(var data: TData; len: Integer): Integer; 34 | var 35 | pivot: TNumber; 36 | pivotIndex, i: Integer; 37 | begin 38 | pivot := data[len]; 39 | pivotIndex := 1; 40 | 41 | for i := 1 to len do 42 | if data[i] < pivot then 43 | begin 44 | Swap(data[pivotIndex], data[i]); 45 | Inc(pivotIndex); 46 | end; {if} 47 | 48 | Swap(data[len], data[pivotIndex]); 49 | 50 | Result := pivotIndex; 51 | end; 52 | 53 | 54 | 55 | 56 | procedure QuickSort(var data: TData; len: Integer); 57 | var 58 | pivotIndex: Integer; 59 | dataShiftedPtr: PData; 60 | begin 61 | if len > 1 then 62 | begin 63 | pivotIndex := Partition(data, len); 64 | dataShiftedPtr := PData(@data[pivotIndex + 1]); 65 | 66 | QuickSort(data, pivotIndex - 1 ); 67 | QuickSort(dataShiftedPtr^, len - pivotIndex); 68 | end; // if 69 | end; 70 | 71 | 72 | 73 | 74 | procedure BubbleSort(var data: TData; len: Integer); 75 | var 76 | changed: Boolean; 77 | i: Integer; 78 | begin 79 | repeat 80 | changed := FALSE; 81 | 82 | for i := 1 to len - 1 do 83 | if data[i + 1] < data[i] then 84 | begin 85 | Swap(data[i + 1], data[i]); 86 | changed := TRUE; 87 | end; 88 | 89 | until not changed; 90 | end; 91 | 92 | 93 | 94 | procedure SelectionSort(var data: TData; len: Integer); 95 | var 96 | i, j, extrIndex: Integer; 97 | extr: TNumber; 98 | begin 99 | for i := 1 to len do 100 | begin 101 | extr := data[i]; 102 | extrIndex := i; 103 | 104 | for j := i + 1 to len do 105 | if data[j] < extr then 106 | begin 107 | extr := data[j]; 108 | extrIndex := j; 109 | end; 110 | 111 | Swap(data[i], data[extrIndex]); 112 | end; // for 113 | end; 114 | 115 | 116 | 117 | var 118 | RandomData: TData; 119 | i: Integer; 120 | Method: Char; 121 | 122 | 123 | 124 | begin 125 | WriteLn; 126 | WriteLn('Sorting demo'); 127 | WriteLn; 128 | WriteLn('Initial array: '); 129 | WriteLn; 130 | 131 | Randomize; 132 | 133 | for i := 1 to DataLength do 134 | begin 135 | RandomData[i] := Round((Random - 0.5) * 1000000); 136 | Write(RandomData[i]); 137 | if i mod 4 <> 0 then Write(#9) else WriteLn; 138 | end; 139 | 140 | WriteLn; 141 | WriteLn; 142 | Write('Select method (Q - quick, B - bubble, S - selection): '); Read(Method); 143 | WriteLn; 144 | WriteLn; 145 | 146 | case Method of 147 | 'Q', 'q': 148 | begin 149 | WriteLn('Quick sorting'); 150 | QuickSort(RandomData, DataLength); 151 | end; 152 | 'B', 'b': 153 | begin 154 | WriteLn('Bubble sorting'); 155 | BubbleSort(RandomData, DataLength); 156 | end; 157 | 'S', 's': 158 | begin 159 | WriteLn('Selection sorting'); 160 | SelectionSort(RandomData, DataLength); 161 | end 162 | else 163 | WriteLn('Sorting method is not selected.'); 164 | ReadLn; 165 | Halt; 166 | end; 167 | 168 | WriteLn; 169 | WriteLn('Sorted array: '); 170 | WriteLn; 171 | 172 | for i := 1 to DataLength do 173 | begin 174 | Write(RandomData[i]); 175 | if i mod 4 <> 0 then Write(#9) else WriteLn; 176 | end; 177 | WriteLn; 178 | 179 | WriteLn; 180 | WriteLn('Done.'); 181 | 182 | ReadLn; 183 | end. 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | -------------------------------------------------------------------------------- /xdp/system.pas: -------------------------------------------------------------------------------- 1 | // System library 2 | 3 | 4 | 5 | const 6 | pi = 3.1415927; 7 | 8 | SEEKSTART = 0; 9 | SEEKCUR = 1; 10 | SEEKEND = 2; 11 | 12 | 13 | 14 | 15 | type 16 | LongInt = Integer; 17 | 18 | Single = Real; 19 | 20 | PChar = ^Char; 21 | 22 | TStream = record 23 | Data: PChar; 24 | Index: Integer; 25 | end; 26 | 27 | PStream = ^TStream; 28 | 29 | TRegisters = record 30 | AX, BX, CX, DX, DS, Flags: Integer; 31 | end; 32 | 33 | 34 | 35 | var 36 | RandSeed: Integer; 37 | IOError: Integer; 38 | LastReadChar: Char; 39 | 40 | 41 | 42 | 43 | // System timer and keyboard state 44 | 45 | 46 | function Timer: Integer; 47 | var 48 | Reg: TRegisters; 49 | begin 50 | Reg.AX := 0; 51 | Reg.CX := 0; 52 | Reg.DX := 0; 53 | Intr($1A, @Reg); 54 | Result := Reg.CX shl 16 + Reg.DX; 55 | end; 56 | 57 | 58 | 59 | 60 | function KeyPressed: Boolean; 61 | var 62 | Reg: TRegisters; 63 | begin 64 | Reg.AX := $0B00; 65 | Intr($21, @Reg); 66 | Result := (Reg.AX and $FF) <> 0; 67 | end; 68 | 69 | 70 | 71 | 72 | // Mathematical routines 73 | 74 | 75 | 76 | procedure Randomize; 77 | begin 78 | RandSeed := Timer; 79 | end; 80 | 81 | 82 | 83 | 84 | function Random: Real; 85 | begin 86 | RandSeed := 1975433173 * RandSeed; 87 | Result := 0.5 * (RandSeed / $7FFFFFFF + 1.0); 88 | end; 89 | 90 | 91 | 92 | 93 | function Min(x, y: Real): Real; 94 | begin 95 | if x < y then Result := x else Result := y; 96 | end; 97 | 98 | 99 | 100 | 101 | function IMin(x, y: Integer): Integer; 102 | begin 103 | if x < y then Result := x else Result := y; 104 | end; 105 | 106 | 107 | 108 | 109 | 110 | function Max(x, y: Real): Real; 111 | begin 112 | if x > y then Result := x else Result := y; 113 | end; 114 | 115 | 116 | 117 | 118 | function IMax(x, y: Integer): Integer; 119 | begin 120 | if x > y then Result := x else Result := y; 121 | end; 122 | 123 | 124 | 125 | 126 | 127 | // File and console I/O routines 128 | 129 | 130 | 131 | procedure ReadConsole(var Ch: Char); 132 | var 133 | Reg: TRegisters; 134 | begin 135 | Reg.AX := $0100; 136 | Intr($21, @Reg); 137 | Ch := Char(Reg.AX and $FF); 138 | end; 139 | 140 | 141 | 142 | 143 | procedure WriteConsole(Ch: Char); 144 | var 145 | Reg: TRegisters; 146 | begin 147 | Reg.AX := $0200; 148 | Reg.DX := Integer(Ch); 149 | Intr($21, @Reg); 150 | end; 151 | 152 | 153 | 154 | 155 | procedure Rewrite(var F: Text; const Name: string); 156 | var 157 | Reg: TRegisters; 158 | begin 159 | Reg.AX := $3C00; 160 | Reg.CX := $0000; 161 | Reg.DX := Integer(@Name) and $FFFF; 162 | Reg.DS := Integer(@Name) shr 16; 163 | Intr($21, @Reg); 164 | F := Text(Reg.AX); 165 | if Reg.Flags and 1 = 1 then IOError := Reg.AX else IOError := 0; // Error code 166 | end; 167 | 168 | 169 | 170 | 171 | procedure Reset(var F: Text; const Name: string); 172 | var 173 | Reg: TRegisters; 174 | begin 175 | Reg.AX := $3D02; 176 | Reg.DX := Integer(@Name) and $FFFF; 177 | Reg.DS := Integer(@Name) shr 16; 178 | Intr($21, @Reg); 179 | F := Text(Reg.AX); 180 | if Reg.Flags and 1 = 1 then IOError := Reg.AX else IOError := 0; // Error code 181 | end; 182 | 183 | 184 | 185 | 186 | procedure Close(F: Text); 187 | var 188 | Reg: TRegisters; 189 | begin 190 | Reg.AX := $3E00; 191 | Reg.BX := Integer(F); 192 | Intr($21, @Reg); 193 | end; 194 | 195 | 196 | 197 | 198 | procedure BlockRead(F: Text; Buf: PChar; Len: SmallInt; var LenRead: SmallInt); 199 | var 200 | Reg: TRegisters; 201 | begin 202 | Reg.AX := $3F00; 203 | Reg.BX := Integer(F); 204 | Reg.CX := Len; 205 | Reg.DX := Integer(Buf) and $FFFF; 206 | Reg.DS := Integer(Buf) shr 16; 207 | Intr($21, @Reg); 208 | LenRead := Reg.AX; 209 | end; 210 | 211 | 212 | 213 | 214 | procedure BlockWrite(F: Text; Buf: PChar; Len: SmallInt); 215 | var 216 | Reg: TRegisters; 217 | begin 218 | Reg.AX := $4000; 219 | Reg.BX := Integer(F); 220 | Reg.CX := Len; 221 | Reg.DX := Integer(Buf) and $FFFF; 222 | Reg.DS := Integer(Buf) shr 16; 223 | Intr($21, @Reg); 224 | end; 225 | 226 | 227 | 228 | 229 | procedure DeleteFile(const Name: string); 230 | var 231 | Reg: TRegisters; 232 | begin 233 | Reg.AX := $4100; 234 | Reg.DX := Integer(@Name) and $FFFF; 235 | Reg.DS := Integer(@Name) shr 16; 236 | Intr($21, @Reg); 237 | end; 238 | 239 | 240 | 241 | 242 | function SeekFile(F: Text; Pos: Integer; Mode: ShortInt): Integer; 243 | var 244 | Reg: TRegisters; 245 | begin 246 | Reg.AX := $4200 + Mode; 247 | Reg.BX := Integer(F); 248 | Reg.CX := Pos shr 16; 249 | Reg.DX := Pos and $FFFF; 250 | Intr($21, @Reg); 251 | Result := Reg.DX shl 16 + Reg.AX; 252 | if Reg.Flags and 1 = 1 then IOError := Reg.AX else IOError := 0; // Error code 253 | end; 254 | 255 | 256 | 257 | 258 | 259 | procedure Seek(F: Text; Pos: Integer); 260 | var 261 | NewPos: Integer; 262 | begin 263 | NewPos := SeekFile(F, Pos, SEEKSTART); 264 | if NewPos <> Pos then IOError := 1 else IOError := 0; 265 | end; 266 | 267 | 268 | 269 | 270 | 271 | function FilePos(F: Text): Integer; 272 | begin 273 | Result := SeekFile(F, 0, SEEKCUR); 274 | end; 275 | 276 | 277 | 278 | 279 | 280 | function EOF(F: Text): Boolean; 281 | var 282 | OldPos: Integer; 283 | begin 284 | if Integer(F) = 0 then 285 | Result := FALSE 286 | else 287 | begin 288 | OldPos := SeekFile(F, 0, SEEKCUR); 289 | Result := SeekFile(F, 0, SEEKEND) = OldPos; 290 | OldPos := SeekFile(F, OldPos, SEEKSTART); 291 | end; 292 | end; 293 | 294 | 295 | 296 | 297 | 298 | function IOResult: Integer; 299 | begin 300 | Result := IOError; 301 | IOError := 0; 302 | end; 303 | 304 | 305 | 306 | 307 | 308 | procedure WriteCh(F: Text; P: PStream; ch: Char); 309 | var 310 | Dest: PChar; 311 | begin 312 | if P <> nil then // String stream output 313 | begin 314 | Dest := PChar(Integer(P^.Data) + P^.Index); 315 | Dest^ := ch; 316 | Inc(P^.Index); 317 | end 318 | else 319 | if Integer(F) = 0 then // Console output 320 | WriteConsole(ch) 321 | else // File output 322 | BlockWrite(F, @ch, 1); 323 | end; 324 | 325 | 326 | 327 | 328 | procedure WriteInt(F: Text; P: PStream; Number: Integer); 329 | var 330 | Digit, Weight: Integer; 331 | Skip: Boolean; 332 | 333 | begin 334 | if Number = 0 then 335 | WriteCh(F, P, '0') 336 | else 337 | begin 338 | if Number < 0 then 339 | begin 340 | WriteCh(F, P, '-'); 341 | Number := -Number; 342 | end; 343 | 344 | Weight := 1000000000; 345 | Skip := TRUE; 346 | 347 | while Weight >= 1 do 348 | begin 349 | if Number >= Weight then Skip := FALSE; 350 | 351 | if not Skip then 352 | begin 353 | Digit := Number div Weight; 354 | WriteCh(F, P, Char(ShortInt('0') + Digit)); 355 | Number := Number - Weight * Digit; 356 | end; 357 | 358 | Weight := Weight div 10; 359 | end; // while 360 | end; // else 361 | 362 | end; 363 | 364 | 365 | 366 | 367 | 368 | procedure WriteHex(F: Text; P: PStream; Number: Integer; Digits: ShortInt); 369 | var 370 | i, Digit: ShortInt; 371 | begin 372 | for i := Digits - 1 downto 0 do 373 | begin 374 | Digit := (Number shr (i shl 2)) and $0F; 375 | if Digit <= 9 then Digit := ShortInt('0') + Digit else Digit := ShortInt('A') + Digit - 10; 376 | WriteCh(F, P, Char(Digit)); 377 | end; 378 | end; 379 | 380 | 381 | 382 | 383 | 384 | procedure WritePointer(F: Text; P: PStream; Number: Integer); 385 | begin 386 | WriteHex(F, P, Number, 8); 387 | end; 388 | 389 | 390 | 391 | 392 | 393 | procedure WriteReal(F: Text; P: PStream; Number: Real); 394 | const 395 | FracBits = 16; 396 | var 397 | Integ, Frac, InvWeight, Digit, IntegExpon: Integer; 398 | Expon: Real; 399 | 400 | begin 401 | // Write sign 402 | if Number < 0 then 403 | begin 404 | WriteCh(F, P, '-'); 405 | Number := -Number; 406 | end; 407 | 408 | // Normalize number 409 | if Number = 0 then Expon := 0 else Expon := ln(Number) / ln(10); 410 | if (Expon > 8) or (Expon < -3) then 411 | begin 412 | IntegExpon := Trunc(Expon); 413 | if IntegExpon < 0 then Dec(IntegExpon); 414 | Number := Number / exp(IntegExpon * ln(10)); 415 | end 416 | else 417 | IntegExpon := 0; 418 | 419 | // Write integer part 420 | Integ := Trunc(Number); 421 | Frac := Round((Number - Integ) * (1 shl FracBits)); 422 | 423 | WriteInt(F, P, Integ); WriteCh(F, P, '.'); 424 | 425 | // Write fractional part 426 | InvWeight := 10; 427 | 428 | while InvWeight <= 10000 do 429 | begin 430 | Digit := (Frac * InvWeight) shr FracBits; 431 | if Digit > 9 then Digit := 9; 432 | WriteCh(F, P, Char(ShortInt('0') + Digit)); 433 | Frac := Frac - (Digit shl FracBits) div InvWeight; 434 | InvWeight := InvWeight * 10; 435 | end; // while 436 | 437 | // Write exponent 438 | if IntegExpon <> 0 then 439 | begin 440 | WriteCh(F, P, 'e'); WriteInt(F, P, IntegExpon); 441 | end; 442 | 443 | end; 444 | 445 | 446 | 447 | 448 | procedure WriteString(F: Text; P: PStream; const s: string); 449 | var 450 | i: Integer; 451 | begin 452 | i := 0; 453 | while s[i] <> #0 do 454 | begin 455 | WriteCh(F, P, s[i]); 456 | Inc(i); 457 | end; 458 | end; 459 | 460 | 461 | 462 | 463 | procedure WriteBoolean(F: Text; P: PStream; Flag: Boolean); 464 | begin 465 | if Flag then WriteString(F, P, 'TRUE') else WriteString(F, P, 'FALSE'); 466 | end; 467 | 468 | 469 | 470 | 471 | procedure WriteNewLine(F: Text; P: PStream); 472 | begin 473 | WriteCh(F, P, #13); WriteCh(F, P, #10); 474 | end; 475 | 476 | 477 | 478 | 479 | procedure ReadCh(F: Text; P: PStream; var ch: Char); 480 | var 481 | Len: SmallInt; 482 | Dest: PChar; 483 | begin 484 | if P <> nil then // String stream input 485 | begin 486 | Dest := PChar(Integer(P^.Data) + P^.Index); 487 | ch := Dest^; 488 | Inc(P^.Index); 489 | end 490 | else 491 | if Integer(F) = 0 then // Console input 492 | begin 493 | ReadConsole(ch); 494 | if ch = #13 then WriteConsole(#10); 495 | end 496 | else // File input 497 | begin 498 | BlockRead(F, @ch, 1, Len); 499 | if ch = #10 then BlockRead(F, @ch, 1, Len); 500 | if Len <> 1 then ch := #0; 501 | end; 502 | LastReadChar := ch; // Required by ReadNewLine 503 | end; 504 | 505 | 506 | 507 | 508 | procedure ReadInt(F: Text; P: PStream; var Number: Integer); 509 | var 510 | Ch: Char; 511 | Negative: Boolean; 512 | 513 | begin 514 | Number := 0; 515 | 516 | // Read sign 517 | Negative := FALSE; 518 | ReadCh(F, P, Ch); 519 | if Ch = '+' then 520 | ReadCh(F, P, Ch) 521 | else if Ch = '-' then 522 | begin 523 | Negative := TRUE; 524 | ReadCh(F, P, Ch); 525 | end; 526 | 527 | // Read number 528 | while (Ch >= '0') and (Ch <= '9') do 529 | begin 530 | Number := Number * 10 + ShortInt(Ch) - ShortInt('0'); 531 | ReadCh(F, P, Ch); 532 | end; 533 | 534 | if Negative then Number := -Number; 535 | end; 536 | 537 | 538 | 539 | 540 | procedure ReadReal(F: Text; P: PStream; var Number: Real); 541 | var 542 | Ch: Char; 543 | Negative, ExponNegative: Boolean; 544 | Weight: Real; 545 | Expon: Integer; 546 | 547 | begin 548 | Number := 0; 549 | Expon := 0; 550 | 551 | // Read sign 552 | Negative := FALSE; 553 | ReadCh(F, P, Ch); 554 | if Ch = '+' then 555 | ReadCh(F, P, Ch) 556 | else if Ch = '-' then 557 | begin 558 | Negative := TRUE; 559 | ReadCh(F, P, Ch); 560 | end; 561 | 562 | // Read integer part 563 | while (Ch >= '0') and (Ch <= '9') do 564 | begin 565 | Number := Number * 10 + ShortInt(Ch) - ShortInt('0'); 566 | ReadCh(F, P, Ch); 567 | end; 568 | 569 | if Ch = '.' then // Fractional part found 570 | begin 571 | ReadCh(F, P, Ch); 572 | 573 | // Read fractional part 574 | Weight := 0.1; 575 | while (Ch >= '0') and (Ch <= '9') do 576 | begin 577 | Number := Number + Weight * (ShortInt(Ch) - ShortInt('0')); 578 | Weight := Weight / 10; 579 | ReadCh(F, P, Ch); 580 | end; 581 | end; 582 | 583 | if (Ch = 'E') or (Ch = 'e') then // Exponent found 584 | begin 585 | // Read exponent sign 586 | ExponNegative := FALSE; 587 | ReadCh(F, P, Ch); 588 | if Ch = '+' then 589 | ReadCh(F, P, Ch) 590 | else if Ch = '-' then 591 | begin 592 | ExponNegative := TRUE; 593 | ReadCh(F, P, Ch); 594 | end; 595 | 596 | // Read exponent 597 | while (Ch >= '0') and (Ch <= '9') do 598 | begin 599 | Expon := Expon * 10 + ShortInt(Ch) - ShortInt('0'); 600 | ReadCh(F, P, Ch); 601 | end; 602 | 603 | if ExponNegative then Expon := -Expon; 604 | end; 605 | 606 | if Expon <> 0 then Number := Number * exp(Expon * ln(10)); 607 | if Negative then Number := -Number; 608 | end; 609 | 610 | 611 | 612 | 613 | procedure ReadString(F: Text; P: PStream; const s: string); 614 | var 615 | i: Integer; 616 | Ch: Char; 617 | begin 618 | i := 0; 619 | ReadCh(F, P, Ch); 620 | 621 | while Ch <> #13 do 622 | begin 623 | s[i] := Ch; 624 | Inc(i); 625 | ReadCh(F, P, Ch); 626 | end; 627 | 628 | s[i] := #0; 629 | end; 630 | 631 | 632 | 633 | 634 | procedure ReadNewLine(F: Text; P: PStream); 635 | var 636 | Ch: Char; 637 | begin 638 | Ch := LastReadChar; 639 | while not EOF(F) and (Ch <> #13) do ReadCh(F, P, Ch); 640 | LastReadChar := #0; 641 | end; 642 | 643 | 644 | 645 | 646 | // String manipulation routines 647 | 648 | 649 | function StrLen(const s: string): SmallInt; 650 | begin 651 | Result := 0; 652 | while s[Result] <> #0 do Inc(Result); 653 | end; 654 | 655 | 656 | 657 | 658 | 659 | procedure StrCopy(var Dest: string; const Source: string); 660 | var 661 | i: Integer; 662 | begin 663 | i := -1; 664 | repeat 665 | Inc(i); 666 | Dest[i] := Source[i]; 667 | until Source[i] = #0; 668 | end; 669 | 670 | 671 | 672 | 673 | 674 | procedure StrCat(var Dest: string; const Source: string); 675 | var 676 | i, j: Integer; 677 | begin 678 | i := 0; 679 | while Dest[i] <> #0 do Inc(i); 680 | j := -1; 681 | repeat 682 | Inc(j); 683 | Dest[i + j] := Source[j]; 684 | until Source[j] = #0; 685 | end; 686 | 687 | 688 | 689 | 690 | 691 | function StrComp(const s1, s2: string): Integer; 692 | var 693 | i: Integer; 694 | begin 695 | Result := 0; 696 | i := -1; 697 | repeat 698 | Inc(i); 699 | Result := Integer(s1[i]) - Integer(s2[i]); 700 | until (s1[i] = #0) or (s2[i] = #0) or (Result <> 0); 701 | end; 702 | 703 | 704 | 705 | 706 | 707 | procedure Val(const s: string; var Number: Real; var Code: Integer); 708 | var 709 | Stream: TStream; 710 | begin 711 | Stream.Data := @s; 712 | Stream.Index := 0; 713 | 714 | ReadReal(Text(0), @Stream, Number); 715 | 716 | if Stream.Index - 1 <> StrLen(s) then Code := Stream.Index - 1 else Code := 0; 717 | end; 718 | 719 | 720 | 721 | 722 | 723 | procedure Str(Number: Real; var s: string); 724 | var 725 | Stream: TStream; 726 | begin 727 | Stream.Data := @s; 728 | Stream.Index := 0; 729 | 730 | WriteReal(Text(0), @Stream, Number); 731 | s[Stream.Index] := #0; 732 | end; 733 | 734 | 735 | 736 | 737 | 738 | procedure IVal(const s: string; var Number: Integer; var Code: Integer); 739 | var 740 | Stream: TStream; 741 | begin 742 | Stream.Data := @s; 743 | Stream.Index := 0; 744 | 745 | ReadInt(Text(0), @Stream, Number); 746 | 747 | if Stream.Index - 1 <> StrLen(s) then Code := Stream.Index - 1 else Code := 0; 748 | end; 749 | 750 | 751 | 752 | 753 | 754 | procedure IStr(Number: Integer; var s: string); 755 | var 756 | Stream: TStream; 757 | begin 758 | Stream.Data := @s; 759 | Stream.Index := 0; 760 | 761 | WriteInt(Text(0), @Stream, Number); 762 | s[Stream.Index] := #0; 763 | end; 764 | 765 | 766 | 767 | 768 | // Graphics routines 769 | 770 | 771 | procedure SetScreenMode(mode: Integer); 772 | var 773 | Reg: TRegisters; 774 | begin 775 | Reg.AX := $00 shl 8 + mode; 776 | Intr($10, @Reg); 777 | end; 778 | 779 | 780 | 781 | procedure PutPixel(x, y, clr: Integer); 782 | var 783 | Reg: TRegisters; 784 | begin 785 | Reg.AX := $0C shl 8 + clr; 786 | Reg.BX := 0; 787 | Reg.CX := x; 788 | Reg.DX := y; 789 | Intr($10, @Reg); 790 | end; 791 | 792 | 793 | 794 | procedure Line(x1, y1, x2, y2, clr: Integer); 795 | var 796 | x, y, xMax, xMin, yMax, yMin: Integer; 797 | begin 798 | if x1 > x2 then 799 | begin 800 | xMax := x1; xMin := x2; 801 | end 802 | else 803 | begin 804 | xMax := x2; xMin := x1; 805 | end; 806 | 807 | if y1 > y2 then 808 | begin 809 | yMax := y1; yMin := y2; 810 | end 811 | else 812 | begin 813 | yMax := y2; yMin := y1; 814 | end; 815 | 816 | if x1 = x2 then 817 | for y := yMin to yMax do 818 | PutPixel(x1, y, clr) 819 | else if y1 = y2 then 820 | for x := xMin to xMax do 821 | PutPixel(x, y1, clr) 822 | else if abs(yMax - yMin) < abs(xMax - xMin) then 823 | for x := xMin to xMax do 824 | begin 825 | y := y1 + (y2 - y1) * (x - x1) div (x2 - x1); 826 | PutPixel(x, y, clr); 827 | end 828 | else 829 | for y := yMin to yMax do 830 | begin 831 | x := x1 + (x2 - x1) * (y - y1) div (y2 - y1); 832 | PutPixel(x, y, clr); 833 | end 834 | 835 | end; 836 | 837 | 838 | 839 | 840 | procedure Circle(x, y, r, clr: Integer); 841 | var 842 | t, dt: Real; 843 | dx, dy: Integer; 844 | begin 845 | t := 0; dt := 0.5 / r; 846 | 847 | while t < Pi / 2 do 848 | begin 849 | dx := Round(r * cos(t)); 850 | dy := Round(r * sin(t)); 851 | 852 | PutPixel(x + dx, y + dy, clr); 853 | PutPixel(x - dx, y + dy, clr); 854 | PutPixel(x - dx, y - dy, clr); 855 | PutPixel(x + dx, y - dy, clr); 856 | 857 | t := t + dt; 858 | end; 859 | 860 | end; 861 | 862 | 863 | 864 | 865 | procedure OutCharXY(x, y, clr: Integer; ch: Char); 866 | const 867 | CharSetOrigin = $F000 shl 16 + $FA6E; 868 | 869 | type 870 | TCharBitmap = array [0..7] of ShortInt; 871 | PCharBitmap = ^TCharBitmap; 872 | 873 | var 874 | CharBitmap: PCharBitmap; 875 | i, j: Integer; 876 | 877 | begin 878 | CharBitmap := PCharBitmap(CharSetOrigin + Integer(ch) shl 3); 879 | 880 | for i := 0 to 7 do 881 | for j := 0 to 7 do 882 | if (CharBitmap^[i] and (1 shl j)) <> 0 then PutPixel(x + 7 - j, y + i, clr); 883 | end; 884 | 885 | 886 | 887 | 888 | procedure OutTextXY(x, y, clr: Integer; const s: string); 889 | var 890 | i: Integer; 891 | begin 892 | i := 0; 893 | while s[i] <> #0 do 894 | begin 895 | OutCharXY(x, y, clr, s[i]); 896 | x := x + 8; 897 | Inc(i); 898 | end; 899 | end; 900 | 901 | 902 | 903 | -------------------------------------------------------------------------------- /xdp/xdp.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nickelsworth/pascal/7a376f389fcad25c41a35825deddad82e97d52c6/xdp/xdp.exe --------------------------------------------------------------------------------