BYTE Listings Jan Jun 1986

Byte

This book was produced in EPUB format by the Internet Archive.

The book pages were scanned and converted to EPUB format automatically. This process relies on optical character recognition, and is somewhat susceptible to errors. The book may not offer the correct reading sequence, and there may be weird characters, non-words, and incorrect guesses at structure. Some page numbers and headers or footers may remain from the scanned page. The process which identifies images might have found stray marks on the page which are not actually images from the book. The hidden page numbering which may be available to your ereader corresponds to the numbered pages in the print edition, but is not an exact match; page numbers will increment at the same rate as the corresponding print edition, but we may have started numbering before the print book's visible page numbers. The Internet Archive is working to improve the scanning process and resulting books, but in the meantime, we hope that this book will be useful to you.

The Internet Archive was founded in 1996 to build an Internet library and to promote universal access to all knowledge. The Archive's purposes include offering permanent access for researchers, historians, scholars, people with disabilities, and the general public to historical collections that exist in digital format. The Internet Archive includes texts, audio, moving images, and software as well as archived web pages, and provides specialized services for information access for the blind and other persons with disabilities.

Created with abbyy2epub (v.1.7.2)

TABLE OF CONTENTS

January.3

February.73

March .201

April.217

May.317

June.343

INDEX

J anuary

AIREAD

ME. . .

. .3

APPLGRF

BAS..

..5

CYCLFRAC

BAS. .

..8

EDITSORT

MD2..

.13

FRAMES

PRO..

..9

GOD

BAS..

..7

LCM

BAS. .

..7

LISTING

TXT. .

.12

LISTING2

PRO. .

..3

LISTING3

PRO..

..5

MACGRAF

BAS..

.12

PCGRAP

BAS. .

.17

PROLOG

DOC. .

.63

QUIKSORT

MD2. .

.18

READSIM2

ME. . .

.16

SIMPL2

TXT. .

.19

February

ANALYZER

ONE. .

. .76

ANALYZER

TWO. .

. .77

B10H14

DAT. .

.133

B5H9

DAT. .

.133

BADFILE

C. . . .

BENZENE

DAT. .

.135

BTRANS

PAS. .

..73

C7H702N

DAT. .

.134

CALC

PAS. .

..73

CLOCKNET

..

. .94

CLOCKPLT

. .94

C0L0R3D

BAS.’.’

.131

CRC6H6

DAT. .

.134

CRDIBENZ

DAT. .

.135

DATAGEN

BAS. .

.136

DVORAK

TXT. .

.136

DVORAK

BAS. .

.115

FARRELL

LBR. .

.130

FARRELL

LIB. .

.131

FIB

. .123

FLOAT

PAS.

...74

FOO

NET.

.. .94

FOO

PLT.

...95

GOBBLER

ONE.

...78

GOBBLER

TWO.

...79

GRINDEF

..123

LEVIEN

lbr!

..122

LINETEST

PAS.

...73

LIST1

TXT.

..114

LIST2

TXT.

. .114

LIST3

TXT.

. .114

LIST4

TXT.

..115

LIST5

TXT.

. .115

NACL

DAT.

. .135

NATLANG

LBR.

...93

PARSE

PLT.

.. .96

PARSE

NET.

. . .95

PATTERNS

DAT.

..133

PUZZLE

PAS.

..118

QSORT

PAS.

.. .74

README

VSD.

. .122

README3D

DOC.

. .137

READNAT

ME. .

. . .93

READSIM3

ME. . ,

. . .92

SA

LSP.,

...96

SA12

LSP. .

..102

SCANPOEM

DOC. .

. . .82

SCANPOEM

PAS..

, . .85

SIEVE

PAS. .

..74

SMALLVSD

.123

ST

DOC. .

.110

STRAMDSK

C. . . .

. 107

TANKARD

LBR. .

. .76

TEXTBOX

DOC. .

. .82

TRANS

PAS..

..73

XLISPVSD

,,

.127

March

DIOPHANT BAS...214 EXPLORER TXT...208 LISTING1 386...205 LISTING2 386...206 LISTING3 386...205 MFILECPV MOD...204

MSCREEN

MOD.

. .201

MSIEVE

MOD.

. .201

MTIMEF

MOD.

. .202

MTIMEI

MOD.

. .203

April

ATSPGM

FOR.

. .252

CHBEVL

C. . .

CHEBY

C...

DRAGON

DOC.

..313

EPSILON

FOR.

..234

EXAMPLES

DOC.

..235

LISTING4

PAS.

. .247

MANUAL

DOC.

..255

MATINV

BAS.

..314

ONEBODY

BAS.

..239

ORBIT

FOR.

..229

PAINLEVE

FOR.

..237

PREDICT

FOR.

..225

REACT

FOR.

. .230

REMES

C. . .

RKCONST

FOR.

..231

RUNKUT

DOC.

..217

RUNKUT

FOR.

. .227

SIMQ

C. . .

. .245

THERM

FOR.

. .235

May

HUFREAD

ME...

.334

MAINPROG

BAS..

.317

OPTICDB

C. . . .

.335

PELL

BAS..

.340

ROUTINE

SUB..

.341

June

FRACTAL

LIB.

. .349

HILBERT

BAS.

. .348

INDEXBPP

LST.

..343

INDEXBPP

PAS.

. .364

LIST1

TXT.

. .362

LIST2

TXT.

. .364

MACVIEW

PAS.

..395

MIDI

ARC.

..352

MIDI 111

C. . .

. .372

RXINT11

A. . .

. .390

BYTE LISTINGS SUPPLEMENT 1

BYTE

MANACINC EDITOR. BYTE

Frederic S. Langa

ASSISTANT MANAGING EDITOR

Glenn Hartwig

CONSULTING EDITORS

Steve Ciarcia Jerry Pournelle Ezra Shapiro Bruce Webster

SENIOR TECHNICAL EDITORS

Jon R. Edwards. R^viws G. Michael Vose. T hemes Gregg Williams. Features

TECHNICAL EDITORS

Dennis Allen Richard Grehan Ken Sheldon George A. Stewart Jane Morrill Tazelaar

TOM THOMPSON

Charles D. Weston Eva White Stanley Wszola associate technical editors Curtis Franklin. Jr B*st of BIX Margaret Cook Gurney book R eviews Brenda McLaughlin. Applications Software Reviews. San Francisco

COPY EDITORS

Bud Sadler. Chief Jeff Edmonds Faith Hanson Nancy Hayes Cathy Kingery Paula Noonan Warren Williamson Judy Winkler

SENIOR VICE PRESIDENTfPUBLISHER

Harry L. Brown EDITOR IN CHIEF

Philip Lemmons

NEWS AND TECHNOLOGY

Gene Smarte. Bureau Chief. Costa Mesa Jonathan Erickson. Senior Technical Editor. San Francisco Rich Malloy. Senior Technical Editor. New York Cindy Kiddoo. Editorial Assistant. San Francisco

ASSOCIATE NEWS EDITORS

Dennis Barker. Microbytes Cathryn Baskin. W hat s New Anne Fischer Lent. W hat's New

CONTRIBUTING EDITORS

Jonathan Amsterdam, programming projects Mark Dahmke. video, operating systems Mark Haas, at large Rik Jadrnicek. CAD. graphics, spreadsheets Robert T Kurosaka. mathematical recreations Phil Lopiccolo. computers in medicine Alastair J. W. Mayer, software Alan R. Miller, languages and engineering Dick Fountain. UK.

Roger Powell, computers and music William M. Raike. japan Phillip Robinson, semiconductors

ART

Nancy Rice. Art Director

Joseph A. Gallagher. Associate Art Director

Jan Muller. Art Assistant

Alan Easton. Drafting

PRODUCTION

David R Anderson. Production Director

Denise Chartrand

Michael J. Lonsky

Virginia Reardon

Dana Rice

EXECUTIVE EDITOR. BIX

George Bond

SENIOR EDITOR David Betz ASSOCIATE EDITORS

TOny Lockwood

Donna Osgood. Saw Francisco

BIX GROUP MODERATORS

David P. Allen. Applications Programs Frank Boosman. Artificial Intelligence Leroy Casterline. Other

Marc F. Greenfield Programming Languages and Tools

Jim Howard. Graphics

Gary Kendall. Operating Systems

Steve Krenek. Personal Computers

Brock Meeks. Telecommunications

Barry Nance. New Technology

Donald Osgood. Personal Computers

Sue Rosenberg. Other

Ion Swanson. Chips

BUSINESS AND MARKETING

Doug Webster. Director. (603) 924-9027 Patricia Bausum. Secretary Brian Warnock. Customer Service Denise A. Greene. Customer Service Tammy Burgess. Customer Credit and Billing

TECHNOLOGY

Clayton Lisle. Director. Business Systems Technology. MHIS Bill Garrison. Business Systems Analyst Jack Reilly. Business Systems Analyst Linda Wolff. Senior Business Systems Analyst

TYPOGRAPHY

ASSISTANTS Sherry McCarthy Chief typographer

Peggy Dunham. Office Manager len Lorette

Martha Hicks Donna Sweeney

L. Ryan McCombs

Chad Mitchell

Iune N. Sheldon

Officers of McGraw-Hill Information Systems Company President Richard B Miller WiK Executive Vice Presidents Frederick P lannoo. Construction Information Group Russell ■ ■nil C White. Computers and Communications Information Group i Thomas Ryan Marketing and International. Senior Vice Presidents: Francis A Shinal Controller Robert C Violette. Manufacturing and ■technology. Senior Vice Presidents and Publishers Laurence Altman Electronics Vteek Harry L. Brown. BYTE: David J. McGrath. Construction Publications Group Vice President Peter B. McCuen. Communications Information. Vice President Fred O lensen. Planning and Development.

Officers of McGraw-Hill. Inc: Harold W. McGraw. Jr.. Chairman: loseph L Dionne President and Chief Executive Officer: Robert N. Landes Executive Vice President and Secretary-: Walter D. Serwatka Executive Vice President and Chief Financial Officer: Shel F Asen. Senior Vice President. Manufacturing: Robert I Bahash. Senior Vice President Finance and Manufacturing: Ralph R Schulz. Senior Vice President Editorial: George R Elsinger. Vice President Circulation Ralph I Webb. Vice President and Treasurer

BYTE and The Small Systems Journal are registered trademarks of McGraw-Hill Inc

EDITORIAL AND BUSINESS OFFICE: One Phoenix Mill Lane Peterborough New Hampshire 03458 (603) 924-9281

West Coast Offices: 425 Battery St. San Francisco. CA 94111 (415) 954-9718 3001 Red Hill Ave Building #1. Suite 222 Costa Mesa CA 92626 (714) 557-6292 New York Editorial Office: 1221 Avenue of the Americas New Ybrk. NY 10020 (212) 512-2000

BYTEnet: \617) 861-9764 (set modem at 8-l-N or 7-2-E: 300 or 1200 baud)

BYTE (ISSN 0360-52801 is published monthly with one extra issue per year by McGraw-Hill Inc Founder lames H McGraw |l860-!948i Executive, editorial, circulation and advertising offices 70 Main St Peterborough. NH 03458 phone 1603) 924-9281 Office hours Mon-7hur 8 30 AM - 4 30 PM Friday 8 30 AM - 1 00 PM. Eastern Time Address subscriptions to BYTE Subscriptions POB 590 Martinsville NI 08836 Postmaster send address changes USPS Form 3579 undeliverable copies and fulfillment questions to BYTE Subscriptions POB 596 Martinsville NI 08836 Second-class postage paid at Peterborough NH 03458 and additional mailing offices Postage paid at Winnipeg Manitoba Registration number 9321 Subscriptions are S21 for one year S38 for two years and S55 for three years in the USA and its possessions In Canada and Mexico. S23 for one year S42 for two years S61 for three years $69 for one year air delivery to Europe 31.000 yen for one year air delivery to lapan 15 600 yen for one year surface delivery to lapan S37 surface delivery elsewhere Air delivery to selected areas at additional rates upon request Single copy price is S3 50 in the USA and its possessions $4 25 ;n Canada and Mexico $4 50 in Europe and $5 elsewhere Foreign subscriptions and sales should be remitted in United States funds drawn on a U S bank Please allow six to eight weeks for delivery of first issue Printed In the United States of America

Address all editorial correspondence to the Editor BYTE POB 372 Hancock. NH 03449 Unacceptable manuscripts will be returned if accompanied by sufficient first-class postage Not responsible for lost manuscripts or photos Opinions expressed by the authors are not necessarily those of BYTE

Copyright © 1986 by McGraw-Hill Inc All nghts reserved Trademark registered in the United States Patent and TYacemark Office Where necessary permission is granted by the copyright owner for libraries and ethers registered with the Copynght Clearance Center iCCC) to photocopy any article herein for the flat fee of SI 50 per copy of the article or any part thereof Correspondence and payment should be sent directly to the CCC 29 Congress St Salem MA 01970 Specify ISSN 0360-528083 $1 50 Copying done for other than personal or internal reference use without the permisfcor of McGraw-Hill Inc is prohibited Requests fer speoal permission or bulk order s shou ld be addressed to the publisher BYTE is available in microform from University Microfilms Internationa 300 North Zeeb Rd Dept PR Ann Arbor Ml 48106 or 18 Bedford Row. Dept PR London WCIR 4EI England

Subscription questions or problems should be addressed to: BYTE Subscriber Service POB 328 Hancock. NH 03449

2 BYTE LISTINGS SUPPLEMENT

January

airead.me

TEXT

"AI in Computer Vision" John L. Cuadrado and Clara Y. Cuadrado.

K,^ ar «’ page 237 * A,so down,oad frames.pro I ist ing2.pro, and iisting3.pro o2I E: . Run ? under Pdprolog.exe which can be found in the FromBYTE85 file area. PDProlog is an MS-DOS or PC-DOS program only.

The prolog •jsfmg FRAMES.PRO will compile and run under PDPROLOG. The major limitation of PDPROLOG in this context is that it does not support floating-point arithmetic. We have truncated the value of pi in the cylinder cross-sectional area routine to 3. An alternative approach would be to use, e.g., 314 and mentally divide each area and volume by 100 to obtain an answer to two decimal points. In any case, when you enter values from the keyboard for, e.g., the Radius, you must use integer values if you are running PDPROLOG. y

To invoke the program, boot PDPROLOG and type: consuIt(•frames').

After the program has compiled, type: frame_put(cylinderl,radius,2). frame_put(cylinder1,height,10). etc.

In order to see the affect of entering a value for the radius or heiaht you may either type: y #

Iisting(cylinderl).

(Don * t forget the period at the end of commands).

Or, you may use the frame_get predicate: frame_get(cylinderl,X,Y).

X end Y must be capital letters. Initial cops indicate variable names in Pro Iog.

To change values for cylinderl, you may use either frame_removefcyIinderl,radius). [or

frame_remove(cylinder1,name-of-sIot-to-be-deIeted).] followed by frame.put(ENTER NEW VALUE AS EXPLAINED FOR FRAME.PUT ABOVE), or frame_replace(cylinderl.radius,4). or whatever value you want changed This form allows the new value to be entered in one step, but is otherwise equivalent to frame — remove folloed by frame_put.

To end a pdprolog session and return to the operating system enter exitsys." (without the quotes, of course).

I eve I,

EXECUTED AN ° LISTING3,PR0 ARE N0T STAND-ALONE PROGRAMS. THEY CANNOT BE

The current version of pdprolog, pdprolog 1.8 is included on this disk. PuI I documentation and other sample prolog programs are available for downloading from BYTEnet Listings (617)861-9764 or from BIX.

PDPROLOG.EXE IS A PC-DOS OR MS-DOS PROGRAM ONLY.

list!ng2.pro TEXT

"AI in Computer Vision." See airead.me.

window_type1

ako

value : window

panes

value : 12

style

value : sash

window_type2

ako

value : window

panes

( continued )

BYTE LISTINGS SUPPLEMENT 3

J anuarj

value

style

VOlLt

wirdow_ty?«3

cko

va I ue

panes

va I ue

style

value

window_type4

ako

va I ue

panes

va I ue

sty I e

va I ue

window_type5

ako

va I ue

panes

va I ue

style

va I ue

24

sash

window

3

picture

window

3

sash

window

2

sash

window

ako

value : thing

area

If_needed : w!ndow_area

window_area(Window,Area)

fget(Window,height,Height), fget(Window.width.Width), Area is Height * Width, frep I ace(Window,area,Area).

door_type1

ako

value : door pane Is

value : 4 symmetry

value : yes doorway

value : [coIumns,fan_light]

door_type2

ako

value : door pane Is

value : 6 symmetry

value : yes doorway

value : [columns, portico, s i de__windows]

door_type3

ako

value : door pane Is

value : 0 symmetry

value : no doorway

value : []

door

ako

value : thing

area

if_needed : door_area

door_area(Door,Area)

fget(Door,he Ight,Height), fget(Window,width,Width), Area Is Height * Width, frep I ace(Door,area,Area).

siding.typel ako

value : siding mater I a I

value : clapboard

width

value : narrow cornerboard

value : yes

siding_type2 ako

value : siding materia I

value : aluminum

width

value : wide cornerboard

value : no

siding

ako

value : thing

house_type1

ako

value : house stories

value : 3 siding

value : sidfng_type1

roof

value : gable windowl

optional : yes xpositlon : 2 yposition : 3 type : window_type2 window2

xposition : 1 yposition : 2 type : window_type2 window3

xposition : 3 yposition : 2 type : wlndow_type2

proto_house

ako

value : house_type1 window4

xposition : 1 yposition : 1 type : window_type2

door

xposition : 3 yposition : 1 type : door_type1

proto_house_mirror_image ako

value : house_type1 window4

xposition : 3 yposition : 1 type : window_type2

door

xposition : 1 yposition : 1 type : door_type1

4 BYTE LISTINGS SUPPLEMENT

1 1st ing3.pro

TEXT

"AI in Computer Vision." See oireod.me.

house17

xposition

ako

value : 1

value : house

yposition

stories

value : 2

value : 3

siding

w17

value : siding_type2

ako

roof

value : window_type4

value : gable

ipo

windowl

value : house17

value : w7

xposition

window2

value : 3

value : w12

yposition

window3

value : 2

value : w17

window4

w23

value : w23

ako

door

value : window_type3

value : door37

i po

value : house17

w7

xposition

ako

value : 3

value : window_type4

yposition

ipo /* is_part_of */

value : 1

value : house17

xpositIon

door37

value : 2

ako

yposition

value : door_type3

value : 3

ipo

value : house17

w12

xposition

ako

value : 1

value : window_type4

yposItion

ipo

value : 1

value : house17

app1graf.bas

TEXT

Programming Insight: "Easy 3-D Graphics," Henning

Mittelbach.

January, page 153. Apple version.

10 REM ***********************

20 REM APPLGRAF

30 REM EASY 3-D GRAPHICS, BY 40 REM HENNING MITTELBACH 50 REM FOR PRIVATE,

60 REM NON-COMMERCIAL USE ONLY 70 REM ***********************

90 DIM H(279)

100 X0 « 110 110 Y0 - 180 120 PHI - .5 130 PSI = .4 140 XL - 0 150 XR - 170 160 YL - 0

170 YR - 100

180 D - 5

190 REM * FUNCTION TO BE PLOTTED *

200 DEF FN Y(X) - SIN (Y / F) * (X - Y) * (X - Y) / 150

210 F ■ 10

240 REM ^ABBREVIATIONS AND CUTTING THE TOP *

250 CF - COS (PHI) :SF - SIN (PHI):CP - COS (PSI):SP - SIN (PSI) 260 H - Y0 - XR * SF - YR * SP - 2

(continued)

BYTE LISTINGS SUPPLEMENT 5

January

270 PRINT "DO YOU DESIRE CROSS-HATCHING? (Y/N):"

275 INPUT OPT$

278 CH - 1

280 IF OPT$ - "Y" OR OPT$ - "y" THEN CH - 2 300 PRINT "DO YOU WISH TO VIEW THE AXES? (Y/N):"

305 INPUT AX$: HGR2 : HCOLOR- 7

310 IF AX$ - "N" OR AX$ - "n" THEN 340

320 HPLOT X0 + XL * CF.Y0 - XL * SF TO X0 + XR * CF.Y0 - XR * SF

330 HPLOT X0 - YL * CP,Y0 - YL * SP TO X0 - YR * CP.Y0 - YR * SP

340 HPLOT 0,0 TO 279,0 TO 279,189 TO 0,189 TO 0,0

400 FOR R - 1 TO CH

420 FOR I - 0 TO 279:H(I) - 189: NEXT I

430 ON R GOSUB 1000,2000 440 NEXT R

500 HCOLOR- 0

510 HPLOT 0,0 TO 279,0 TO 279,189 TO 0,189 TO 0.0

520 REM PRINTER ROUTINE FOR C.ITOH

521 REM 8510 A PRINTER FOLLOWS.

522 REM DELETE "REM" COMMANDS TO USE 530 REM INPUT "PRINTING? (Y/N) ";J$

540 REM IF J$ - "N" THEN 600

560 REM PR#1

580 REM PRINT CHR$ ($14)

590 POKE 1657,96: CALL 49661!

600 REM PR#0

700 END

1000 REM 1010 Y - YL

1020 FOR X - XL TO XR

1030 XB - INT (X0 + X * CF - Y * CP + .5)

1040 Z = FN Y(X): IF Z > H THEN Z - H

1050 YB = INT (Y0 - X * SF - Y * SP - Z + .5)

1060 IF YB < H(XB) THEN H(XB) = YB 1070 NEXT X

1100 FOR X - XL TO XR STEP D

1110 U = X0 + X * CF:V - Y0 - X * SF

1120 FOR Y - YL TO YR

1130 XB - INT (U - Y * CP + .5)

1140 Z - FN Y(X): IF Z > H THEN Z - H 1150 YB - INT (V - Y * SP - Z + .5)

1160 IF YB < H(XB) THEN H(XB) = YB

1200 FOR K » INT (U - YR * CP + .5) TO INT (U - YL * CP + .5)

1210 HPLOT K,H(K) TO K + 1,H(K + 1)

1220 NEXT K 1230 NEXT X 1240 RETURN 2000 REM 2010 X = XL

2020 FOR Y - YL TO YR

2030 XB * INT (X0 + X * CF - Y * CP + .5)

2040 Z = FN Y(X): IF Z > H THEN Z - H

2050 YB - INT (Y0 - X * SF - Y * SP - Z + .5)

2060 IF YB < H(X8) THEN H(XB) - YB 2070 NEXT Y

2100 FOR Y - YL TO YR STEP D

2110 U - X0 - Y * CP:V - Y0 - Y * SP

2120 FOR X - XL TO XR

2130 XB - INT (U + X * CF + .5)

2140 Z - FN Y(X): IF Z > H THEN Z = H 2150 YB - INT (V - X * SF - Z + .5)

2160 IF YB < H(XB) THEN H(XB) - YB 2170 NEXT X

2200 FOR K = INT (U + XL * CF + .5) TO INT (U + XR * CF) - 1 2210 HPLOT K,H(K) TO K + 1,H(K + 1)

2220 NEXT K 2230 NEXT Y 2240 RETURN

6 BYTE LISTINGS SUPPLEMENT

gcd.bas

TEXT

Mathematical Recreations: "Euclid's Algorithm," by Robert T. Kurosaka. January page 397. Also download Icm.bas and eye Ifroc.bos.

310 ’**********************************************<,*******«

320 ’* EUCLIO'S ALGORITHM FOR GREATEST COMMON DIVISORS *

330 ** BY ROBERT T. KUROSAKA *

340 ********************************************************

350 CLS

360 PRINT “This program calculates the greatest common divisor"

370 PRINT "of a positive fraction"

380 PRINT "and reduces the fraction to lowest terms."

390 PRINT :PRINT

400 INPUT "ENTER THE FRACTION'S NUMERATOR";NUM:NUM-ABS(NUM)

410 INPUT "ENTER THE FRACTION'S DENOMINATOR";DEN:DEN-ABS(DEN)

420 DIVISOR-NUM:DIVIDEND-DEN 'SAVE ORIGINAL VALUES FOR LATER DISPLAY 430 REM IF EITHER TERM IS NOT A WHOLE NUMBER, CLEAR THE DECIMAL.

440 IF DIVISOR<>INT(DIVISOR) OR DIVIDENDoINT(DIVIDEND) THEN DIVISOR-DIVISOR*10:

DIVIDEND-DIVIDEND*10:NUM-DIVISOR:DEN=DIVIDENO:GOTO 440 450 IF DIVISOR>DIVIDEND THEN SWAP DIVISOR, DIVIDEND 460 WHILE DIVISOR>0

470 QUOTIENT«INT(DIVIDEND/DIVISOR)

480 REMAINDER-DIVIDEND-DIVISOR*QUOTIENT

490 DIVIDEND-DIVISOR: DIVISOR-REMAINDER

500 WEND

510 PRINT :PRINT

520 PRINT "THE FRACTION ";NUM;"/";DEN;" HAS A G.C.D. OF ";DIVIDEND

530 IF DIVIDEND-1 THEN PRINT "THE FRACTION IS ALREADY IN LOWEST TERMS.“:GOTO 560

540 PRINT "THE REDUCED FRACTION IS: ";NUM/DIVIDEND;" /";DEN/DIVIDEND;

550 IF DEN/DIVIDEND-1 THEN PRINT " - ";NUM/DIVIDEND 560 END

Icm.bas

TEXT

Mathematical Recreations: "Euclid's Algorithm." See gcd.bos.

10 ’**********************************************

20 '* LEAST COMMON MULTIPLE ALGORITHM *

30 ’* BY ROBERT T. KUROSAKA *

40 '*******•***********•*****•••**•********••*****

50 CLS

60 PRINT "This program calculates the least common multiple"

70 PRINT "of a set of positive Integers."

80 PRINT

90 INPUT "HOW MANY INTEGERS ARE IN THE SETTERMS:TERMS-INT(ABS(TERMS))

100 IF TERMS<2 THEN 400

110 REM NUMBER ARRAY HOLDS THE SET OF INTEGERS FOR WHICH THE LCM IS SOUGHT.

120 DIM NUMBER(TERMS)

130 PRINT :PRINT "ENTER THE INTEGERS ONE AT A TIME."

140 FOR 1-1 TO TERMS 150 INPUT NUMBER(I)

160 NUMBER(I)-INT(ABS(NUMBER(I)))

170 IF NUMBER(I)»0 THEN PRINT "ILLEGAL ENTRY.":GOTO 150 180 NEXT I

190 REM BEGIN LCM PROCEDURE.

200 LCM-NUMBER(I) 'THE LCM OF A SINGLE NUMBER IS ITSELF.

210 FOR 1-2 TO TERMS

220 REM FIND GCD OF ACTIVE ENTRY AND WHAT PRECEDED IT (GCD WILL BE STORED IN 'DIVIDEND' BECAUSE LINE 290 ASSIGNS LAST VALID DIVISOR TO DIVIDEND).

230 DIVIS0R-NUM8ER(I):DIVIDEND-LCM

240 REM LINES 250-300 ARE THE SAME AS 450-500 OF THE GCD ROUTINE.

250 IF DIVISOR>DIVIDEND THEN SWAP DIVISOR.DIVIDEND

260 WHILE DIVISOR>0

270 QUOTIENT-INT(DIVIDENO/DIVISOR)

(continued)

BYTE LISTINGS SUPPLEMENT 7

January

280 REMAINOER-DIVIDEND-DIVISOR*QUOTIENT

290 DIVIOENO-DIVISOR:DIVISOR-REMAINDER

300 WEND

310 LCM-NUMBER(I)* LCM/DIVIDEND

320 REM THE LAST LCM WILL BE LCM OF ALL THE ENTRIES.

330 NEXT I

340 PRINT :PRINT

350 PRINT "THE LEAST COMMON MULTIPLE OF";

360 FOR 1-1 TO TERMS 370 PRINT NUMBER(I);

380 NEXT I

390 PRINT "IS";LCM

400 END

cyclfrac.bas TEXT

Mathematical Recreations: "Euclid’s Algorithm," Robert T. Kurosaka. Listing 3, page 402.

10 ***********************************************************

20 '* REPEATING DECIMAL TO FRACTION CONVERTING ROUTINE *

30 •* BY ROBERT T. KUROSAKA *

50 CLS

60 PRINT "Th1s routine can be used with the greatest common denominator"

70 PRINT "program. Load the GCD program, then MERGE this routine into It."

80 PRINT "The MERGEd program is designed to determine the reduced fractional" 90 PRINT "representation of a repeating decimal.":PRINT 100 PRINT "To ENTER a repeating decimal:":

PRINT " Type the nonrepeating part, then a before the cycle." 110 PRINT "For example, 1.2_345 Is the proper entry for 1.2345345345..."

120 PRINT "The decimal should always precede the , l.e., .333... is

entered": PRINT "as *._3'. Reversing the and will cause

an error.":PRINT

130 INPUT "ENTER REPEATING DECIMAL";NUMBER$

140 REM NON-REPEATING PART OF NUMBER IS THAT PART UP TO VAL OPERATOR

IGNORES ALL NUMBERS AFTER A NON-NUMERICAL CHARACTER. THUS, IN 1.2_345. VAL(“1.2_345") WILL BE 1.2, ETC.

150 NONREPEATING.PART-ABS(VAL(NUMBER!))

160 REM DEFINE A MORE READABLE FUNCTION TO USE FOR THROWING THE LEFTMOST CHARACTER OF A STRING AWAY.

170 DEF FNDROP.LEF T$(A$)=RIGHT$(A$,LEN(A$)-1)

180 REM FIND DECIMAL POINT

190 WHILE LEFT$(NUMBER$,1) <> "."

200 NUMBER$«FNDROP.LEFT$(NUMBER$)

210 WEND

220 NUM8ER$=FNDR0P.LEFT$(NUMBER$)

230 REM FIND OUT HOW MANY DECIMAL PLACES THE REPEATING CYCLE IS OFFSET FROM THE DECIMAL POINT.

240 WHILE LEFT$(NUMBER$,1) o "_"

250 OFFSET-OFFSET+1

260 NUMBER$-FNDROP.LEFT!(NUMBER!)

270 WEND

280 REM THROW AWAY REPEATING PORTION MARKER,

290 NUMBER!-FNDROP.LEFT!(NUMBER!)

300 REM HOW MANY DECIMAL PLACES ARE IN THE CYCLE? SINCE THE REPEATING CYCLE IS EVALUATED AFTER THROWING AWAY THE DECIMAL POINT. MULTIPLY BY 10‘-(TOTAL NUMBER OF PLACES TO THE RIGHT IT SHOULD BE SHIFTED).

310 CYCLE.LENGTH-LEN(NUMBER!)

320 REPEATING.CYCLE-VAL(NUMBER!)* 10"-(OFFSET+CYCLE.LENGTH)

330 REM NUMBER-NONREPEATING PART+REPEATING CYCLE. SINCE THE FIRST ITERATION OF THE CYCLE IS THE ONLY ONE THAT DOES NOT CANCEL ON SUBTRACTION, ONLY USE IT.

340 NUMBER-NONREPEATING.PART+REPEATING.CYCLE

350 REM "CLEARED.NUMBER IS THE VALUE OF THE SUBTRACTION THAT DOES AWAY WITH THE INFINITE CYCLE (STEP 3 IN THE BYTE ARTICLE ALGORITHM).

360 CLEARED.NUMBER-NUMBER*10‘CYCLE.LENGTH-NONREPEATING.PART 370 REM NOW. ASSIGN THE VALUES OF THE NUMERATOR AND DENOMINATOR TO THE VARIA8LE NAMES USED IN THE GCD ROUTINE.

380 NUM-CLEARED.NUMBER:DEN-10‘CYCLE.LENGTH-1

390 REM I CONVERT NUM AND DEN TO STRINGS AND THEN BACK TO CLEAR THE GUARD DIGITS IN THE NUM AND DEN VARIABLES. SEE BYTE ARTICLE FOR DETAILS.

8 BYTE LISTINGS SUPPLEMENT

400 NUM$-STR$(NUM):DEN$«STR$(DEN):NUM-VAl(NUM$):DEN=VAL(DEN$) 410 PRINT "THE EQUIVALENT UNREDUCED FRACTION IS:";NUM;"/“;DEN

January

frames.pro TEXT

"AI in Computer Vision." See airead.me for details.

/* get the Value of Slot in a given Frame */ frame_get(Frame,Slot,VaIue)

ffget(Frame,Frame,Slot.Value).

ffget(Parameter_Frame,Frame,Slot.Value) /* check for a value Facet */ fget(Frame,SIot,vaIue,VaIue).

ffget(Parameter_Frame,Frame,Slot.Value) /* does it have a default? */ fget(Frame,SIot,defauIt,VaIue).

ffget(Parameter_Frame,Frame,Slot.Value) /* how about a demon? */

fget(Frame,Slot,if_needed,RuIe),

F =.. [RuIe,Parameter_Frame,Value],

F.

ffget(Parameter_Frame,Frame,Slot.Value) /* none of the above */

fget(Frame,ako,value,Parent), /* so, move up the hierarchy */

ffget(Parameter_Frame.Parent,Slot.Value).

fget(Frame,Slot.Facet.Value) /* just grab the given Facet or fail */

F = .. [Frame,Slot.Facet.Value],

/* put Value in Slot of a given Frame. If this Slot has an associated if_added demon, then grab it and execute It after installing the given Value.

*/

frame_put(Frame,SIot,VaIue)

get_ruIe(Frame,SIot,if_added,RuIe), /* must we do something extra */ fput(Frame,SIot,vaIue,VaIue),

F [RuIe.Frame,VaIue],

F.

frame_put(Frame,Slot.Value) s

fput(Frame,Slot.value,Value). /* just a simple fput will do */

fput(Frame,Slot.Facet.Value)

F «.. [Frame,Slot,Facet.Value], assertz(F).

/* remove Slot from a given Frame. If the Slot has an associated if_removed demon, then grab the rule and execute it before , removing the Slot.

*/

f rame_remove(Frame,SIot)

get__ruIe(Frame,SIot,if_removed,RuIe), /* something extra to do */

F ■.. [RuIe.Frame],

F,

fremove(Frame,Slot). frame_remove(Frame,Slot)

fremove(Frame,Slot). /* just a simple fremove */

fremove(Frame.Slot)

F *.. [Frame,Slot.value,Value], retract(F).

fremove(_,_). /* If Slot doesn't exist, then no harm done */

/* replace whatever is in Slot with Value. If the Slot has an associated if_repIaced rule, then grab it and execute it after doing the rep Iacement.

[continued)

BYTE LISTINGS SUPPLEMENT 9

frame_repI ace(Frame,Slot.Value)

get_rule(Frame,Slot.If_replaced,Rule). /* something extra to do */ frep I ace(Frame,Slot.Value),

F -.. [Rule,Frame],

F.

frame_repI ace(Frame,Slot.Value)

freplace(Frame.Slot.Value). /* just a simple replace */

frep Iace(Frame,Slot,VaIue)

fremove(Frame.Slot), frame_put(Frame,SIot.Value).

/* append Value to the list in Slot. If Slot has an associated if.appended rule, then grab it and execute it after appending

the Value.

*/

frame_append(Frame,Slot.Value)

get_.ru I e(Frame ,S I ot , i f ..appended ,Ru I e) , f append(Frame,SIot,VaIue),

F «.. [Rule,Frame],

F.

f rame__append(Frame ,S I ot ,Va I ue)

fappend(Frame.Slot,Value).

/* here we check to see if the slot already exists.

If it does, then we just append the new Value to the old value list. If the Slot does not exist, then we create it and give it a value consisting of the list whose single element is Value.

*/

fappend(Frame.Slot.Value)

fget(Frame,Slot,value,Old).

(member(VaIue,01d)

fremove(Frame,Slot), fput(Frame,SIot.value,[Value101d])

fappend(Frame,SIot,VaIue)

fput(Frame,Slot.value,[Value]).

/* this is a simple utility predicate used to travel up the frame hierarchy looking for an appropriate rule to grab.

*/

get_ruIe(Frame,SIot.Type.Rule)

fget(Frame,SIot.Type.RuIe). get_.ru I e (Frame ,S I ot .Type.Ru I e)

fget(Frame,ako,value.Parent), get_ruIe(Parent.Slot.Type.RuIe).

/* Example

frame representation:

cyIinder ako

value : thing height

if_added : cyIinder_height_add

if_removed : cy11nder_height_remove radius

if_added : cy I inder__radius_add

If_removed : cyIinder_radius_remove cross_section

if_needed : cyIinder_cross_section voIume

!f__needed : cy I inder_vo I ume

10 BYTE LISTINGS SUPPLEMENT

cyIinder1 ako

value : cylinder

comments: cyllnderl above is an instance of cylinder. When we use frame-put(cylinderl,radius,2), say, the system wiI I install the number "2" as the value of cylinderl’s radius and it will further compute cylinderl's cross sectional area and install it under the cross_section slot. Similor actions take place when we do a frame_put for cylinderl’s height. Below is the Prolog code that implements all this. NOTE: PDPROLOG only supports integer arithmetic.

*/

cyIinder(ako,value,geometric_object).

cylinderfheight,if_added,cylinder.height_add).

cylInder(height,if_removed,cyIinder_height_remove).

cylinder ( radius,if_added,cylinder_radius_add).

cylinder(radius,if_removed,cyIinder_radius_remove).

cylinder(cross_section,if-needed,cylinder_cross_section).

cylinder(voIume,if—ineeded,cyIinder_voIume).

/* if we get the height, then we try to compute the cylinder’s voIume.

*/

cylfnder_height_add(Cylinder,_)

cylinder_voIume(CyIinder,_).

cylfnder_height_add(_,_). /* if we can’t do it,

e.g., the radius is unknown, then no harm done */

/* if the height is removed, then the old volume is no longer valid

*/

cylinder_heIght_remove(CyIinder)

frame_remove(CyIinder,voIume).

/* if we get the radius, then we can compute the cylinder’s cross sectional area

*/

cylInder_radius_add(CyIinder,_)

cylinder_cross_section(CyIinder,_).

/* if the radius Is removed, then the old cross sectional area Is no Ionger valid

*/

cyllnder_radIus_remove(CyIinder)

f r ame_remove(CyIinder,cross_section), frame_remove(CyIinder,voIume).

/* PDPROLOG does not support floating-point arithmetic, so pi has been

approximated as 3. If you are using a commercial prolog, change 3 to 3 1416

*/

cyl1nder_cross_section(CyIinder,Cross_Section) f rame_get(CyIinder,radius.Radius),

Cross-Section Is 3*Radius*Radius, frep I ace(Cylinder,cross_section,Cross_Section).

cylinder-voIume(CyI Inder,Vo Iume)

frame.get(Cylinder,cross_section,Cross_Section), frame-get(Cylinder,height,Height),

Volume is Height♦Cross-Sect ion, f rep I ace(Cylinder,voIume,Vo Iume).

cylinderl(ako,value,cylInder).

BYTE LISTINGS SUPPLEMENT 11

Iisting.txt TEXT

Ciorcio’s Circuit Cel lor: "Build on Anolog-to-Digitol Con verter." Steve Clorcia. January, poge 104.

10 CLEAR

20 REM READ AND DISPLAY A/D CHANNELS 0-7 30 REM SINGLE ENDED OR DIFFERENTIAL 40 REM -5 TO +5 VOLT INPUT 50 REM 60 REM

70 N=47104 : REM BOARD ADDRESS 80 REM STATUS BIT IS B5 - LOGIC 1 IS RESET 90 FOR A=0 TO 7 : REM DO ALL CHANNELS 0-7 100 GOSUB 160 : REM READ A CHANNEL 110 NEXT A : REM NEXT CHANNEL

120 PRINT CHR(18),CHR(27),"Y" : REM TERMITE - HOME AND CLEAR SCREEN 130 REM DISPLAY ARRAY HOLDING CHANNEL 0-7 READINGS

140 PRINT USING(#.###),A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),"VOLTS 150 GOTO 20 : REM DO IT AGAIN

160 XBY 170 XBY

(N)=

(N>

■A + 16 : REM RESET A/D AND SET MUX CHANNEL ■A : REM CLEAR STATUS BIT TO READ DATA 180 DI-XBY(N) : D2-XBY(N) : REM READ 12 BITS AS 2 SUCCESSIVE WORDS 190 R-.0012207 : REM VOLTS PER COUNT 200 IF DI>«*240 THEN GOTO 230

210 A(A)-R*((D1*256)+D2) : REM SAVE POSITIVE READING IN ARRAY 220 RETURN

230 D1-255-D1 : D2-255-D2 : REM ADJUST D1 4 D2 FOR 2’S COMPLEMENT 240 A(A)«-1*R*((D1*256)+D2) : REM SAVE NEGATIVE READING IN ARRAY 250 RETURN

macgraf.bos TEXT

Programming Insight: "Easy 3-D Grophlcs." Henning Mittlebach. January, page 153. Macintosh version.

****************************************

MacGraf - Easy 3-D Graphics on the Macintosh

by

Henning MIttelbach

Copyright 1985, for private, non-commercial

use only.

****************************************

10 *

20 *

30 *

40 ’

50 '

60 *

70 ’

80 CLS

90 DIM H (279)

100 X0-110 110 Y0-180 120 PHI-.5 130 PSI-.4 140 XL- 0 150 XR- 170 160 YL-0 170 YR-100 180 D-5

198 '

199 '

200 DEF FN Y(X)

210 F-10

24 0 • * ABBREVIATIONS AND CUTTING THE TOP *

250 CF- COS (PHI) : SF-SIN(PHI) : CP- COS (PSI) : SP- SIN(PSI)

260 H-Y0 - XR * SF -YR * SP - 2

270 INPUT "Do you desire cross-hatching? (Y/N):“,

280 IF opt$-"Y" OR opt$«“y" THEN ch»2 ELSE ch=1 300 INPUT "Do you wish to view the axes? (Y/N):“,

310 CLS : IF AX$-“Y" OR ox$«"y" THEN 320 ELSE 340

320 LINE (X0 + XL * CF. Y0 - XL * SF) -(X0 + XR *

330 LINE (X0 - YL * CP. Y0 - YL * SP) -(X0 - YR *

340 LINE (0.0) 350

* FUNCTION TO BE PLOTTED * SIN (Y/F) * (X-Y) * (X-Y)/150

opt$

AX$

"(279,189),,B

CF.

CP.

Y0 - XR Y0 - YR

SF) SP )

12

BYTE LISTINGS SUPPLEMENT

398 • R-1:

399 ' R«2:

400 FOR R - 1 TO ch 410 *

420 FOR I - 0 TO 279: H(I)

430 ON R GOSUB 1000, 2000 440 NEXT R

499 '

500 BEEP

510 LINE (0.0) - (279,189)..B

Y-COORD.

X-COORO.

LINES

LINES

* SETTING MASK ON LOWER BORDER OF WINDOW * = 189: NEXT I

* GRAPHIC IS FINISHED *

IF a$=

THEN 520

* END OF PROGRAM *

* Y-COORD. LINES FOR X

* FRONT MASK SETTING *

CF - Y * CP + .5) > H THEN 2 - H SF - Y * SP - Z + YB

CONST. *

.5)

520 o$=» INKEY$:

600 END $10 *

1000 1

1010 Y - YL: •

1020 FOR X - XL TO XR 1030 XB = INT (X0 + X *

1040 Z - FN Y(X) : IF Z 1050 YB = INT (Y0 - X *

1060 IF YB < H(X8) THEN H(XB)

1070 NEXT X

1090 * ADAPTING THE MASK PER LINE *

1100 FOR X - XL TO XR STEP D

1110 U - X0 + X * CF : V - Y0 - X * SF

1120 FOR Y - YL TO YR

1130 XB = INT (U - Y * CP + .5)

1140 Z - FN Y(X) : IF Z > H THEN Z - H

1150 YB - INT (V - Y * SP - Z + .5)

1160 IF YB < H(XB) THEN H(XB) « YB

1170 NEXT Y

1190 ' * PLOTTING THE MASK *

1200 FOR K - INT (U - YR * CP + .5) TO INT (U - YL * CP + .5) - 1 1210 LINE (K.H(K)) - (K + 1,H(K+1))

1220 NEXT K 1230 NEXT X 1240 RETURN 2000 *

2010 X - XL: •

2020 FOR Y - YL TO YR 2030 XB - INT (X0 + X *

2040 Z - FN Y(X) : IF Z

2050 YB - INT (Y0 - X * SF - Y * SP - Z + .5)

2060 IF YB < H(X8) THEN H(XB) - YB 2070 NEXT Y

2090 ’ * ADAPTING THE MASK PER LINE *

2100 FOR Y - YL TO YR STEP D 2110 U - X0 - Y * CP : V ■ Y0 - Y * SP 2120 FOR X - XL TO XR

X * CF + .5)

IF Z > H THEN Z - H 2150 YB - INT (V - X * SF - Z + .5)

2160 IF YB < H(X8) THEN H(XB) - YB 2170 NEXT X 2190 •

2200 FOR K - INT (U ♦ XL 2210 LINE (K.H(K)) - (K + 1,H(K+lj$

2220 NEXT K 2230 NEXT Y 2240 RETURN

* X-COORD. * FRONT MASK SETTING *

LINES FOR Y = CONST. *

CF - Y * CP + .5) > H THEN Z - H SF - Y * SP - Z +

2130 XB - INT (U + 2140 Z - FN Y(X)

PLOTTING THE MASK *

CF + .5) TO INT (U + XR * CF) - 1

editsort.md2 TEXT

"Creating Reusable Modules," Namir Clement Shammas. January, page 145. Also download quiksort.md2.

EDITS0RT.MD2 MODULE Ed ItSort;

(* -*

(* This module Is the capsule editor for the procedure Quicksort. ♦

{continued)

BYTE LISTINGS SUPPLEMENT 13

! * This editor will perform the following:

*

* (1) Customize the procedure nome.

* (2) Customize the Record type decloratlon.

* (3) Customize the keys for sorting. _

FROM Strlibl IMPORT Stringls, StrtngAdd. StringRemove. StringRepI ShowString, StringLeft. Inputstring, ten. StringPos, eos;

FROM FileSystem IMPORT File, Response, Lookup, Close, ReodChor,

WriteChor;

FROM InOut IMPORT ReadCard, WriteCard;

FROM Terminal IMPORT WrlteLn;

CONST MAXKEY - 10;

MAXSTRING - 80:

EOL - 36C ;

TYPE String - ARRAY [1..MAXSTRING] OF CHAR;

VAR I. J, k, n : CARDINAL: ch : CHAR;

Line, Str, Sortnome. Recname, YourFile, Fldname : String; Subkey : ARRAY [1..MAXKEY] OF String; f1. f2 : File;

PROCEDURE GetLine;

(* Procedure to read the next text line from QWKSORT.CAP file.

(* Insert on End Of String (eos) If string is not full.

BEGIN

I 0;

REPEAT

ReadChar(f1,ch);

INC(i);

Line[!] :«■ ch UNTIL ch - CHAR(EOL) ;

IF i < MAXSTRING THEN Llne[i + 1] :« eos END;

END GetLine;

PROCEDURE PutLine;

(* Procedure to write o text line In the user specified output (* file. If the line is generated by this program, append an (* End-Of-Line (EOL) character to the text line.

BEGIN

I :» Len(Line);

IF i>0 THEN

FOR j 1 TO i DO ch ;= Line[j];

Wr i teChar(f2.ch)

END;

IF ch <> CHAR(EOL) THEN WriteChar(f2.CHAR(EOL)) END;

END;

END PutLine;

PROCEDURE ScanSkip(Match : ARRAY OF CHAR);

Procedure will read a text line from file QWKSORT.CAP and (# attempt to locate string 'Match' in it. If no match is (* found, the line is written to output text file.

VAR Pos : CARDINAL;

BEGIN

Pos :■ 0;

WHILE Pos - 0 DO GetLine;

Pos :■ StrlngPos(Line.Match,1);

IF Pos - 0 THEN PutLine END;

END;

END ScanSkip;

PROCEDURE OneSort;

(* Procedure to customize the dummy key field

14 BYTE LISTINGS SUPPLEMENT

January

BEGIN

(* Edit record type. *)

ScanSkIp(“Item");

StrIngReplace(LIne,"Item".Recname); PutLIne;

(* Enter sort key and edit the 'dummy' key. *)

ShowStrlng("Enter fieldname ? "); InputStrJng(Fldname); FOR k 1 TO 2 00

ScanSklp("key"); StrIngReplace(Llne."key'',Fldnome); PutLIne '

ENO;

END OneSort;

PROCEDURE Mu 111 Sort;

(* Procedure to establish multikey sorting. *)

BEGIN

(* Enter the number of sort fields and their names. *) ShowStringf"Enter number of fields used ? ");

ReadCard(n);

WriteLn;

FOR k 1 TO n DO

ShowStr ing(''Enter name for subkey # ");

Wr i teCard(k,2);

ShowString(" “); InputString(Subkey[k]);

WrIteLn

END;

(* Edit the arguments In the procedure coll, changing them (* from arrays of character to the user specified record tvoe ScanSkipf-SI. S2 '

StringIs(Str,"R1, R2 : ");

StringAdd(Str.Recname); StringRepI ace(Line."SI, S2 :

ARRAY OF CHAR".Str);

PutLIne;

ScanSkIp("I : CARDINAL;"); PutLIne;

(* Insert the declaration for the strings used in the (* comparison.

StringIs(Line," SI. S2 : ARRAY [1.YourMaxString] OF CHAR;"); PutLine;

ScanSkip("i 0"); PutLine;

(* Build the text line that represents the code for the (* build-up of the multifield sort string.

StrIngIs(Line."St ring Is(SI,R1."); StringAdd(Line.Subkeyril)StringAdd(Line,") ; Strlngls(S2.R2."); 1

StringAdd(Line,Subkey[1]);

StrIngAdd(Line,") ;“) ; PutLine;

IF n > 1 THEN FOR k 2 TO n DO

StringIs(LIne." StrlngAdd(S1,R1.");

StringAdd(Line.Subkey[k]);

Str i ngAdd (Line, *') ; Str ingAdd(S2.R2.'•) ; StringAdd(Line.Subkey[k]);

StrlngAdd(Llne,") ;") ; PutLine ENO;

END;

*)

*)

:!

:)

(* Edit record type for the locally declared records. SconSkip("Item");

StringRepIace(LIne,"Item".Recname); PutLine;

(* Edit the call to the Compare procedure.

FOR k 1 TO 2 DO

END COnSkiP( "' k * y " 5 Str,n 9 R « mov «( Lin *-"- k ®y M ): PutLine ENO MultiSort;

BEGIN (* Main module *)

ShowString("Enter the output filename ? ");

InputString(YourFile); WriteLn;

Lookup(f1."c:qwk sor t.cap."FALSE);

Lookup(f2.YourFile.TRUE);

(* Check if both files are opened correctly.

IF (fl.res - done) AND (f2.res - done) THEN ShowStrlng("Enter new procedure name ? ");

InputStrIng(Sortname);

WrIteLn;

GetLIne ; StrIngRepIace(Line,"QuIckSort."Sortnome);

{continued)

BYTE LISTINGS SUPPLEMENT IJ

I anuary

ShowString("Enter record type nome ? “):

InputString(Recnome);

WrlteLn; .. ,

StrIngRepIoce(Llne,"Item".Recnome); PutLine;

GetLIne ; GetLIne; (* * Skip the two comment lines *)

ShowStrlng(“Is the sort based on one field ? “); InputStrlng(Str); WrlteLn; A . . \

StrIngLeft(Str,Str, 1); (* Extract the leftmost character *)

IF CAP(Str[1]) - "Y" THEN OneSort ELSE MultlSort END *

ScanSk lp( H QulckSort M ) ; Str IngRepIace(Llne, "Quicksort* 4 ,

Sortname);

PutLine;

ELSE

ShowStrlng("Error In locating fI Ie QWKSORT.CAP")

IF (fi.ree - done) THEN Closeffl) END; IF (f2.res ■ done) THEN Close(f2) END; END EdltSort.

readsim2.me TEXT

"A SIMPL Compiler, Part 2: Procedures and Functions." See simpl2.txt.

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

Note 8

Note 9

Note 10

Note 11

Note 12

Note 13

Note 14

Note 15

Note 16

[Editor’s note: The above files were combined were put on the bulletin board. You will need Into a separate file to compile them.]

Into one to break

file

each

when they moduIe

You

the

the

Will also need to compile the following utility modules along with 12 above. These modules can be found with those downloaded with VM2 Monitor:

CharStuff LexAnStuf f MyTerminaI StringStuff

The programs were developed using MacModula-2 for the Macintosh, but conversion to other Modula-2 systems should be straightforward, would appreciate hearing about any conversion difficulties or bugs. You can reach me on BIX as "jbo" or by U.S. mail at 1643 Cambridge St. #34. Cambridge. MA 02138. Happy CompiIing!

Jonathan Amsterdam

16 BYTE LISTINGS SUPPLEMENT

pcgraf.bas TEXT

Programming Insight: "Easy 3-D Graphics," Henning Mittlebach. January, page 153. IBM version.

**********************************************

* PCGRAF - Easy 3-D Graphics on the IBM PC *

* by *

* Henning Mittelbach *

* Copyright 1985, for private non-commercial *

* use only. *

**********************************************

10 *

20 *

30 #

40 #

50 *

60 *

70 •

80 CLS: SCREEN 1 90 DIM H (279)

100 X0-110 110 Y0-180 120 PHI-.5 130 PSI-.4 140 XL- 0 150 XR- 170 160 YL-0 170 YR-100 180 D-5

198 •

199 *

200 DEF FN Y(X)

210 F-10

240 * * ABBREVIATIONS AND CUTTING THE TOP *

250 CF= COS (PHI) : SF-SIN(PHI) : CP- COS (PSI) : SP- SIN(PSI) 260 H-Y0 - XR * SF -YR * SP - 2

270 INPUT "Do you desire cross-hatching? (Y/N):",OPT$

280 IF OPT$="Y" OR OPT$-"y" THEN CH-2 ELSE CH-1 300 INPUT "Do you wish to view the axes? (Y/N):",AX$

* FUNCTION TO BE PLOTTED * SIN (Y/F) * (X-Y) * (X-Y)/150

IF AX$ (X0 + XL (X0 - YL ( 0 .

"Y" OR AX$

* CF. Y0 - XL

* CP, Y0 - YL 0) - (279,189),,B

y" THEN 320 ELSE 340

* SF) -(X0 + XR

* SP) -(X0 - YR

CF,

CP.

> 1 :

2:

Y-COORD.

X-COORD.

LINES

LINES

* SETTING MASK ON LOWER BORDER OF WINDOW * = 189: NEXT I

* GRAPHIC IS FINISHED *

IF A$="" THEN 520

310 CLS 320 LINE 330 LINE 340 LINE 350 *

398 •

399 •

400 FOR R - 1 TO CH 410 •

420 FOR I - 0 TO 279: H(I)

430 ON R GOSUB 1000, 2000 440 NEXT R

499 '

500 BEEP

510 LINE (0.0) - (279.189),,B 520 A$»INKEY$: '

600 END 610 *

1000 ’

1010 Y - YL: *

1020 FOR X - XL TO XR 1030 XB - INT (X0 + X 1040 Z - FN Y(X) : IF 1050 YB - INT (Y0 - X 1060 IF YB < H(XB) THEN H(X8)

1070 NEXT X

1090 ’ * AO APT ING THE MASK PER LINE *

1100 FOR X - XL TO XR STEP 0 1110 U - X0 + X * CF : V - Y0 - X * SF 1120 FOR Y - YL TO YR 1130 XB - INT (U - Y * CP + .5)

IF Z > H THEN Z - H INT (V - Y * SP - Z + .5)

THEN H(XB) - YB

Y0 - XR * SF) Y0 - YR * SP )

* END OF PROGRAM *

* Y-COORD. LINES FOR X * FRONT MASK SETTING *

CONST. *

CF - Y * CP + .5) > H THEN Z - H SF - Y * SP - Z + YB

•5)

1140 Z - FN Y(X)

1150 YB

H(XB)

1160 IF YB <

1170 NEXT Y 1190 ’

1200 FOR K - INT (U - YR 1210 LINE (K.H(K)) - (K +

* PLOTTING THE

■ CP + .5) 1,H(K+1))

TO

MASK *

INT (U - YL *

CP + .5) - 1

\

( continued )

BYTE LISTINGS SUPPLEMENT 17

1220

1230

1240

2000

2010

2020

2030

2040

2050

2060

2070

2090

2100

2110

2120

2130

2140

2150

2160

2170

2190

2200

2210

2220

2230

2240

NEXT K NEXT X RETURN

* X-COORO. LINES FOR Y - CONST. * FRONT MASK SETTING *

CF - Y * CP ♦ .5) > H THEN Z « H SF - Y * SP - Z + YB

.5)

X ■ XL: ’

FOR Y - YL TO YR XB - INT (X0 + X Z - FN Y(X) : IF Y8 - INT (Y0 - X IF YB. < H(XB) THEN H(XB)

NEXT Y

• * AOAPTING THE MASK PER LINE * FOR Y - YL TO YR STEP D

U - X0 - Y * CP : V - Y0 - Y * SP

FOR X - XL TO XR

XB « INT (U + X * CF + .5)

Z - FN Y(X) : IF Z > H THEN Z - H YB - INT (V - X * SF - Z + .5)

IF YB < H(XB) THEN H(XB) - YB NEXT X

• * PLOTTING THE MASK *

FOR K - INT (U + XL * CF + .5) TO INT (U + XR * CF) LINE (K.H(K)) - (K + 1.H(K+1))

NEXT K NEXT Y RETURN

quiksort.md2

TEXT

"Creating Reusable Modules." See editsort.md2.

QUIKSORT.MD2

(* This module should be saved under

the name QWKSORT.CAP.

*>

PROCEDURE QulckSort( A : ARRAY OF Item ; N : CARDINAL ); (* Capsule Quicksort: A skeleton procedure for using the (* quicksort algorithm. See reference 3.

PROCEDURE Compare ( SI. S2 : ARRAY OF CHAR): BOOLEAN;

(* Compare two strings of the same maximum lengths.

CONST eos - 0C; (* End-Of-String *)

VAR Less. Stop : BOOLEAN; i ; CARDINAL;

BEGIN

Less := FALSE;

Stop :* FALSE;

WHILE (i <- HIGH(SI)) AND (Less = FALSE) AND (Stop * FALSE) DO IF (SI[i] <> eos) AND (S2[i] <> eos)

THEN (* Proceed in comparison *)

IF (SI[i] < S2[i1) THEN Less := TRUE ELSE INC(i) END; ELSE Stop := TRUE (* Reached the end of string *)

END;

END;

RETURN Less;

END Compare;

PROCEDURE Sort( L. R : CARDINAL);

VAR i. j : CARDINAL;

X. W : Item;

BEGIN

X := A[(L + R) DIV 2];

REPEAT

WHILE Compare(A[i].key.X.key) DO INC(i) END; WHILE Compare(X.key,A[i].key) DO DEC(j) END; IF i <= j THEN

\

18 BYTE LISTINGS SUPPLEMENT

January

w = A INC( END;

A[i] := A[i] U : DEC(j)

A[i]

UNTIL i > j ;

IF L < j THEN Sort(l.j) END; IF i < R THEN Sort(i.R) END; ENO Sort;

A[j] ; A[j] ;= W ;

BEGIN

Sort(I.N) END QuickSort;

simpl2.txt

TEXT

Programming Project: "A SIMPL Compiler. Part 2: Procedures and Functions." Jonathan Amsterdam.

January, page 130. Code for the revised SIMPL compiler. Also download

readsim2.me.

E+++++++

Editor's note: Break each of the files into a separate file. Be sure and delete the notes surrounded by plus signs.

Start CodeGen.DEF +++++++

DEFINITION MODULE CodeGen;

(* This module generates code from parse trees. *)

FROM Node IMPORT node;

FROM Symbol IMPORT symbol;

EXPORT QUALIFIED genBlock. genGlobal, genLocals;

PROCEDURE genBlock(n:node);

(* Generate code for a block of statements. *)

PROCEDURE genGIobaI(s:symboI);

(* Generate code for a global variable. *)

PROCEDURE genLocaIs(routine:symbol);

(* Generate code to set up the stack for local variables. *)

END CodeGen.

+++++++

Start CodeGen.MOD +++++++

IMPLEMENTATION MODULE CodeGen;

(* Code Generator for the SIMPL compiler. *)

IMPORT MyTermlnaI;

FROM InOut IMPORT WriteString, WriteLn;

FROM Node IMPORT node, nodeClass, NodeClass, nodeEmpty, nodeFirst, nodeRest, nodeTest, nodeThen, nodeElse, nodeStmts, nodeRHS, nodeLHS, nodeArgs! nodeRoutine, nodeExpr, nodeArg, nodeLeftArg. nodeRightArg, nodeOp, nodeSymbol, nodelnt, nodeBool, nodeNumFormaIs, nodeChar, nodeType, freeNode;

FROM CodeWrite IMPORT writeLabel, writeStringLabeI, writeStringBranch, wrIteCondBranch, writeBranch, writePop, writeCall, writeChar, writeWritelnt, writelnt, wrlteReadlnt, writeReturn, writeFReturn, writeOp, writeBool, writeSymbol, writeWrIteChar, writeReadChar;

FROM Token IMPORT tokenClass, isRelation, strlngType, typeType;

FROM LexAn IMPORT errorFlag;

FROM Symbol IMPORT symbol, symboILexLeveI, symboI String, numLocals;

(*** label generation ***)

(* The code generator needs a supply of unique label names. *)

( continued )

BYTE LISTINGS SUPPLEMENT 19

) amary

MODULE LabeIGenerator;

EXPORT newLabeI, IabeI;

TYPE label - CARDINAL;

VAR I abe ICount -.CARDINAL;

PROCEDURE newLabeI():label; BEGIN

INC(IabeICount);

RETURN label(IabeICount); END newLabeI;

BEGIN

labelCount 0;

END LabeIGenerator;

PROCEDURE genBlock(n:node); don .* wa8 t« our time

BEGI IP (NOT errorFlog) AND (NOT nodeEmpty(n)) THEN

IF nodeClass(n) <> nList THEN . . t ,».

MyTerminol.fatal(’genBlock: node class must be nList ).

ELSE

genStmts(n^

f reeNode

END;

END;

END genBlock;

PROCEDURE genGIoboI(s:symbol); initialize integers to 0, booleans

VAR nametstringType;

BEGIN , .

symbolString(8, nome);

IF symboILexLeveI(s) - 0 THEN wrIteStrIngLabeI(name);

WrIteStrIng(" 0"):

WriteLn;

ELSE M yTermlnal .WrlteStrlna("genGlobal: not o global: "):

MyTermtnal.fatal(name);

END;

END genGlobal;

^55“^ e (or FALSE. or KUL) .)

VAR I:CARDINAL;

BEGIN

FOR 1 1 TO numLocaIs(routine) DO

wr itelnt(0);

END;

END genLocaIs;

»0. oodo ompty. .)

BEGIN

IF NOT nodeEmpty(n) THEN

END;

END genStmts;

v » liwuvw» r v\"/ / \\

genStmt(nodeFIrst(n)); genStmts(nodeRest(n));

(*** Statements ***)

PROCEDURE genStmt(n:node);

BEGIN / X nr

CASE nodeCloss(n) OF nlf: genlfStmt(n);

| nWhlle: genWhileStmt(n);

nAssignment: genAssignStmt(n); I nCall; genCalIStmt(n);

20 BYTE LISTINGS SUPPLEMENT

nWrIt«: genWrlteStmt(n); nRead: genReadStmt(n); nReturn: genReturnStmt(n);

ELSE

MyTerminaI.fatal("genStmt:

END;

END genStmt;

unknown statement type");

PROCEDURE genIfStmt(n:node);

VAR label 1, Iabe12:IabeI;

BEGIN

I abe11 := newLabeIQ; genExpr(nodeTest(n)); wr IteCondBranch(Equal, label 1);

*)

genBlock(nodeThen(n));

IF nodeEmpty(nodeEIse(n)) THEN wr i teLabeI(IabeII);

ELSE

Iabe12 :* newLabeI(); wrIteBranch(Iabe12); wr IteLabeI(label 1); genBlock(nodeEIse(n)); wr IteLabeI(IabeI 2);

END;

END genlfStmt;

PROCEDURE genWhI IeStmt(n:node);

VAR testLabeI, endLabeI;IabeI;

BEGIN

testLabel :« newLabel();

endLabel ;* newLabelQ;

wrIteLabeI(testLabeI);

genExpr(nodeTest(n));

wrIteCondBranch(EquaI, endLabeI);

genBlock(nodeStmts(n));

wrIteBranch(testLabe I);

wr IteLabeI(endLabeI);

END genWhI IeStmt;

(* generate test *)

(* branch to else part If test false

(* generate then part *)

(* no else part *)

* branch around els part *)

* label for else part *)

* generate else part *)

(* final label *)

(* label for top of loop *)

(* generate test *)

(* if false, branch to end of loop *) (* generate loop body *)

* branch back to test *)

* end label *)

PROCEDURE genAssignStmt(n:node); BEGIN

genExpr(nodeRHS(n)}; wrItePop(nodeLHS(n));

END genAssIgnStmt;

PROCEDURE genCalI Stmt(n:node); BEGIN

genExprLIst(nodeArgs(n)}; wrIteCaI I(nodeRoutine(n)); END genCaIIStmt;

* generate the expression *)

* pop the result into the variable *)

* generate the arguments *)

* generate a call instruction *)

PROCEDURE genWrIteStmt(nmode);

(* Generate code to write the arguments to the screen. WRITE can take any number of arguments. *)

VAR argl 1st mode;

BEGIN

argl1st :* nodeArgs(n);

WHILE NOT nodeEmpty(argI 1st) DO genExpr(nodeFirst(arglist));

CASE nodeType(nodeFirst(argIist)) OF tlnteger: wrIteWritelnt;

| tChar: wrIteWrIteChar;

ELSE

MyTerminaI.fata I("genWriteStmt; iI legal type");

END;

arglIst :■ nodeRest(argI Ist) ;

END;

END genWriteStmt;

PROCEDURE genReadStmt(nmode);

(* Generate code to read from the terminal. READ can take any number of arguments. *)

VAR argl ist mode;

{continued)

BYTE LISTINGS SUPPLEMENT 21

BEGIN . .

arglist nodeArgsfn);

WHILE NOT nodeEmpty(orgl1st) DO

CASE nodeType(nodeFirst(argI 1st)) OF tlnteger: wr1teReadlnt;

I tChar: wrIteReadChar;

ELSE

MyTermlnaI.fatal("genReadStmt: Illegal type");

wr ItePop(nodeSymbol(nodeFirst(arglist)))* arglist nodeRest(argI Ist);

END;

END genReadStmt;

PROCEDURE genReturnStmt(n:node);

BEGI IF nodeEmpty(nodeExpr(n)) THEN (* o procedure return *) wrIteReturn(nodeNumFormaIs(n));

£LSE (* a function return *)

genExpr(nodeExpr(n)); writeFReturn(nodeNumFormaIs(n));

END;

END genReturnStmt;

(*** expressions ***)

PROCEDURE genExprLIst(nmode); VAR el mode;

BEGIN

el :* n;

WHILE NOT nodeEmpty(eI) DO

genExpr(nodeFirst(el)); el := nodeRest(el);

END;

END genExprList;

PROCEDURE genExpr(n;node);

BEGIN

CASE nodeCIass(n) OF

nUnop; genExpr(nodeArg(n));

wr1teOp(nodeOp(n));

| nOp: IF (nodeOp(n) » And) OR (nodeOp(n)

genLogicalOp(n);

ELSE , XN

genExpr(nodeLef tArg(n));

Or) THEN

genExpr ( nodeRightArg(n)); writeOp(nodeOp(n));

E ND; ,

nlnt: writeInt(nodeInt(n));

nBool: writeBooI(nodeBooI(n));

nChar; writeChar(nodeChar(n)); nSymbol:writeSymboI(nodeSymbol(n));

nCall: genCalIStmt(n); .

ELSE MyTerminal.fatal("genExpr; unknown expression type

END;

END genExpr;

PROCEDURE genLogicaIOp(nmode);

(* AND’s and OR’s end up here. We generate code to evaluate only the first

if possible. *)

VAR label 1, label2:label;

BEGIN

label 1 :■ newLabel();

Iabel2 :« newLabel();

IF n nodeOp(n) L = And^HEN (* we branch to FALSE if the first was FALSE *) ELSE W (i t tt < 's d ORrwe ( branch to^TRUE' I f the first was TRUE *)

wrIteCondBranch(Greater, label 1);

genExpr (nodeRIghtArg(n)); (* If the first one failed to decide, the val y of the 2nd is the value of the whole thing

*)

wrlteBranch(label2); wrIteLabeI(IabeII); wrIteBooI(nodeOp(n) *

Or); (* write TRUE If OR. FALSE if AND *)

22 BYTE LISTINGS SUPPLEMENT

January

writeLabeI(Iabe12); END genLogicalOp;

BEGIN

END CodeGen.

+++++++

Start CodeWrite.DEF

+++++++

DEFINITION MODULE CodeWrite;

(* This module outputs the code for the SIMPL compiler. *)

FROM Symbol IMPORT symbol;

FROM Token IMPORT tokenClass;

EXPORT QUALIFIED writeLabeI. writeStringLabeI, wr i teRoutineLabeI, writeHalt, writeStringBranch, writeBranch, writeCondBranch. writePop, writeCall, writeWritelnt, writeReadlnt, writeReturn, writeFReturn, writeOp, writelnt, writeBool, writeSymbol, writeChar, wr1teWriteChar, writeReadChar;

PROCEDURE writeLabeI(c:CARDINAL);

(* Writes an "L" followed by the number, then a colon. *)

PROCEDURE wrIteStringLabeI(s:ARRAY OF CHAR);

(* Just writes the string followed by a colon. *)

PROCEDURE writeRoutineLabeI(routineisymbol);

(* Writes the name of the routine followed by a colon, and writes (on the screen) the procedure name so the user knows it's being compiled. *)

PROCEDURE writeStringBranch(s: ARRAY OF CHAR);

(* Write a branch followed by the string *)

PROCEDURE writeCondBranch(tc:tokenCI ass; c:CARDINAL);

(* Write a conditional branch (Equal, Greater or Less) followed by "L", then the number. *)

PROCEDURE writeBranch(c:CARDINAL);

(* Write an unconditional branch to the label. *)

PROCEDURE writePop(s:symboI);

(* Generate the appropriate pop instruction for the symbol *)

PROCEDURE writeCalI(s:symbol);

(* Generate a call instruction with the symbol *)

PROCEDURE wrIteWritelnt;

PROCEDURE writeReadlnt;

PROCEDURE wrIteWrIteChar;

PROCEDURE writeReadChar;

(* instructions for I/O *)

PROCEDURE wrIteReturn(numFormaIs:CARDINAL);

PROCEDURE writeFReturn(numFormaIs:CARDINAL);

(* Two types of return instructions; both take the number of formals as arg. *)

PROCEDURE wrIteOp(tc:tokenCI ass);

(* Write the instruction corresponding to the operator *)

PROCEDURE writelnt(i;INTEGER);

PROCEDURE writeBooI(b:BOOLEAN);

PROCEDURE writeChar(c:CHAR);

(* Write pushes for these constants. *)

PROCEDURE writeSymboI(s:symboI);

(* Generate the appropriate push instruction for the symbol *)

PROCEDURE writeHalt;

( continued )

BYTE LISTINGS SUPPLEMENT 23

Chapter Notes

SRM70O

Guide to Part 2 of the SIMPL Compiler

This code accompanies part 2 of "A SIMPL Compiler." It includes Modula-2 source code for the entire SIMPL Compiler. You will need the Monitor program from Building a Computer in Software (October

*85) and the VM2 Assembler (November *85). There are 12 modules to the compiIer:

CodeGen

CodeWrlte

Compiler (MOD file only)

ExprParser

LexAn

Node

Parser

Routines

SymboI

SymboI Tab Ie

Token

TypeChecker

I anuary

END CodeWrIte.

+++++++

Start CodeWrite.MOD +++++++

IMPLEMENTATION MODULE CodeWrite:

FROM InOut IMPORT WrlteStrlng, WrlteLn. Wrltelnt.WrlteCard;

(* We can't use Write because of a conflict Inside t^^lass FROM Symbol IMPORT symboI, symbolstring, symboILexLeveI, symbolOffset; FROM SymboI Table IMPORT currentLexLevel;

FROM Token IMPORT tokenClass. stringType;

IMPORT MyTerminal;

PROCEDURE wrtteStrtngLabel(s:ARRAY OF CHAR):

BEGIN

WrlteStrlng(s):

WrIteStrIng(’: ');

END wrIteStrIngLabeI:

PROCEDURE wr11eRou11neLabeI(rout Ine:symboI);

VAR nomerstringType;

BEGIN / . t \ wr iteRoutlneName(routine);

Wr iteString(*: ');

WrlteLn;

symboI Strlng(routine, name);

MyTerminal.WriteStrIng(name);

MyTerminaI.WriteLnString;

END writeRoutineLabeI;

PROCEDURE writeRoutineName(routine:symboI);

VAR name:stringType;

BEGIN x

symboI String(routine, name);

WrIteStrIng(name);

IF symboILexLeveI(routine) <> 0 THEN

WriteInt(symboIOffset(routine), 0);

END;

END writeRoutineName;

PROCEDURE wr i teLabe I (c -.CARDINAL) ;

BEGIN

WriteChar(’L’):

WriteCard(c, 0);

WriteChar(*:*);

Wr 1 teLn;

END writeLabeI;

PROCEDURE writeStringBranch(s:ARRAY OF CHAR);

BEGIN

wr iteOpCode('BRANCH );

Wr I teLnString(s):

END writeStringBranch;

PROCEDURE writeBranch(crCARDINAL):

BEGIN

wrIteOpCode(*BRANCH L );

WriteCard(c, 0);

WriteLn;

END writeBranch;

PROCEDURE writeCondBranch(tc:tokenCI ass; c:CARDINAL);

BEGIN

CASE tc OF , , iN

Equal: writeOpCodef'BREQL L );

I Less: writeOpCode(’BRLSS L’);

Greater:writeOpCode(*BRGTR L*);

ELSE

MyTerminol.fataI(’wrIteCondBranch: unknown branch type’);

END;

WrIteCard(c, 0);

WrlteLn;

END writeCondBranch;

PROCEDURE writeWritelnt;

24 BYTE LISTINGS SUPPLEMENT

BEGIN

wr iteOpCode('WRINT*);

Wr iteLn;

END writeWritelnt;

PROCEDURE writeReadlnt;

BEGIN

writeOpCode('RDINT');

Wr IteLn;

END writeReadlnt;

PROCEDURE writeWriteChar;

BEGIN

wr it eOpCode(* WRCHAR *);

Wr iteLn;

END wr iteWriteChar;

PROCEDURE writeReadChar;

BEGIN

wr iteOpCode('RDCHAR');

Wr i teLn;

END writeReadChar;

PROCEDURE writeHalt;

BEGIN

wr 1teOpCode('HALT*);

Wr iteLn;

END writeHaIt;

PROCEDURE writeReturn(numFormaIs:CARDINAL);

BEGIN

writeOpCode(’RETURN ’);

WriteCard(numFormaI 8, 0);

WriteLn;

END wr1teReturn;

PROCEDURE writeFReturn(numFormaIs:CARDINAL);

BEGIN

wr IteOpCode('FRETURN ');

WrlteCard(numFormaIs, 0);

Wr iteLn;

END writeFReturn;

PROCEDURE writelnt(i:INTEGER);

BEGIN

writeOpCode('PUSHC ’);

Writelnt(i, 0);

Wr iteLn;

END writelnt;

PROCEDURE wri teChar(c:CHAR);

BEGIN

wr iteOpCode('PUSHC ');

WriteCharf.);

Wr 1 teChar(c);

Wr iteLn;

END writeChar;

PROCEDURE writeBooI(b:BOOLEAN);

BEGIN

IF b THEN

wrltelnt(l);

ELSE

wr i telnt(0);

END;

END writeBooI;

PROCEDURE wr1tePop(s:symboI);

BEGIN

wrlteSymAddr(s, 'POPC \ ’POPL *);

END wr1tePop;

PROCEDURE writeCalI(s:symbol);

BEGIN

writeOpCode("CALL M );

(continued)

BYTE LISTINGS SUPPLEMENT 25

January

writeRoutineName(s);

WriteString(", ");

WrI taint(currentLexLeveI() - symboILaxLavaI(s), 0); WrItaLn;

END wrItaColI;

PROCEDURE writaSymboI(s:symboI);

BEGIN

wr1taSymAddr(s, "PUSH \ "PUSHL ");

END writaSymboI;

PROCEDURE wrItaSymAddr(s:symboI; global, local:ARRAY OF CHAR); VAR nama:strIngTypa;

BEGIN

IF symboILaxLavaI(s) * 0 THEN (* global variable *)

symboI String(s, name); writeOpCode(globaI);

WrIteLnString(name);

ELSE

wr IteOpCode(locaI);

Wr i taint(currentLexLeveI() - symboILexLeveI(s), 0); WriteStringC, ’);

WrItelnt(symbol0ffset(s), 0); symbolString(s, name); wr i teComment(name);

END;

END writaSymAddr;

PROCEDURE wrIteOp(tc:tokenCI ass); BEGIN

CASE tc OF

Plus:

writeOpCode(’ADD’);

Minus:

writeOpCode(’SUB’);

UMinus:

wr iteOpCode(’NEG*);

Times:

writeOpCode(’MUL');

Divide:

writeOpCode(’DIV’);

Not:

writeOpCodef’NOT');

Equal:

wrlteOpCode(’EQUAL');

Greater:

writeOpCode(’GREATER’);

Less:

writeOpCodef’LESS’);

NotEqual:

writeOpCode(’NOTEQL *);

LessEqua1:

writeOpCode('LSSEQL*);

GreaterEqua1

: writeOpCode(’GTREQL’);

ELSE MyTermina1.

fata 1("wr1teOp: unknown operator

Table captionEND;

Wr iteLn; END writeOp;

);

PROCEDURE WriteLnString(s:ARRAY OF CHAR); BEGIN

Wr 1 teString(s);

Wr i teLn;

END WriteLnString;

PROCEDURE WriteChor(c:CHAR);

(* can’t use InOut.Write, because the name conflicts with the Write in tokenClass. *)

VAR s:ARRAY[0..1J OF CHAR;

BEGIN

5 L I J . ,

WriteString(s); END WriteChar;

PROCEDURE writeOpCode(s:ARRAY OF CHAR); BEGIN

WriteString(" ");

WriteStrlng(s);

END writeOpCode;

PROCEDURE writeComment(s:ARRAY OF CHAR); BEGIN

Wr iteStringf" ; ");

WriteString(s);

Wr iteLn;

END writeComment;

26 BYTE LISTINGS SUPPLEMENT

1

January

BEGIN

END CodeWrite.

+++++♦+

Start Comp 1 ler.MOD ++♦++++

MODULE Comp Iler;

(* A compiler for the SIMPL programming language.

Copyright 1985 By Jonathan Amsterdam.

See the BYTE article "A SIMPL Compiler" for more information.

Table captionModule map, roughly in order of low to high level:

CharStuff StrlngStuff previous

MyTermina1 LexAnStuff

Low-level character utilities \

Low-level string utilities

Low-level terminal I/O utilities |

Toolkit for building lexical analyzers /

used in

projects

Token

Symbo1

Node

Token, tokenList and typeType data types Symbol, symbolLlst and related data types Node and related data types

TypeChecker

LexAn

Symbo1 Tab 1e

CodeWrite

CodeGen

Procedures to do type-checking

Lexical analyzer for compiler

Compiler symbol table

Actual output of code

Code generation

ExprParser Routines Parser

Parses expressions

Parses procedure and function declarations Main parser

The module Debug, also supplied, is not used by the compiler, but contains routines useful in debugging the compiler.

I would appreciate hearing about any bugs in the code. My BIX address is jba. —Jonathan Amsterdam

*)

FROM InOut IMPORT Openlnput, OpenOutput, Closelnput, CloseOutput;

FROM MyTerminal IMPORT ClearScreen, pause, WriteLnString;

FROM Parser IMPORT program;

BEGIN

ClearScreen;

WriteLnStrIng("SIMPL Compiler VI.0");

Openlnput(’SMP’);

OpenOutput(’ASM');

program;

Closelnput;

CloseOutput; pause('Done—*);

END Compiler.

+++++++

Start ExprParser.DEF +++++++

DEFINITION MODULE ExprParser;

(* The part of the parser that handles expressions.

Syntax:

<expr>::* <expr>|<relexpr> | <relexpr> OR <expr> | <relexpr> AND <expr> <relexpr> ::■ <intexpr> | <lntexpr> <relation> <intexpr>

<intexpr> ::- <term> | <term> + <intexpr> | <term> - <intexpr>

<term> ::- <factor> | <factor> * <term> | <factor> / <term>

<factor> <ld> | <number> | <ca11> | <char>

- <factor> | NOT <factor> | ( <expr> )

*)

FROM Node IMPORT node;

(continued)

BYTE LISTINGS SUPPLEMENT 27

EXPORT QUALIFIED expr;

PROCEDURE expr():node;

END ExprParser.

+++++++

Start ExprParser.MOD ++♦++++

IMPLEMENTATION MODULE ExprParser;

(* Handles parsing of expressions, which are tricky because we have to

make the operators left-associative, whereas the normal recursive descent grammar would have them be right-associative.

The problem is that the trees are build from the right. To make them get built from the left, we pass to expr, relexpr, intexpr and term the partial tree constructed from the left, and each of these procedures hooks that tree on to the one It parses in the appropriate way. *)

FROM Token IMPORT token, tokenClass, IsRelation;

FROM LexAn IMPORT getToken, ungetToken, tokenErrorCheck. compError;

FROM Symbol IMPORT symbol, SymbolClass. symbo1C IassEquaI;

FROM SymboI Table IMPORT findSymbol;

FROM Node IMPORT node, emptyNode, makeOpNode, makeUnopNode, makelntegerNode, makeBooleanNode, makeSymbolNode, makeCaI INode, makeStringNode, nodeEmpty, makeCharNode;

FROM Parser IMPORT actuals;

CONST dummy « Period;

(* <expr>::- <expr>|<relexpr> | <relexpr> OR <expr> | <relexpr> AND <expr> *) PROCEDURE expr()inode;

BEGIN

RETURN expr1(emptyNode, dummy);

END expr;

PROCEDURE expr1(I eft inode; opitokenClass)inode;

VAR ninode;

titoken;

BEGIN

n :« relexpr(); getToken(t);

IF (t.class « And) OR (t.class ■ Or) THEN

RETURN expr1(bulldTree(op, left, n), t.class);

ELSE

ungetToken;

IF nodeEmpty(Ieft) THEN RETURN n;

ELSE

RETURN makeOpNode(op, left, n);

END;

END;

END exprl;

(* <reIexpr> <tntexpr> | <intexpr> <relation> <intexpr> *)

PROCEDURE re Iexpr()inode;

(* Here we don't have to worry about associativity since relations aren't associativel *)

VAR ninode;

titoken;

BEGIN

n i« intexpr(emptyNode, dummy); getToken(t);

IF IsRelation(t.class) THEN

RETURN makeOpNode(t.class, n, intexpr(emptyNode, dummy));

ELSE

ungetToken;

RETURN n;

END;

END relexpr;

(* <!ntexpr> <term> | <term> + <intexpr> | <term> - <intexpr> *) PROCEDURE intexpr(left inode; op:tokenClass)inode;

VAR n:node; titoken;

28 BYTE LISTINGS SUPPLEMENT

BEGIN

n :« term(emptyNode, dummy); getToken(t);

IF (t.class « Plus) OR (t.class « Minus) THEN

RETURN intexpr(buildTree(op, left, n), t.class);

ELSE

ungetToken;

IF nodeEmpty(left) THEN RETURN n;

ELSE

RETURN makeOpNode(op, left, n);

END;

END;

END Intexpr;

(* <term> ;<factor> | <factor> * <term> | <factor> / <term> *)

PROCEDURE term(I eft mode; op:tokenClass):node;

VAR n:node;

t:token;

BEGIN

n :* factor(); getToken(t);

IF (t.class ** Times) OR (t.class « Divide) THEN RETURN term(buildTree(op, left, n), t.class);

ELSE

ungetToken;

IF nodeEmpty(left) THEN RETURN n;

ELSE

RETURN makeOpNode(op, left, n);

END;

END;

END term;

(* <factor> <id> | <number> | <caI I> | <char> | - <factor> | NOT <factor>

( <«xpr> ) *)

PROCEDURE factor():nod«;

VAR ninode;

trtoken;

BEGIN

getToken(t);

CASE t.cl ass OF

Int: RETURN makeIntegerNode(t.integer);

Character: RETURN makeCharNode(t.ch);

String: RETURN makeStringNode(t.string);

Minus: RETURN makeUnopNode(UMinus, factor());

Not: RETURN makeUnopNode(Not, factor());

True: RETURN makeBooIeanNode(TRUE);

False: RETURN makeBooIeanNode(FALSE);

Lparen:

n :- expr();

tokenErrorCheck(Rparen, ’Right paren expeced');

RETURN n;

| Identifier: RETURN callOrld(t);

ELSE

compError(’bad factor’);

RETURN emptyNode;

END;

END factor;

PROCEDURE calI0rld(t:token):node;

VAR sisymboI;

BEGIN

8 :- findSymbol(t.string);

IF symbolClassEqual(s, Func) THEN

RETURN makeCaI INode(s, actuals());

ELSIF symboICIassEquaI(s, Proc) THEN

compError(’procedures cannot be used in an expression');

RETURN emptyNode;

ELSE (* it’s a variable *)

RETURN makeSymboINode(s);

END;

END callOrld;

[continued)

BYTE LISTINGS SUPPLEMENT 29

PROCEDURE billldTree(op:tokenClass; nl, n2:node):node;

(* This Is the key hack that builds trees up from the left if necessary. *) BEGIN

IF nodeEmpty(n1) THEN RETURN n2;

ELSE

RETURN makeOpNode(op, nl, n2);

END;

END bulIdTree;

BEGIN

END ExprParser.

+++++++

Start LexAn.DEF +++++++

DEFINITION MODULE LexAn;

(* The lexical analyzer for the SIMPL compiler. It uses the InOut module do Input, so you can get input from a file by redirecting it with InOut.Openlnput.

This module also handles errors. *)

FROM Token IMPORT token, tokenClass;

EXPORT QUALIFIED getToken, ungetToken, getTokenCI ass, tokenErrorCheck, getTokenErrorCheck, errorFlag, compError, peekTokenCI ass;

VAR errorFIag:BOOLEAN; (* Set to TRUE when an error occurs. *)

PROCEDURE getToken(VAR t:token);

(* Get a token from the input stream. *)

PROCEDURE ungetToken;

(* Push a token back on the input stream. Can only unget one at a time. *) PROCEDURE getTokenCIass():tokenClass;

(* Get a token from the input stream, but Just return its class. *)

PROCEDURE peekTokenCI ass():tokenCI ass;

(* Get a token from the input stream, unget it, and return its class. *)

PROCEDURE tokenErrorCheck(tc:tokenClass; msg: ARRAY OF CHAR);

(* Read a token from the input stream and compare its class to tc. If they are the same, do nothing. If they are different, write the current line to the screen, print the message and unget the token. *)

PROCEDURE getTokenErrorCheck(VAR trtoken; tc:tokenCI ass; msg: ARRAY OF CHAR); (* Like tokenErrorCheck. but returns the token as well. *)

PROCEDURE compError(msg:ARRAY OF CHAR);

(* Writes the current line and displays msg. Sets errorFlag to TRUE. *)

END LexAn.

+++++++

Start Lexan.MOD +++++++

IMPLEMENTATION MODULE LexAn;

(* Lexical analyzer for the SIMPL compiler. Uses the routines in LexAnStuff.*)

FROM InOut IMPORT EOL;

FROM Token IMPORT token, tokenClass;

FROM MyTerminal IMPORT fatal, WriteLnString;

FROM StringStuff IMPORT stringLen;

FROM Symbol Table IMPORT enterKeyword, findKeyword;

FROM LexAnStuff IMPORT dispatch, enterAII, enterChar, enterEndOfFiIe, ignore, enterAlphas, enterDigits, skipToChar, a IphaNumString, poslnteger, string, enterWhite, writeLine, getChar, ungetChar;

VAR tok: token;

ungotten: BOOLEAN;

30 BYTE LISTINGS SUPPLEMENT

January

PROCEDURE getToken(VAR t:token);

BEGIN

getTok; t := tok;

END getToken;

PROCEDURE getTok;

VAR c:CHAR;

BEGIN

IF ungotten THEN

ungotten := FALSE;

ELSE

dispatch;

END;

END getTok;

PROCEDURE ungetToken;

BEGIN

IF ungotten THEN

fata I("ungetToken: can only unget one token at a time");

ELSE

ungotten := TRUE;

END;

END ungetToken;

PROCEDURE getTokenCI ass():tokenClass;

BEGIN

getTok;

RETURN tok.cI ass;

END getTokenCIass;

PROCEDURE peekTokenCIass():tokenCI ass;

BEGIN

getTok; ungetToken;

RETURN tok.cl ass;

END peekTokenCIass;

PROCEDURE tokenErrorCheck(tc:tokenCI ass; msg: ARRAY OF CHAR);

BEGIN

getTok;

IF tok.class <> tc THEN compError(msg);

IF tok.class * EndOflnput THEN

fata I("unexpected end of input");

END;

ungetToken;

END;

END tokenErrorCheck;

PROCEDURE getTokenErrorCheck(VAR titoken; tc:tokenClass; msg: ARRAY OF CHAR); BEGIN

tokenErrorCheck(tc, msg); t := tok;

END getTokenErrorCheck;

(*** reading procedures ★**)

PROCEDURE iI IegaIChar(c:CHAR);

VAR charstrlng:ARRAY[0..1] OF CHAR;

BEGIN

charstringT01 :* c; (* fake a 1-char string *)

charstring[1] :• 0C;

compError(*iI IegaI character*);

getTok;

END iIlegalChar;

PROCEDURE comment(c:CHAR); (* Comments are ignored. They are delimited

by { and } *)

BEGIN

skIpToChar(*|*); getTok;

END comment;

(continued)

BYTE LISTINGS SUPPLEMENT 31

I anuary

PROCEDURE 1dOrKeyword(c:CHAR);

(* Get an alphanumeric string from the Input. If we find It In the symbol

table marked as a keyword, then It’s a keyword; findKeyword will have taken care of setting tok.class to the right value. Else, it's an identifier. *) BEGIN

IF NOT a IphaNumString(c, tok.string} THEN compError(*identifier too long*);

END;

IF NOT findKeyword(tok.string, tok.class) THEN tok.class :■ Identifier;

END;

END idOrKeyword;

PROCEDURE poslnt(c:CHAR);

BEGIN

tok.class :« Int;

tok.Integer :* poslnteger(c);

END poslnt;

PROCEDURE charProc(c:CHAR);

(* Read a character, delimited by delim, from the input. Can use backslash: \n * newline, \t ■ tab, anything else literal. *)

BEGIN

tok.class :■ Character;

IF (NOT str I na(c, tok.string)) OR (stringLen(tok.string) > 1) THEN compError(* I I IegaI character constant*);

END;

tok.ch tok.string[0];

END charProc;

PROCEDURE stringProc(c:CHAR);

(* Read a string from the input. If too long, skip to the next delim. *) BEGIN

tok.class := String;

IF NOT strlngfc, tok.string) THEN compError(*string too long*); skipToChar(c);

c getChar(); (* get the delimiter *)

END;

END stringProc;

(*** Reading special characters ***)

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

period(c:CHAR); semicoI on(c:CHAR) equal(c:CHAR); comma(c:CHAR); plus(c:CHAR); minus(c:CHAR); times(c:CHAR); dividefc:CHAR);

Iparen(crCHAR); rparen(c:CHAR);

BEGIN tok.class ;BEGIN tok.class BEGIN tok.class BEGIN tok.class BEGIN tok.class BEGIN tok.class BEGIN tok.class BEGIN tok.class BEGIN tok.cl ass BEGIN tok.class

:= Period;

:= Semicolon; :* EquaI;

:» Comma;

:= Plus;

:= Minus;

:= Times;

:= Divide;

:*= Lparen;

:= Rparen;

PROCEDURE greater(c:CHAR);

BEGIN

IF getChar() - *»* THEN

tok.class :* GreaterEquaI;

ELSE

ungetChar;

tok.cI ass :* Greater;

END;

END greater;

Table captionPROCEDURE I ess(c:CHAR); BEGIN

Table captionc :* getChar();

Table captionIF c » ’-* THEN

tok.c1 ass

:« LessEqual

ELSIF c * *>*

THEN

tok.c1 ass

:= NotEqua1;

ELSE

ungetChar; tok.c1 ass

i

:« Less;

END;

END less;

END period;

END semicolon; END equaI;

END comma;

END plus;

END minus;

END times;

END divide;

END lparen; END rparen;

Table caption32 BYTE LISTINGS SUPPLEMENT

PROCEDURE colon(c:CHAR);

BEGIN

IF getChar() - THEN

tok.class :* Assignment;

ELSE

ungetChar;

tok.class :» Colon;

END;

END colon;

PROCEDURE endOfInput(c:CHAR); BEGIN

tok.class :* EndOflnput;

END endOflnput;

(*** Initialization of charTable ***)

PROCEDURE initCharTabIe;

BEGIN

enterAI I(iI IegaI Char); enterWhite(ignore); enterAIphasSidOrKeyword); enterDigits(poslnt); enterCharS’.*, period); enterChar(’:*, colon); enterChar S*; *, enterChar( 1 (*, enterChar(*)*, enterChar(•,*, enterChar

semicolon);

Iparen); rparen); comma); equaI);

enterChar(’>’, greater); enterCharS*<’, less); enterCharS’ + ', plus); enterCharS, minus); enterCharS’*', times);

enterChar(V*• divide);

enterCharS'\' , comment); enterCharS "", stringProc); enterChar("•", charProc); enterEndOfFlIe(endOfInput); END initCharTobIe;

PROCEDURE enterKeywords;

BEGIN

enterKeyword(*AND*, And); enterKeywordS'BEGIN*, Begin); enterKeywords’BOOLEAN*, Boo Iean); enterKeywordS’CHAR', Char); enterKeywords’DO’, Do); enterKeywordS’ELSE*, Else); enterKeywords’ELSIF', Elsif); enterKeywordS’END’, End); enterKeywords’FALSE', False); enterKeywordf’FUNCTION’, Function); enterKeywords'IF’, If); enterKeywordS * INTEGER*, Integer); enterKeywordC’NOT*, Not); enterKeywords’OR’, Or); enterKeywords'PROCEDURE’, Procedure); enterKeywords’PROGRAM*, Program); enterKeywords’READ’, Read); enterKeywordS’RETURN’, Return); enterKeywords’THEN*, Then); enterKeywordS’TRUE’, True); enterKeywords’VAR*, Var); enterKeywords’WHILE’, While); enterKeywords’WRITE*, Write);

END enterKeywords;

(*** errors ***)

PROCEDURE compError(msg:ARRAY OF CHAR);

BEGIN

wr1teL1ne;

Wr1teLnString(msg);

(< continued)

BYTE LISTINGS SUPPLEMENT 33

errorFlag :■ TRUE; END compError;

BEGIN

ungotten :■ FALSE; errorFlag FALSE; InltCharTable; enterKeywords;

END LexAn.

+++++++

Start Node.DEF

+++++++

DEFINITION MODULE Node;

(* Nodes are what make up the parse tree produced by the SIMPL parser.

They consist of all data relevant to generating code. *)

FROM Token IMPORT tokenClass, typeType;

FROM Symbol IMPORT symbol;

EXPORT QUALIFIED node, nodeClass, NodeClass, emptyNode, nodeEmpty, freeNode, makeStmtsNode, makelfNode, makeWhiIeNode, makeReturnNode, makeAssignmentNode, makeExprLIstNode, makeOpNode, makeUnopNode, makelntegerNode, makeBooIeanNode, makeSymboI Node, makeCaI I Node, makeWriteNode, makeReadNode, makeStringNode, makeCharNode, nodeFIrst, nodeRest, nodeTest, nodeThen, nodeElse, nodeStmts, nodeRHS, nodeLHS, nodeArgs, nodeRoutine, nodeExpr, nodeArg, nodeLeftArg, nodeRightArg, nodeOp, nodeSymbol, nodeType, nodelnt. nodeBool, nodeNumFormaIs, nodeString, nodeChar;

TYPE

NodeClass * (*

(nOp,

*)

nUnop, nBooI , nlnt, nChar, nString, nSymboI, nlf, nWhiIe, nReturn, nCaI I,

nAssignment, nWrlte, nRead, nList);

node;

VAR emptyNode: node;

PROCEDURE nodeCI ass(n:node):NodeClass;

(* Returns the class of node *)

PROCEDURE nodeEmpty(n:node)-.BOOLEAN;

(* Returns true if node is the emptyNode *)

PROCEDURE freeNode(n:node);

(* Frees the storage associated with n *)

(*** Node creation ***)

PROCEDURE makeStmtsNode(f1rst, rest:node):node;

(* Make a node representing a list of statements *)

PROCEDURE makeReturnNode(routine:symbol; returnExpr:node):node;

(* Make a return node. Routine is the routine we are returning from.

returnExpr is an expression to be returned, for functions; for procedures, it should be the empty node. *)

PROCEDURE makeCaI I Node(name:symboI; actuals:node):node;

PROCEDURE makeWrIteNode(actuaIs:node):node;

PROCEDURE makeReadNode(actuaIs:node):node;

(* In all of these, actuals should have been made with makeExprListNode. *)

different kinds of nodes *)

(* binary operators (+, -, *, /, relations, AND, OR)

I * unary operators (unary minus, NOT) *)

♦ a boolean constant (TRUE, FALSE) *)

* an integer constant *)

* a character constant *)

* a string constant *)

♦ a symbol (variable) *)

* IF statement *)

* WHILE statement *)

* RETURN statement, either procedure or function *) * procedure call (statement) or function call *)

! * assignment statement *)

* WRITE and READ statements *)

(* a list of statements or expressions *)

34 BYTE LISTINGS SUPPLEMENT

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

makelfNode(test, then, e I se mode) mode;

makeWhileNode(test, stmts:node)mode;

makeAssignmentNode(var :symboI; expr mode)mode;

makeExprListNode(first, rest mode)mode;

makeOpNode(op;tokenCIass; leftarg, r i ghtarg mode) mode;

makeUnopNode(op: tokenCI ass; argmode) mode;

makeIntegerNode(I:INTEGER):node;

makeBooIeanNode(b:BOOLEAN)mode;

makeSymboINode(idisymbol):node;

makeStrIngNode(s;ARRAY OF CHAR)mode;

makeCharNode(c:CHAR)mode;

(*** Accessing parts of nodes **)

(* many nodes have a type associated with them *) PROCEDURE nodeType(nmode):typeType;

(* for constants *)

PROCEDURE nodelnt(n:node):INTEGER;

PROCEDURE nodeBooI(n mode):BOOLEAN;

PROCEDURE nodeChar(nmode):CHAR;

PROCEDURE nodeString(n:node; VAR s:ARRAY OF CHAR); (* Just truncates is s is too short. *)

(* for 11sts *)

PROCEDURE nodeF i rst (n mode) mode; PROCEDURE nodeRest (n mode) mode;

(* for IF statements *)

PROCEDURE nodeTest (n mode) mode; PROCEDURE nodeThen(nmode) mode; PROCEDURE nodeEIse(nmode)mode;

(* for WHILE statements *)

PROCEDURE nodeStmts(nmode) mode;

(* for assignment statements *) PROCEDURE nodeRHSfn mode) mode; PROCEDURE nodeLHS(nmode):symboI;

(* for calls *)

PROCEDURE nodeArgs(n:node):node; PROCEDURE nodeRout ine(nmode) isymbol;

(* also for WHILE statements *)

* right-hand side *)

* left-hand side *)

(* for RETURN statements *)

PROCEDURE nodeExpr(n:node):node;

PROCEDURE nodeNumFormaIs(n;node):CARDINAL;

(* for ops and unops *)

PROCEDURE nodeArg(nmode)mode; PROCEDURE nodeLeftArg(nmode)mode; PROCEDURE nodeRightArg(nmode)mode; PROCEDURE nodeOp(n;node):tokenClass;

(* for symbols *)

PROCEDURE nodeSymbol(nmode):symboI; END Node.

+++++++

Start Node.MOD +++++++

IMPLEMENTATION MODULE Node;

(* Procedures for constructing and manipulating the nodes of the parse tree.

Most type-checking is done here. *)

FROM Token IMPORT tokenClass, typeType, stringType, isRelation;

FROM Symbol IMPORT symbol, Symbo1C I ass, symboI Type, emptySymbol, numFormals; FROM Storage IMPORT ALLOCATE, DEALLOCATE;

FROM TypeChecker IMPORT typeCompatibIe, opAppropriate, callCheck, unopCheck, readCheck, wrlteCheck, binopCheck, returnCheck, assignCheck;

FROM MyTermlnal IMPORT Wr1teString, fatal;

FROM StringStuff IMPORT stringCopy;

( continued )

BYTE LISTINGS SUPPLEMENT 35

TYPE

node ■ POINTER TO nodeRec; nodeRec ■ RECORD

type: typeType;

CASE clas8:NodeCloss OF

nOp: op: tokenClase; leftArg, rlghtArg: node;

nUnop: unop: tokenClase; arg: node;

nBool: bool: BOOLEAN;

nlnt: Int: INTEGER;

nChar: ch: CHAR;

nStrIng: str lng:strIngType;

nSymbol: eym: symbol;

nlf: test, then, else: node;

nWhlle: wtest, stmts: node;

nAssignment: LHS: symbol; RHS:node;

nCall, nWrlte, nRead: rout Ine:symboI; args:node;

nReturn: nFormaIs:CARDINAL; expr:node;

nLlst: first, rest:node;

END;

END;

PROCEDURE nodeCloss(n:node):NodeClass;

BEGIN

RETURN n^.class;

END nodeClass;

PROCEDURE nodeEmpty(n:node):BOOLEAN;

BEGIN

RETURN n « emptyNode;

END nodeEmpty;

PROCEDURE freeNode(n:node);

BEGIN

IF n <> emptyNode THEN

WITH n* DO CASE class OF

nlnt, nBool, nSymbol, nString, nChor: (* do nothing *); | nOp: freeNode(leftArg);

freeNode(rIghtArg); nUnop: freeNodefarg);

nlf: freeNodeitest);

freeNodefthen); freeNode(eIse);

| nWhlle: freeNodefwtest);

freeNode(stmts); nAssIgnment: freeNode(RHS); nCall, nRead, nWrite: freeNode(args); nReturn:freeNodefexpr); nLlst: freeNode(fIrst);

freeNode(rest);

ELSE

WrIteString("freeNode: unknown node type");

END; END;

DISPOSE(n); (* , n".class); *)

END;

END freeNode;

(*** node creation ***)

PROCEDURE makeStmtsNode(fIrst, rest:node):node;

VAR n:node;

BEGIN

n :* newNode(nLlst); n^.first :- first; n^.rest :- rest;

RETURN n;

END makeStmtsNode;

PROCEDURE makeExprListNode(first, rest:node):node; VAR n:node;

BEGIN

n :* newNode(nLIst); n^.f1rst :* first; n^.rest :- rest;

RETURN n;

END makeExprLIstNode;

36 BYTE LISTINGS SUPPLEMENT

January

PROCEDURE makeIfNode(test, then, else:node):node;

VAR n:node;

BEGIN

n i® newNode(nIf); n^.test i« test; n^.then ;* then; n^.else i« else;

RETURN n;

END makelfNode;

PROCEDURE makeWhIIeNode(test, stmts:node):node;

VAR n:node;

BEGIN

n ;* newNode(nWhiIe); n^.wtest ;* test; n A .stmts ;■ stmts;

RETURN n;

END makeWhIIeNode;

PROCEDURE makeReturnNode(routIne:symboI; returnExpr:node):node;

VAR ninode;

BEGIN

n ;« newNode(nReturn); n^.expr :® returnExpr;

IF returnCheck(routIne, returnExpr) THEN n^.nFormals i® numFormaIs(routIne);

END;

RETURN n;

END makeReturnNode;

PROCEDURE makeAssIgnmentNode(var:symboI; exprinode)inode;

VAR ninode;

BEGIN

n i* newNode(nAssignment); n^.LHS i® var; n^.RHS i® expr; assignCheck(var, expr);

RETURN n;

END makeAssignmentNode;

PROCEDURE makeOpNode(opitokenClass; leftarg, rightarginode)inode;

VAR ninode;

typeOKiBOOLEAN;

BEGIN

n i® newNode(nOp); n*.op i® op; n^.leftArg i* leftarg; n^.rlghtArg i® rlghtarg;

typeOK i® blnopCheck(op, leftarg, rlghtarg);

IF isReI atlon(op) THEN n^.type ;® tBoolean;

ELSIF typeOK THEN

n^.type i® leftarg^.type;

ELSE

n^.type i« tUnknown;

END;

RETURN n;

END makeOpNode;

PROCEDURE makeUnopNode(op;tokenClass; arg;node);node;

VAR ninode;

BEGIN

n i® newNode(nUnop); n^.unop i® op; n^.arg :■ arg;

IF unopCheck(op, arg) THEN n^.type ;® arg A .type;

ELSE

n^.type ;■ tUnknown;

END;

RETURN n;

END makeUnopNode;

PROCEDURE makeIntegerNode(I:INTEGER)inode;

VAR ninode;

(continued)

BYTE LISTINGS SUPPLEMENT 37

I anuary

BEGIN

n :* newNode(nInt); n*.type :» tlnteger; n^.int I;

RETURN n;

END mokelntegerNode;

PROCEDURE makeBooIeanNode(b:BOOLEAN):node;

VAR n:node;

BEGIN

n :■ newNode(nBooI); n^.type :« tBoolean; n^.bool :« b;

RETURN n;

END makeBooIeanNode;

PROCEDURE makeCharNode(c:CHAR):node;

VAR n:node;

BEGIN

n :* newNode(nChar); n^.type :■ tChar; n^.ch :■ c;

RETURN n;

END makeCharNode;

PROCEDURE makeSymboI Node(s:symboI)inode;

VAR n:node;

BEGIN

n :■ newNode(nSymboI); n^.type symboIType(s); n^.sym :■ s;

RETURN n;

END makeSymboI Node;

PROCEDURE makeCal INode(name:symbo I ; actuaI s inode) -.node VAR n:node;

BEGIN

n :* newNode(nCaI I);

WITH n~ DO

routine name;

args :■ actuals;

type :* symboIType(name};

calICheck(routine, args);

END;

RETURN n;

END makeCalINode;

PROCEDURE makeWrlteNode(actuaIs:node):node;

VAR n:node;

BEGIN

wrIteCheck(actuaIs); n :■ newNode(nWrIte); n*.routine :* emptySymbol; n^.args :■ actuals;

RETURN n;

END makeWrIteNode;

PROCEDURE makeReadNode(actuaIs:node):node;

VAR n:node;

BEGIN

readCheck(actuals); n :* newNode(nRead); n*.routine :* emptySymbol; n^.args :* actuals;

RETURN n;

END makeReadNode;

PROCEDURE makeStrIngNode(s:ARRAY OF CHAR):node;

VAR n:node;

BEGIN

n :* newNode(nString); strlngCopy(n^.string, s);

RETURN n;

END makeStringNode;

PROCEDURE newNode(nc:NodeCI ass):node;

38 BYTE LISTINGS SUPPLEMENT

VAR ninode;

BEGIN

NEW(n); (* nc); *) n~.class :« nc; n^.type :» tUnknown; RETURN n;

END newNode;

(*** node access ***)

PROCEDURE nodelnt(nmode): INTEGER;

BEGIN

nodeCIassCheck('nodelnt*, n, nlnt);

RETURN n^.Int;

END nodelnt;

PROCEDURE nodeBool (ninode)-.BOOLEAN;

BEGIN

nodeCIassCheck('nodeBooI', n, nBool);

RETURN n^.bool;

END nodeBool;

PROCEDURE nodeChar(ninode)iCHAR;

BEGIN

nodeCIassCheck('nodeChar', n, nChar);

RETURN n^.ch;

END nodeChar;

PROCEDURE nodeString(ninode; VAR siARRAY OF CHAR);

BEGIN

nodeCIassCheck('nodeString', n, nString); strIngCopy(s, n A .string);

END nodeStrlng;

PROCEDURE nodeFf rst(ninode)inode;

BEGIN

nodeCIassCheck('nodeFirst', n, nLIst);

RETURN n*.first;

END nodeFirst;

PROCEDURE nodeRest(ninode)inode;

BEGIN

nodeCIassCheck('nodeRest', n, nLIst);

RETURN n^.rest;

END nodeRest;

PROCEDURE nodeTest(ninode)inode;

BEGIN

IF n^.class ■ nlf THEN RETURN n*.test;

ELSIF n A .class - nWhlle THEN RETURN n^.wtest;

ELSE

nodeCIassEr ror(*nodeTest') ;

RETURN emptyNode;

END;

END nodeTest;

PROCEDURE nodeThen(ninode)inode;

BEGIN

nodeCIassCheck('nodeThen', n, nlf);

RETURN n^.then;

END nodeThen;

PROCEDURE nodeElse(n;node)inode;

BEGIN

nodeCIassCheck('nodeEIse', n, nlf);

RETURN n^.else;

END nodeEIse;

PROCEDURE nodeStmts(ninode)inode;

BEGIN

nodeCIassCheck('nodeStmts’, n, nWhlle);

RETURN n^.stmts;

END nodeStmts;

(continued)

BYTE LISTINGS SUPPLEMENT 39

PROCEDURE nodeRHS(n:node):node;

BEGIN

nodeCIassCheck(’nodeRHS’, n, nAssignment );

RETURN rT.RHS;

END nodeRHS;

PROCEDURE nodelHS(n:node):symbol;

BEGIN

nodeClassCheck(’nodeLHS’, n, nAssignment);

RETURN n^.LHS;

END nodeLHS;

PROCEDURE nodeArgs(n:node):node;

BEGIN

WITH n* DO

IF (class « nCall) OR (class = nRead) OR (class = nWrite) THEN RETURN args;

ELSE

nodeCIassError(’nodeArgs’);

END;

END;

END nodeArgs;

PROCEDURE nodeRoutIne(n:node):symboI;

begin ^ . lN

nodeCIassCheck( 1 nodeRoutine*, n, nCall);

RETURN n*.routine;

END nodeRoutine;

PROCEDURE nodeExpr(n:node):node;

begin ^ x x

nodeCIassCheck(*nodeExpr 9 , n, nReturn);

RETURN n^.expr;

END nodeExpr;

PROCEDURE nodeArg(n:node)inode;

BEGIN

nodeCIassCheck(*nodeArg*, n, nUnop);

RETURN n^.arg;

END nodeArg;

PROCEDURE nodeLeftArg(ninode)inode;

BEGIN ^ x

nodeCIassCheck('nodeLeftArg*, n, nOp);

RETURN n~.leftArg;

END nodeLeftArg;

PROCEDURE nodeRightArg(ninode)inode;

BEGIN

nodeClassCheck(*nodeRightArg', n. nOp);

RETURN n^.rightArg;

END nodeRightArg;

PROCEDURE nodeOp(n;node);tokenCI ass;

BEGIN

IF n^.class = nOp THEN RETURN n^.op;

ELSIF n*.class = nUnop THEN RETURN n^.unop;

ELSE

nodeCIassError(*nodeOp*);

RETURN Plus;

END;

END nodeOp;

PROCEDURE nodeSymbol(n;node)isymboI;

BEGIN t BN

nodeClassCheck(*nodeSymbol*, n, nSymbol);

RETURN n^.sym;

END nodeSymbol;

PROCEDURE nodeNumFormaIs(ninode)iCARDINAL;

begin ^ A N

nodeCIassCheck(* nodeNumFormaIs*, n, nReturn);

RETURN n^.nFormaIs;

END nodeNumFormaIs;

40 BYTE LISTINGS SUPPLEMENT

PROCEDURE nodeType(ninode):typeType;

BEGIN

RETURN n^.type;

END nodeType;

(*** other ***)

PROCEDURE nodeCIossCheck(s:ARRAY OF CHAR; ninode; nciNodeCIass);

BEGIN

IF n*.class <> nc THEN nodeCIassError(s);

END;

END nodeCIassCheck;

PROCEDURE nodeCIassError(s:ARRAY OF CHAR);

BEGIN

Wr i teStrIng(s);

fatal (": node of wrong type");

END nodeCIassError;

BEGIN

emptyNode := NIL;

END Node.

+++++++

Start Parser.DEF +++++++

DEFINITION MODULE Parser;

(* This is the bulk of the SIMPL parser. It covers most of the language. For routines (procedures and functions) see Routines.

For expressions, see ExprParser.

Syntax handled by this module:

<program> PROGRAM <id>; <vars> <routines> <block> .

<vars> <empty> | VAR <varIist>

<varlist> <decl> | <decl> <varlist>

<decl> <idIist> : <type> ;

<IdI 1st> <id> | <id> , <idIist>

<type> INTEGER | BOOLEAN | CHAR

<block> ::«= BEGIN <stmts> END <stmts> <empty> | <stmt> ; <stmts>

<stmt> <while> | <if> | <return> | <assign> | <caI I>

<while> WHILE <expr> DO <stmts> END

<if> IF <eIsif> END

<eIsif> <expr> THEN <stmts> <else>

<else> <empty> | ELSIF <eIsif> | ELSE <stmts>

<return> RETURN | RETURN <expr>

<assign> <id> :* <expr>

<call> <id> <actuals>

<actuals> <empty> I ( <exprllst> )

<exprllst> :<expr> | <expr> , <exprlist>

*)

FROM Symbol IMPORT symbol;

FROM Node IMPORT node;

FROM Token IMPORT tokenList;

EXPORT QUALIFIED program, vars, idlist, block, actuals;

PROCEDURE program;

(* Parse the entire program *)

PROCEDURE vars(rout 1neName:symboI);

(* Parse variable declarations. Scope indicates whether these are local or global variables. RoutineName is the name of the routine currently being compiled; if these are global variables, it should be the name of the program. *)

PROCEDURE id I 1st():tokenList;

(* Parse a list of identifiers *)

{continued )

BYTE LISTINGS SUPPLEMENT 41

PROCEDURE bIock(rout1ne:symboI ) inode; ]k \

(* Parse a block of code. Routine is the routine currently being compiled. *)

PROCEDURE actuals():node; ., x . . v

(* Parse a list of actual parameters, l.e. a list of expressions. )

END Parser.

+++++++

Start Parser.MOD +++++++

IMPLEMENTATION MODULE Parser;

(* Most of the parser for the SIMPL compiler. It Is o top-down, recursive descent parser. *)

FROM Token IMPORT token, tokenCloss. isType, emptyTokenList,

tIToken. tINext, tIEmpty, addToTokenList, tokenList, freeTokenList, typeType, tokenClassToType; c , r «r

FROM LexAn IMPORT getToken. getTokenCIass, peekTokenCloss. compError, ungetToken. tokenErrorCheck. getTokenErrorCheck;

FROM Symbol IMPORT symbol, emptySymbol, SymbolCloss. symbolEmpty, symbolClassEquol, symbolEqual;

FROM SymboI Table IMPORT enterSymbol, enterLocal. enterFormal. findSymbol,

FROM^ode" IMPORT node, emptyNode. makeStmtsNode, mokelfNode, makeWhiIeNode, makeReturnNode, makeAssignmentNode, makeExprListNode, makeCalINode. makeReodNode, mokeWrIteNode. nodeType;

FROM CodeGen IMPORT genBlock, genGlobal;

FROM CodeWrite IMPORT wrIteStringBranch. writeHalt, writeRoutineLabeI.

FROM TypeChecker IMPORT boolCheck;

FROM ExprPorser IMPORT expr;

FROM Routines IMPORT routines;

FROM MyTermInal IMPORT fatal;

VAR programName:symboI;

(♦ <program> PROGRAM <ld>; <vars> <routlnes> <block> . *)

PROCEDURE program;

VAR t:token; n:node;

B ^ ( ^ 1 tokenErrorCheck (Prog ram. ’keyword "PROGRAM" expected’);

getTokenErrorCheck(t , Identifier, name of program expected ),

IF t t?stHng > := d "???"; er (* H ^ the program name isn’t given, make one up *)

programName := enterSymbol(t.string. Proc, tUnknown); writeStringBranch(t.string);

tokenErrorCheck (Semi co I on, ’semicolon expected ),

vars(emptySymboI);

routines;

wrIteRoutineLabeI(programName); genBIock(block(programName)); tokenErrorCheck(Period, ’period expected ); tokenErrorCheck(EndOfInput, ’end of input expected ). writeHalt;

END program;

(*** variable declarations ***)

(* <vars> <empty> | VAR <varlist> *)

PROCEDURE vars(routineName:symbol);

BEGIN

IF getTokenCIass() = Var THEN varIist(routineName);

ELSE

ungetToken;

END;

END vars;

<varlist> <decl> I <decl> <varlist> . .

We con recognize the end of a varlist by seeing if ^e next token is on identifier. An Id indicates the varlist continues. If it didn t we d see a keyword: either Begin. Procedure or Function. *)

42 BYTE LISTINGS SUPPLEMENT

PROCEDURE varIist(rout IneName:symboI);

BEGIN

dec I(routineName);

IF peekTokenCIass() * Identifier THEN varlist(routineName);

END;

END varlist;

(* <decl> <idlist> : <type> ;

Declarations. All the work of putting information about the variables into the symbol table is done here. *)

PROCEDURE dec I(routineName:symboI);

VAR tl, tokenp:tokenList; t, idrtoken; tt:typeType;

BEGIN

tl idlistQ;

tokenErrorCheck(CoIon, 'colon expected’); getToken(t);

IF NOT IsTypeft.class) THEN

compError('type name expected'); tt := tUnknown; ungetToken;

ELSE

tt :« tokenCIassToType(t.class);

END;

tokenErrorCheck(SemicoI on, 'semicolon expected'); tokenp := tI;

(* Enter the variables into the symbol table. For globals, also generate the variabIes. *)

WHILE NOT tlEmpty(tokenp) DO tIToken(tokenp, id);

IF currentLexLeveI() * 0 THEN

genGlobal(enterSymboI(id.string, Variable, tt));

ELSE

enterLocal(id.string, tt, routineName);

END;

tokenp :* tINext(tokenp);

END;

freeTokenLIs t(11);

END decl;

(* <idlist> <id> | <id> , <idlist> *)

PROCEDURE idlist():tokenList;

VAR t: token;

BEGIN

getTokenErrorCheck(t, Identifier, 'identifier expected');

IF getTokenCIass() <> Comma THEN (* this is the end of the idlist *) ungetToken;

IF t.class « Identifier THEN

RETURN addToTokenList(t, emptyTokenList);

ELSE

RETURN emptyTokenList;

END;

(* we saw a comma, so there's more *)

ELSIF t.class - Identifier THEN

RETURN addToTokenList(t, idlist());

ELSE

RETURN idlIst();

END;

END idlist;

(*** blocks and statements ***)

(* <bIock> BEGIN <stmts> END *)

PROCEDURE block(routineisymbol):node;

VAR n:node;

BEGIN

tokenErrorCheck(Begin, 'BEGIN expected'); n stmts(routIne);

tokenErrorCheck(End, '"END" expected'); RETURN n;

END block;

(continued)

BYTE LISTINGS SUPPLEMENT 43

(* <stmts> <empty> | <stmt> ; <stmts>

We can recognize an empty <stmts> by seeing if the next token is ELSE, ELSIF or END. *)

PROCEDURE stmts(routIne:symboI)inode;

VAR n:node;

tc:tokenCIass;

BEGIN

tc :■ peekTokenCIass();

IF (tc - Else) OR (tc - Elsif) OR (tc - End) THEN RETURN emptyNode;

ELSE

n :■ stmt(routine);

tokenErrorCheck(SemicoI on, *a semicolon must end a statement'); RETURN makeStmtsNode(n, stmts(routine));

END;

END stmts;

(* <stmt> <while> I <if> | <return> | <assign> | <caI I> |

<write> | <read> *)

PROCEDURE stmt(routineisymbol);node;

VAR t:token;

BEGIN

getToken(t);

CASE t.cl ass OF

If: RETURN ifStmt(routIne);

I While: RETURN whiIeStmt(routine);

| Return: RETURN returnStmt(routine);

IF symbolEqual(routine, programName) THEN

compError("can't return from main program");

ELSE

RETURN makeReturnNode(routIne, expr());

END;

Write: RETURN makeWriteNode(actuaIs());

Read: RETURN makeReadNode(actuaIs());

Identifier: RETURN assignOrCaI I Stmt(t);

ELSE

compError('I I IegaI statement type');

RETURN emptyNode;

END;

END stmt;

(* <if> ::« IF <eIsif> END *)

PROCEDURE ifStmt(routine:symboI):node;

VAR n:node;

BEGIN

n :* elsif(routine); tokenErrorCheck(End, 'END expected');

RETURN n;

END ifStmt;

(* <eIsIf> ::= <expr> THEN <stmts> <else> *)

PROCEDURE eIsif(routine:symboI):node;

VAR nl, n2:node;

BEGIN

nl :* expr() ; boolCheck(nl);

tokenErrorCheck(Then, 'THEN expected'); n2 :■ stmts(routine);

RETURN makelfNode(n1, n2, eIse(routine));

END elsif;

(* <else> ::= <empty> | ELSIF <elsif> | ELSE <stmts>

We can tell an <else> is empty by seeing if the next token is END. *) PROCEDURE else(routine:symbol):node;

BEGIN

CASE getTokenClass() OF End: ungetToken;

RETURN emptyNode;

| Elsif: RETURN makeStmtsNode(eIsif(routine), emptyNode);

Else: RETURN stmts(routine);

ELSE

compError('END, ELSIF or ELSE expected'); ungetToken;

RETURN emptyNode;

END;

44 BYTE LISTINGS SUPPLEMENT

END else;

(* <while> WHILE <expr> DO <stmts> END *)

PROCEDURE whlIeStmt(routine:symboI)inode;

VAR ninode;

BEGIN

n ;* exprH;

booICheck(n);

tokenErrorCheck(Do, ’DO expected’); n i* makeWhiIeNode(n, stmts(routine)); tokenErrorCheck(End, ’END expected*);

RETURN n;

END whlIeStmt;

(* <return> RETURN | RETURN <expr> *)

PROCEDURE returnStmt(routineisymbol)mode;

BEGIN

IF symbolEquaI(routine, programName) THEN

compError("can*t return from main program");

END;

IF peekTokenClass() = Semicolon THEN

RETURN makeReturnNode(routine, emptyNode);

ELSE

RETURN makeReturnNode(routine, expr());

END;

END returnStmt;

(* We can’t distinguish an assignment from a call based on the first token of the statement, since in both cases it’s an identifier. The next token, though, will distinguish: It's an assignment sign for an assignment. *)

PROCEDURE assignOrCalIStmt(t;token)mode;

BEGIN

IF getTokenClassQ * Assignment THEN RETURN assignStmt(t);

ELSE

ungetToken;

RETURN calIStmt(t);

END;

END assignOrCaI I Stmt;

(* <assign> :i« <id> i« <expr> *)

PROCEDURE assignStmt(varName:token)inode;

VAR sisymboI;

BEGIN

s i* fIndSymboI(varName.strIng);

IF NOT symbo1C IassEquaI(s, Variable) THEN

compError(’only variables can be assigned to’);

RETURN expr(); (* consume the expression anyway *)

ELSE

RETURN makeAssignmentNode(s, expr());

END;

END assignStmt;

(* <call> <id> <actuals> *)

PROCEDURE cal I Stmt(rout IneNameitoken)mode;

VAR procisymbol;

BEGIN

proc :■ findSymbol(routIneName.strIng);

IF NOT symboICIassEquaI(proc, Proc) THEN

compError('on Iy procedures can be used in a call statement');

RETURN actuaIs();

ELSE

RETURN makeCalINode(proc, actuals());

END;

END calIStmt;

(* <actuals> <empty> | ( <exprllst> )

We can recognize an empty <actuals> by seeing if the next character is a left parenthesis. *)

PROCEDURE actuaIs()mode;

VAR ninode;

BEGIN

IF getTokenClass() ■ Lparen THEN n i- exprI 1st();

tokenErrorCheck(Rparen, ’right paren expected’);

( continued)

BYTE LISTINGS SUPPLEMENT 45

RETURN n;

ELSE

ungetToken;

RETURN emptyNode;

END;

END actuals;

(* <exprIist> :<expr> | <expr> , <exprl1st>

Exprlist always returns an nLlst node, even If there’s only one expr. *) PROCEDURE exprI 1st():node;

VAR n:node;

BEGIN

n expr() ;

IF getTokenClass() ■ Comma THEN

RETURN makeExprLIstNode(n, exprllst());

ELSE

ungetToken;

RETURN makeExprLIstNode(n, emptyNode);

END;

END exprI 1st;

BEGIN

END Parser.

+++++++

Start Routines.DEF +++++++

DEFINITION MODULE Routines;

(* The part of the parser that deals with procedures and functions.

Syntax:

<routines> :<empty> | <proc> <routines> | <func> <routines>

<proc> procedure <id> <formals> ; <vars> <block> ;

<func> function <id> <formals> : <type> ; <vars> <block> ;

<formaIs> <empty> | ( <formlist> )

<formlist> ::= <formdecl> | <formdecl> ; <formlist>

<formdecl> ::*= <idI ist> : <typeld>

*)

EXPORT QUALIFIED routines;

PROCEDURE routines;

END Routines.

+++++++

Start Routines.MOD +++++++

IMPLEMENTATION MODULE Routines;

(* The part of the parser that handles procedures and functions.

There are basically two things that have to be done: the routine declarations have to be processed to yield symbol table entries, and the code for the routine bodies has to be generated. The lists of formal parameters (arguments) and locals variables are placed in the appropriate slots in the symbol table entry for the routine. For functions,

the return type of the function is put in the type slot of the symbol; for procedures, this slot is left undefined. An offset from the stack pointer is given to each local and formal. The initial offsets assume the following stack conventions:

FP->

arg 1 arg 2

oidFP

$P

return loc 1 loc 2

stack grows down towards low memory

46 BYTE LISTINGS SUPPLEMENT

The list of formals must be backwards to match the argument conventions. The order of the locals doesn't matter, but it's also backwards.

We generate code as if for a block, with two exceptions: at the beginning,

we have to push enough words to move the stack pointer past the local storage area; while we are at it, we initialize the words to 0. At the end, we generate a return, in case the user didn't. For procedures, it Is okay to return by falling off the end. For functions, something has to be returned explicitly; it is an error to fall through.

*)

FROM Token IMPORT token, tokenClass, isType, typeType. tokenCIassToType, tokenList, tIEmpty, tINext, tIToken, freeTokenList;

FROM LexAn IMPORT getToken, getTokenCIass, ungetToken, tokenErrorCheck, getTokenErrorCheck, compError, peekTokenCI ass;

FROM Symbol IMPORT symbol, setSymboI Type, setSymbolOffset,

symboIFormaIs, symboILocaIs, symbol List, si Next, si Symbol, si Empty, SymbolClass, numFormals, numLocals;

FROM SymbolTable IMPORT enterSymbol, enterFormal, beginRoutine, endRoutine; FROM CodeGen IMPORT genBlock, genLocals;

FROM CodeWrite IMPORT writelnt, writeFReturn, writeReturn, writeRoutineLabeI; FROM Parser IMPORT vars, idlist, block;

FROM Node IMPORT node;

CONST

In 11la ILocalOffset * —1; (* offsets, in words, from the FP *)

initiaIFormalOffset ■ 3;

(* <routines> <empty> | <proc> <routines> | <func> <routines> *)

PROCEDURE routines;

BEGIN

LOOP

CASE getTokenCIass() OF Procedure: proc;

| Function: func;

ELSE ungetToken; EXIT;

END;

END;

END routines;

(* <proc> ::■ procedure <id> <formals> ; <vars> <routines> <block> ; *)

PROCEDURE proc;

VAR t:token; s:symboI;

I:CARDINAL;

BEGIN

getTokenErrorCheck(t, Identifier, 'procedure name expected'); s :■ enterSymbol(t.string, Proc, tUnknown); beginRoutine(s); forma Is(s);

tokenErrorCheck(SemicoIon, 'semicolon expected');

locaIs(s);

routines;

writeRoutineLabeI(s); genLocaIs(s); genBlock(block(s)); writeReturn(numFormaIs(s));

tokenErrorCheck(SemicoIon, 'semicolon expected'); endRoutlne(s);

END proc;

(* <func> ::■ function <id> <formaI8>:<type>; <vars> <routines> <block>; *)

PROCEDURE func;

VAR fname, ftype:token; s:symboI;

1:CARDINAL;

BEGIN

getTokenErrorCheck(fname, Identifier, 'function name expected'); s :■ enterSymbol(fname.string, Func, tUnknown); beginRoutlne(s); forma Is(s);

tokenErrorCheck(CoIon, 'colon expected'); getToken(ftype);

(continued)

BYTE LISTINGS SUPPLEMENT 47

IF NOT l8Type(ftyp«.closs) THEN

compError(’function type expected’);

END;

tokenErrorCheck(SemlcoIon, ’semicolon expected*); setSymboI Type(s, tokenCIassToType(ftype.cI ass)); loco Is(s); rout Ines;

writeRoutIneLabeI (s) ; genLocal s(s) ;

aenBlock(block(s)); _ ,

(* Here we should generate an error message in the code: value not returned from function. But since we have no string manipulation, we can’t. Instead we’ll return either 0 (for an Integer function) or false (which is also 0) for a boolean function. *) wr 1telnt(0);

wr 1teFReturn(numFormaIs(s));

tokenEr rorCheck(SemicoI on, ’semicolon expected'); endRout1ne(s);

END func;

(* <formaIs> :<empty> | ( <formlist> ) *)

PROCEDURE forma Is(routine:symbol);

VAR formLlst :symbolUst;

offset:INTEGER;

BEGIN

IF getTokenCIass() - Lparen THEN formlist(routine);

tokenErrorCheck(Rparen, ’right paren expected’);

ELSE

ungetToken;

END;

(* Set the offsets of the formals *) formList :* symboI Forma Is(routine); offset :* initiaIFormalOffset;

WHILE NOT sIEmpty(formList) DO

setSymboIOffset(sISymboI(formList), offset);

INC(offset);

formList :■ sI Next(formL1st);

END;

END formals;

(* <formlist> <formdecl> | <formdecl> ; <formlist> *) PROCEDURE formlist(rout Ine:symboI);

BEGIN

formdecI(rout 1ne);

IF getTokenCI ass() * Semicolon THEN formlist(routine);

ELSE

ungetToken;

END;

END formlist;

(* <formdecl> ::= <idIist> : <typeld> *)

PROCEDURE formdecI(routine:symboI);

VAR tl, tokenp:tokenList; t:token; tt:typeType;

BEGIN

tl :« idlist();

tokenErrorCheck(Co I on, "colon expected"); getToken(t);

IF isType(t.cI ass) THEN

tt :» tokenClassToType(t.class);

ELSE

compError("type name expected"); tt :* tUnknown; ungetToken;

END;

(* create and enter the symbols *) tokenp :* tI;

WHILE NOT tlEmpty(tokenp) DO tIToken(tokenp, t);

enterFormaI(t.string, tt, routine); tokenp := 11 Next(tokenp);

END;

48 BYTE LISTINGS SUPPLEMENT

f reeTokenList(tI);

END formdecI;

PROCEDURE I oca Is(routine:symboI);

(* Syntactically, locals look just like globals; but we have to put them into the locals list of the routine and give them offsets from the frame pointer. *)

VAR locLlst:symbolList;

offset:INTEGER;

BEGIN

vars(routine);

locList :« symboILocaIs(routine); offset := initia ILocalOffset;

(* set the offsets of the locals *)

WHILE NOT slEmpty(locList) DO

setSymboIOffset(sISymboI(IocList), offset);

DEC(offset);

locList :« sINext(locList);

END;

END locals;

BEGIN

END Routines.

+++++++

Start SymboI.DEF

+++++++

DEFINITION MODULE Symbol;

(* The symbol data structure contains all the information about symbols (like variables and routine names). Symbol lists are used for lists of formals and locals. *)

FROM Token IMPORT stringType, tokenClass, typeType;

EXPORT QUALIFIED symbol, emptySymbol, SymbolClass,

symbolClass, symboIString, symbolType, symboILexLeveI, symbolOffset, symboI Forma Is, symboILocaIs, symbolNext, symbolPrev, symboITokCI ass, setSymboI Forma Is, setSymboILocaIs, setSymboI Type, setSymboI Next, setSymboIPrev, setSymboI Offset, setSymboITokCI ass, symboICIassEquaI, symbolEmpty, symbolEqual, newSymbol, freeSymbol, numFormals, numLocals,

symboIList, emptySymboILIst, slEmpty, sISymbol, sINext, addToSymboIList, freeSymbolList;

TYPE

symbol; symboIList;

SymbolClass = (* the different kinds of symbols *)

(Proc, Func, Variable, Keyword, Undeclared);

VAR emptySymboI:symboI;

emptySymboIList:symboIList;

(*** Symbols ***)

PROCEDURE symbo1C I ass(s:symboI):Symbo1C I ass; (★ Return the class of the symbol *)

PROCEDURE symbolString(s:symbol; VAR str:stringType);

(* Return the name of the symbol, as a string *)

(* Symbols are declared to be of a certain type (except procedures) *) PROCEDURE symboIType(s:symboI):typeType;

PROCEDURE setSymboIType(s:symboI; tt:typeType);

PROCEDURE symboILexLeveI(s:symboI):CARDINAL;

(* Return the lexical level at which the symbol was declared *)

(* Each formal and local has an offset from the frame pointer. *)

PROCEDURE symboI Of fset(s:symboI):INTEGER;

PROCEDURE setSymbolOffset(s:symboI; o:INTEGER);

(* These are for routines. They get and set the lists of formals and locals. *)

(continued)

BYTE LISTINGS SUPPLEMENT 49

PROCEDURE symboI Forma Is(s:symboI):symboILis t;

PROCEDURE symboI Loco Is(s:symboI):symboILis t;

PROCEDURE setSymboI Forma Is(s:symboI; sI:symboIList);

PROCEDURE setSymboILocaIs(s:symboI; sI:symboIList);

(* Return the number of formals or locals In the routine. *)

PROCEDURE numFormaIs(s:symboI):CARDINAL;

PROCEDURE numLocaIs(s:symboI):CARDINAL;

(* These next two are for implementing a doubly linked list. See SymbolTable.*)

PROCEDURE symboI Next(s:symboI):symboI;

PROCEDURE symbolPrev(s:symbol):symboI;

PROCEDURE setSymboI Next(s1, s2:symbol);

PROCEDURE setSymboIPrev(s1, s2:symbol);

(* Keyword symbols have a corresponding token class. *)

PROCEDURE symboITokCI ass(s:symboI):tokenCI ass;

PROCEDURE setSymbolTokClass(s:symbol; tcrtokenClass);

PROCEDURE symbo1C IassEquaI(s:symboI; sc:Symbo1C I ass):BOOLEAN;

(* Returns TRUE if the class of s equals sc. *)

PROCEDURE symboI Equal(si, s2:symboI):BOOLEAN;

(* Returns TRUE if the two symbols are the same. *)

PROCEDURE symboI Empty(s:symboI):BOOLEAN;

(* Returns TRUE if the symbol is the emptySymbol. *)

PROCEDURE newSymbol(VAR str:stringType; sc:Symbo1C I ass; scop:CARDINAL;

tt;typeType):symboI;

(* Creates a new symbol. *)

PROCEDURE freeSymbol(s:symboI);

(* Frees the storage associated with s. *)

(*** Symbol Lists ***)

PROCEDURE sI Empty(sI;symboIList):BOOLEAN;

(* Returns TRUE if si is the empty symbol list. *)

PROCEDURE sI Next(si;symboILis t):symboILis t;

(* Gets the rest of the symbol list. *)

PROCEDURE siSymboI(si:symboIList):symboI;

(* Gets the first symbol in the list *)

PROCEDURE addToSymboIList(s:symboI; si;symbolList):symbolList;

(* Adds s to si at the front. Return the new symbol list. *)

PROCEDURE freeSymbolList(si:symboIList);

(* Frees the storage associate with si (but NOT the storage of the symbols in sli *)

END Symbol.

+++++++

Start Symbol.MOD +++++++

IMPLEMENTATION MODULE Symbol;

(* Symbol and symbol list data structures. *)

FROM Token IMPORT stringType, tokenClass, typeType, tokenCIassToType;

FROM Storage IMPORT ALLOCATE. DEALLOCATE;

FROM MyTerminal IMPORT fatal;

TYPE

symbol = POINTER TO symbolRec; symbolList *» POINTER TO sIRec;

symbolRec * RECORD

string: stringType; lexLevel: CARDINAL; type: typeType; next, prev: symboI;

50 BYTE LISTINGS SUPPLEMENT

offset:INTEGER;

CASE class: SymbolClass OF

Proc, Func: formals, locals: symbolList; Keyword: tokClass: tokenClass;

END;

END;

sIRec ■ RECORD

sym: symbol; next: symbolList;

END;

(*** getting fields ***)

PROCEDURE symbolClass(s:symbol):Symbo1C I ass;

BEGIN

RETURN s^.class;

END symbolClass;

PROCEDURE symbolStrlng(s:symbol; VAR str:strIngType);

BEGIN

str :» s^.string;

END symbolstring;

PROCEDURE symboIType(s:symboI):typeType;

BEGIN

RETURN s^.type;

END symboI Type;

PROCEDURE symboILexLeveI(s:symboI):CARDINAL;

BEGIN

RETURN s^.lexLevel;

END symboILexLeveI;

PROCEDURE symboI Of fset(s:symboI):INTEGER;

BEGIN

RETURN s^.offset;

END symbolOffset;

PROCEDURE symbolFormals(s:8ymbol):symboIList;

BEGIN

IF (s A .cI ass - Proc) OR (s*.class - Func) THEN RETURN s*.formals;

ELSE

fata I(*symboI Forma Is: not a proc or func*);

END;

END symboI Forma Is;

PROCEDURE symboILocaIs(s:symboI):symboILIst;

BEGIN

IF (s^.class - Proc) OR (s*.class « Func) THEN RETURN s*.locals;

ELSE

fatal(‘symbolLocaIs: not a proc or func*);

END;

END symboILocaIs;

PROCEDURE symboI Next(s:symboI):symboI;

BEGIN

IF s * emptySymbol THEN

fata I(*symboINext: empty symbol given*);

ELSE

RETURN s*.next;

END;

END symboI Next;

PROCEDURE symbolPrev(8:symboI):symboI;

BEGIN

RETURN s^.prev;

END symbolPrev;

PROCEDURE symboITokCI ass(s:symboI):tokenCI ass;

BEGIN

IF s*.class ■ Keyword THEN RETURN s*.tokClass;

{continued)

BYTE LISTINGS SUPPLEMENT 51

January

ELSE

fata I('symboITokCIass: not a keyword*);

END;

END symboITokCIass;

(*** setting fields ***)

PROCEDURE setSymbolFormals(s:symbol; sI:symbolList); BEG IN

IF (s*.class - Proc) OR (s*.class - Func) THEN s*.formats :■ si;

ELSE , , x

fatal ('set Symbol Formale: not a proc or func );

END;

END setSymboI Forma Is;

PROCEDURE setSymbolLocals(s;symbol; si:symbolList);

begin v _ x TLjrikl

IF (s*.class « Proc) OR (s*.class ■ Func) THEN s*.locals :* sI;

ELSE . . \ fatal('setSymboI Locals: not a proc or func );

END;

END setSymboI Locals;

PROCEDURE setSymboIType(8:symboI; tt:typeType);

BEGIN

s*.type :« tt;

END setSymbolType;

PROCEDURE setSymboI Next(s1, s2:symbol);

BEGIN

si*.next :* s2;

END setSymboI Next;

PROCEDURE setSymboIPrev(s1, s2:symbol);

BEGIN

s1*.prev ;* s2;

END setSymbolPrev;

PROCEDURE setSymboI Offset(s:symboI; o;INTEGER);

BEGIN

s*.offset :« o;

END setSymbolOffset;

PROCEDURE setSymbo ITokCIass(s:symboI; tc:tokenCIass); BEGIN

IF s^.class * Keyword THEN s*.tokClass :■ tc;

else

fata I('setSymboITokCIass: not a keyword');

END;

END setSymboITokCIass;

(*** other symbol procedures ***)

PROCEDURE symbo1C IassEquaI(s:symboI; sc:Symbo1C I ass);BOOLEAN;

begin % x

RETURN (s*.class - Undeclared) OR (s .class - sc);

END symbo1C IassEquaI;

PROCEDURE symboI Equal(si, s2:symboI):BOOLEAN;

BEGIN

RETURN si « s2;

END symboI Equal;

PROCEDURE symbolEmpty(s:symbol)‘.BOOLEAN;

BEGIN

RETURN s « emptySymbol;

END symboI Empty;

PROCEDURE newSymbol(VAR str:stringType; sc:Symbo1C I ass; I I;CARDINAL; tt:typeType):symboI;

VAR s-.symbol;

BEGIN

52 BYTE LISTINGS SUPPLEMENT

NEW(s); (* should be: NEW(s, sc); *)

WITH s* DO

string :■ str; lexLevel :— II; type :■ tt; next :■ emptySymbol; prev :* emptySymbol; class :« sc;

CASE class OF Proc, Func:

forma Is :■ emptySymboILIst; locals :■ emptySymboIL1st;

Varlab Ie: offset :■ 0;

ELSE (* do nothing *)

END;

END;

RETURN s;

END newSymbol;

PROCEDURE freeSymboI(s:symboI);

BEGIN

DISPOSE (s); (* should be: DISPOSER, s^.class); *)

END freeSymboI;

PROCEDURE numFormaIs(s:symbol):CARDINAL;

VAR formLIst:symboILIst;

count:CARDINAL;

BEGIN

count :« 0;

formList :■ symboI Forma Is(s);

WHILE NOT sIEmpty(formList) DO INC(count);

formList sI Next(formList);

END;

RETURN count;

END numFormals;

PROCEDURE numLocals(s:symbol):CARDINAL;

VAR locLIstisymbolList;

count CARDINAL;

BEGIN

count :* 0;

locList :* symboI Loco Is(s);

WHILE NOT sIEmpty(IocL1st) DO INC(count);

locList slNext(locList);

END;

RETURN count;

END numLocals;

(*** symbolList ***)

PROCEDURE si Empty(si:symboILIst):BOOLEAN;

BEGIN

RETURN si * emptySymboIList;

END slEmpty;

PROCEDURE sINext(sI:symboILIst):symboILIst;

BEGIN

RETURN sr.next;

END si Next;

PROCEDURE sISymboI(sI:symboILIst):symboI;

BEGIN

RETURN sl^.sym;

END 8 ISymboI;

PROCEDURE addToSymbolLlst(s:symbol; si:symboILIst):symboILIst; VAR news I: symbolList;

BEGIN

NEW(newsI); newsl^.sym :■ s; newsP.next :■ si;

RETURN news I;

END addToSymbolLlst;

January

r

( continued )

BYTE LISTINGS SUPPLEMENT 53

PROCEDURE freeSymbolLIst(sl:symboI List';

BEGIN , %

IF NOT slEmpty(sl) THEN

freeSymboIList(sI Next(sI)); DISPOSE(sl);

END;

END freeSymbolList;

BEGIN

emptySymbol :* NIL; emptySymbolUst :■* NIL; END Symbol.

+++++++

Start SymboI Tab Ie.DEF +++♦+++

DEFINITION MODULE SymbolTable;

(* The symbol table associates symbol records with names of symbols. *)

FROM Symbol IMPORT symbol, SymbolClass;

FROM Token IMPORT stringType. tokenClass, typeType;

EXPORT QUALIFIED enterSymbol, enterLoccI, enterFormal, findSymbol,

^ enterKeyword, beginRou ine, endRoutlne, currentLexLeve I ,

PROCEDURE currentLexLevel():CARDINAL;

(* Returns the current lexical level *)

If the

(* Enter global, local, formal, keyword symbols Into table.

enterSymbol Is the general routine and returns the entered symbol. symbol is already present, an error is signalled. EnterLocal and enterFormal are used for local variables and formal parameters only; they take care of inserting the symbol into the list of locals or formals. respectively, which Is associated with the routine. *)

PROCEDURE enterSymbol(VAR s:strIngType; symc:SymbolClass; tt:

PROCEDURE'enterLocaI(VAR s:stringType; tt-.typeType; routine:symboI); PROCEDURE enterFormal(VAR s:stringType; tt:typeType; routine:symbo ), PROCEDURE enterKeyword(s:stringType; tc:tokenCI ass);

Return the empty symbol

PROCEDURE findSymbol(VAR s:stringType):symboI;

(* Look up the symbol in the table and return it. if not found. *)

PROCEDURE findKeyword(VAR s:str IngType; VAR tc:tokenCIass):BOOLEAN;

(* Look up the keyword in the table and put its corresponding token class in tc. Return FALSE if the symbol wasn't found. *)

PROCEDURE beginRoutine(rname:symboI);

(* To be called just after the routine name has been entered. Increments lexical level. Also assigns a unique number to the routine if it isn t

gIobaI. *)

This includes

PROCEDURE endRoutine(rname:symbol);

(* Clean up the symbol table after a routine has been compiled, deleting the locals and formals from the table. *)

END SymbolTable.

+++++++

Start SymboI Tab Ie.MOD

+++++++

IMPLEMENTATION MODULE SymbolTable;

(* The symbol table for the SIMPL compiler. It is a hash table; each entry is a symboI.possibly linked through the NEXT field to other symbols. The list of symbols is doubly linked, to make it easy to delete from the

^W^sti11 have to rehash to delete from the beginning, though. This could be gotten around by hanging a dummy record off of every hashtable entry.

*)

FROM Symbol IMPORT symbol, SymbolClass. emptySymbol, newSymbol,

symbo I Forma Is. symboI Loco Is. symboI Empty, symbo1 Strmg. symbolLexLevel.

54 BYTE LISTINGS SUPPLEMENT

January

symboI Next, symboIPrev, setSymboI Next, setSymboIPrev, setSymboILocaIs, setSymbolFormals, freeSymbol, symbolClass, symbolEqual, symboITokCI ass, setSymboITokCI ass, emptySymboIList, numFormals, setSymbolOffset, symbolLlst, slEmpty, sINext, sISymbol, addToSymboIList, freeSymboIList; FROM Token IMPORT stringType, tokenClass, typeType;

FROM LexAn IMPORT compError;

FROM MyTerminal IMPORT fatal;

FROM StrlngStuff IMPORT stringEqual;

CONST symTabSize = 20;

(* This is NOT an upper limit on the number of symbols,

since we have linked lists coming off of the hashtable entries. Still, the compiler may run faster (because the lists It searches are shorter) if this number is increased. *)

VAR symboI Table: ARRAY[0..symTabSize-1] OF symbol; lexicalLeveI: CARDINAL;

PROCEDURE currentLexLeveI():CARDINAL;

BEGIN

RETURN I exicalLeveI;

END currentLexLeveI;

PROCEDURE enterLocaI(VAR s:stringType; tt:typeType; rout Ine:symboI);

VAR sym:symbol;

BEGIN

sym :* enterSymboI(s, Variable, tt);

setSymboILocaIs(routine, addToSymboI List(sym, symboILocaIs(routine))); END enterLocaI;

PROCEDURE enterFormaI(VAR s:stringType; tt:typeType; routine:symboI);

VAR sym:symboI;

BEGIN

sym enterSymboI(s, Variable, tt);

setSymboIFormals(routine, addToSymboIList(sym, symboIFormals(routlne))); END enterFormaI;

PROCEDURE enterKeyword(s:stringType; tc:tokenClass);

VAR sym:symbol;

BEGIN

sym :« enterSymboI(s, Keyword, tUnknown); setSymbolTokClass(sym, tc);

END enterKeyword;

(*** symbol insertion ***)

PROCEDURE enterSymboI(VAR s:stringType; symc:Symbo1C I ass; tt: typeType):symboI;

(* This does the real work of entering a symbol. It signals an error if a symbol Is redefined. *)

VAR sym:symbol;

h:CARDINAL;

BEGIN

sym := lookup(s, FALSE, h);

IF symboIEmpty(sym) THEN

RETURN insert(newSymbol(s, symc, I exicaILeveI, tt), h);

ELSE

compError(*redefined symbol*);

RETURN sym;

END;

END enterSymboI;

(*** symbol lookup ***)

PROCEDURE findSymboI(VAR s:strIngType):symboI;

VAR sym; symbol;

h: CARDINAL;

BEGIN

sym :« lookup(s, TRUE, h);

IF symbolEmpty(sym) THEN

compError(*undefined symbol*);

RETURN lnsert(newSymbol(s. Undeclared, 0, tUnknown), h);

ELSE

RETURN sym;

END;

END fIndSymboI;

BYTE LISTINGS SUPPLEMENT 55

PROCEDURE findKeyword(VAR s:stringType; VAR tc:tokenCI ass):BOOLEAN;

(* This Is used by the lexical analyzer to return the keyword’s token class. Returns true If the keyword is found; tc will then contain the token class of the keyword. *)

VAR sym:symbol;

h:CARDINAL;

BEGIN

sym ;« lookup(s, TRUE, h);

IF symboIEmpty(sym) OR (symbolClass(sym) <> Keyword) THEN RETURN FALSE;

ELSE

tc :« symbolTokClass(sym);

RETURN TRUE;

END;

END findKeyword;

PROCEDURE Iookup(VAR s:stringType; anything:BOOLEAN; VAR h:CARDINAL);symboI;

(* Looks up the string in the symbol table. Returns the empty symbol if the string isn’t found; if it is. returns the symbol and, in h, the hash value, anything TRUE means: "match anything".

This is what findSymbol uses. We match lexical level on insertion, to check for redefined symbols.

*)

VAR sym; symbol;

syms; stringType;

BEGIN

h :■ hash(s);

sym := symboITabIe[h];

WHILE NOT symboIEmpty(sym) DO symboIString(sym, syms);

IF stringEquaI(syms, s) AND

(anything OR (I exicaILeveI = symboILexLeveI(sym))) THEN RETURN sym;

END;

sym :*= symbo I Next (sym);

END;

RETURN emptySymbol;

END lookup;

PROCEDURE Insert(s:symboI; h:CARDINAL):symboI;

(* Link the symbol into the h'th symbol table entry. The symbol is put at the front of the list. *)

BEGIN

setSymboI Next(s, symboI Tab Ie[h]); setSymboIPrev(s, emptySymbol); symboI Tab Ie[h] := s;

RETURN s;

END insert;

MODULE begRout; (* This needs to be a module because a variable needs to be remembered across invocations. *)

IMPORT symboILexLeveI, setSymboI Offset, symbol, I exicaILeveI;

EXPORT beginRoutine;

VAR num;INTEGER;

PROCEDURE beginRoutine(rname:symboI);

BEGIN

IF symboILexLeveI(rname) <> 0 THEN f* assign a unique number to *) setSymboI Offset(rname, num); non-global procedures *)

INC(num);

END;

INC(lexicalLeveI);

END beginRoutine;

BEGIN

num :« 0;

END begRout;

PROCEDURE endRoutine(rname:symboI);

(* This is the stuff we do at the end of compiling a procedure or function.

The free’s are just to reclaim storage. The remove’s remove the symbols from the symbol table, which is important if some local symbol is shadowing a global symbol. We remove both locals and formals, but we don’t free the formals because we need them for type checking.

We also remove the routines declared at this lexical level, and free

the i r

56 BYTE LISTINGS SUPPLEMENT

formals. We find these routines by searching the entire symbol table—it would probably be better to keep a list of them.

*)

BEGIN

removeSymboIList(symboI Loco Is(rname)); freeSymboIs(symboILocaIs(rname)) ; freeSymboI List(symboILocaIs(rname)) ; setSymboILocaIs(rname, emptySymboIList); removeSymboIList(symboI Forma Is(rname)); removeRoutinesAtThisLeveI;

DEC(lexicalLeveI);

END endRoutine;

PROCEDURE removeSymboIList(symboIp:symbo(List);

BEGIN

WHILE NOT slEmpty(symbolp) DO

removeSymboI(sISymboI(symboIp)); symbolp :* sI Next(symboIp);

END;

END removeSymbolList;

PROCEDURE removeRoutinesAtThisLeveI;

(* Remove all routines defined at this lexical level. Free their formals.

All the symbols at this lexical level will be at the beginning of their respective buckets in the symbol table, and they all will be routines. *)

VAR i:CARDINAL;

s , next:symboI;

BEGIN

FOR i :* 0 TO symTabSize-1 DO s :® symboI Tab Ie[i];

WHILE (NOT symbolEmpty(s)) AND (symboILexLeveI(s) = I exicaILeveI) DO freeSymboIs(symboI Forma Is(s)); freeSymboIList(symboI Forma Is(s));

(* remove this symbol from the table *) next := symboINext(s); symboI Tab Ie[i] :* next;

IF NOT symboI Empty(next) THEN

setSymboIPrev(next, emptySymboI);

END;

freeSymboI(s); s := next;

END;

END;

END removeRoutinesAtThisLeveI;

PROCEDURE removeSymboI(s:symboI);

(* Splice the symbol out of the symbol table. If the symbol is at the beginning of the list, we have to rehash to find the right entry.

Otherwise, just remove It from the list. *)

VAR bucketiCARDINAL;

syms: stringType;

BEGIN

IF symboIEmpty(symboIPrev(s)) THEN symboIStrlng(s, syms); bucket :* hash(syms);

IF NOT symboIEquaI(symboI Tab Ie[bucket], s) THEN fata I('removeSymboI: error*);

ELSE

symbolTable[bucketl :« symboINext(s);

IF NOT symbolEmpty(symbolNext(s)) THEN

setSymbolPrev(symbolNext(s), emptySymbol);

END;

END;

ELSE

setSymbolNext(symbolPrev(s), symboI Next(s));

IF NOT symboIEmpty(symboINext(s)) THEN

setSymboIPrev(symboI Next(s), symboIPrev(s));

END;

END;

END removeSymboI;

PROCEDURE freeSymboIs(symboIp:symboIList);

VAR nextSymbolisymbolLIst;

BEGIN

WHILE NOT sIEmpty(symbolp) DO

(continued)

BYTE LISTINGS SUPPLEMENT 57

nextSymbol sI Next(symboIp); freeSymbol(sISymboI(symboIp)); symboIp :■ nextSymbol;

END;

END freeSymbols;

(*** low-level stuff ***)

PROCEDURE hosh(VAR s:str!ngType):CARDINAL;

(* A simple hosh function: just add up the ASCII values of the characters. *) VAR I, sum:CARDINAL;

BEGIN

i :« 0; sum :» 0;

WHILE s[I] <> 0C DO

sum :« sum + ORD(s[i]);

INC(i);

END;

RETURN sum MOD symTabSize;

END hash;

PROCEDURE InitSymbolTable;

VAR 1;CARDINAL;

BEGIN

FOR 1 0 TO symTabSize-1 DO

symboITabIe[I] :* emptySymbol;

END;

END InitSymbolTable;

BEGIN

initSymboITabIe; lexicalLevel :** 0;

END SymboITabIe.

+++++++

Start Token.DEF +++++++

DEFINITION MODULE Token;

(* Tokens are what the lexical analyzer returns to the parser. Keywords are distinct tokens, as are the special characters like parens, colon, etc. This module also exports typeType, which is a list of the possible types of variables in SIMPL. For now, SIMPL only has integers, booleans and characters. TokenLists are lists of tokens; they are used in the "varlist procedure of the parser.

*)

EXPORT QUALIFIED token, tokenClass, stringType, stringlen, isType, isRelation typeType, tokenCIassToType,

tokenList, emptyTokenList, tIToken, tINext, addToTokenList, tIEmpty, freeTokenList;

CONST stringlen « 80;

TYPE

tokenClass « (And, Assignment, Begin, Boolean, Char, Character, Colon, Comma, Divide, Do, Else, Elsif, End, EndOflnput. Equal, False, Function, Greater, GreaterEquaI, Identifier, If, Int, Integer, Less, LessEqual, Lparen, Minus, Not, NotEqual, Or, Period, Plus, Procedure, Program, Read, Return, Rparen, Semicolon, String, Then, Times, True, UMlnus, Var, While, Write);

stringType = ARRAY[0..stringIen] OF CHAR;

token * RECORD

CASE class:tokenClass OF

Identifier, String: string: stringType; Int: integer: INTEGER;

Character: ch: CHAR;

END;

END;

58 BYTE LISTINGS SUPPLEMENT

January

tokenList;

typeType ■ (tlnteger, tBoolean, tChar, tUnknown);

VAR emptyTokenList: tokenList;

PROCEDURE tokenCIassToType(tc:tokenCIass):typeType;

(* Converts the token class Integer to the type tlnteger, and so on. *)

PROCEDURE isType(tc:tokenCI ass):BOOLEAN;

(* Returns TRUE If tc ■ Integer, Char, or Boolean *)

PROCEDURE isReI ation(tc:tokenCI ass):BOOLEAN;

(* Returns TRUE If tc is a relational operator (Equal, Greater, etc.) *)

PROCEDURE tIToken(tl:tokenList; VAR t:token);

(* Gets the first token in the token list. *)

PROCEDURE 11 Next(tI:tokenList):tokenList;

(* Gets the rest of the token list. *)

PROCEDURE addToTokenList(VAR t:token; tI:tokenList);tokenList;

(* Add a token to the beginning of the token list. *)

PROCEDURE freeTokenList(tI:tokenList);

(* Free the storage used by the token list. *)

PROCEDURE 11 Empty(tI:tokenList):BOOLEAN;

(* Return TRUE if the token list is empty. *)

END Token.

+♦+++++

Start Token.MOD +++++++

IMPLEMENTATION MODULE Token;

(* Tokens and token lists for the SIMPL compiler. *)

FROM Storage IMPORT ALLOCATE, DEALLOCATE;

FROM Terminal IMPORT WriteString;

TYPE tokenList - POINTER TO tokenListRec; (* token lists are linked lists *)

tokenLlstRec * RECORD

tok; token; next; tokenList;

END;

PROCEDURE tokenCIa$sToType(tc:tokenCI ass):typeType;

BEGIN

CASE tc OF

Integer: RETURN tlnteger;

I Boolean: RETURN tBoolean;

Char: RETURN tChar;

ELSE

WriteString('tokenCIassToType: unknown type*);

RETURN tUnknown;

END;

END tokenCIassToType;

PROCEDURE isType(tc:tokenCI ass):BOOLEAN;

BEGIN

RETURN (tc - Integer) OR (tc - Boolean) OR (tc « Char);

END isType;

PROCEDURE IsReI ation(tc:tokenCIass):BOOLEAN;

BEGIN

RETURN (tc - Equal) OR (tc * NotEqual) OR (tc - Greater) OR (tc - GreaterEquaI) OR (tc ■ Less) OR (tc ■ LessEqual);

END IsRelation;

PROCEDURE 11 Token(tI:tokenList; VAR t:token);

BEGIN

IF tlEmpty(tl) THEN

WriteString("tIToken: empty tokenList");

ELSE

[continued)

BYTE LISTINGS SUPPLEMENT 59

jamary

t tr.tok;

END;

END 11 Token;

PROCEDURE 11 Next(tIitokenList)itokenList;

BEGIN

RETURN tr.next;

END 11 Next;

PROCEDURE oddToTokenLIst(VAR t:token; tI:tokenLiet):tokenLIst;

(* Create a token list record for the new token and splice it on to the front of the token list. Return ( a pointer to) the new record. *) VAR newt I: tokenL1st;

BEGIN

NEW(newtl); newtl^.tok :■ t; newt I*.next :* 11;

RETURN newt I;

END addToTokenList;

PROCEDURE freeTokenLlst(tI:tokenL1st);

BEGIN

IF NOT tlEmpty(tl) THEN

freeTokenList(tI Next(t I ));

DISPOSER I );

END;

END freeTokenLIst;

PROCEDURE tlEmpty(tI:tokenL1st):BOOLEAN;

BEGIN

RETURN tl - emptyTokenLIst;

END tIEmpty;

BEGIN

emptyTokenLIst :■ NIL;

END Token.

+++++++

Start TypeChecker.DEF +++++++

DEFINITION MODULE TypeChecker;

(* Handles the actual type-checking of SIMPL expressions and statements. *)

FROM Token IMPORT tokenClass, typeType;

FROM Node IMPORT node;

FROM Symbol IMPORT symbol;

EXPORT QUALIFIED typeCompatIbIe, opApproprI ate, callCheck, readCheck,

writeCheck, boolCheck, assignCheck, binopCheck, unopCheck, returnCheck;

PROCEDURE typeCompatlb Ie(t1, t2:typeType):BOOLEAN;

(* Returns TRUE if tl and t2 are compatible types. In order to avoid cascades of error messages, If one or both of the types is tUnknown, it still returns TRUE. *)

PROCEDURE opAppropriate(op:tokenClass; arg:node):BOOLEAN;

(* Returns TRUE if the type of the argument can be handled by the operator *) PROCEDURE calICheck(routineisymbol; args:node);

(* Checks the procedure or function call for right number and types of args. *)

PROCEDURE readCheck(actuaIs:node);

(* Checks the call to the READ built-in procedure. *)

PROCEDURE writeCheck(actuaIs:node);

(* Checks the call to the WRITE built-in procedure. *)

PROCEDURE boo I Check(ninode);

PROCEDURE assignCheck(varisymbol; exprinode);

PROCEDURE returnCheck(routlneisymboI; exprinode):BOOLEAN;

.h*».

60 BYTE LISTINGS SUPPLEMENT

PROCEDURE binopCheck(op:tokenCloss; leftorg, rightarg:node):BOOLEAN;

PROCEDURE unopCheck(op;tokenCI ass; arg;node):BOOLEAN;

END TypeChecker.

♦+++♦++

Start TypeChecker.MOD ♦+++♦++

IMPLEMENTATION MODULE TypeChecker;

(* Handles type-checking of SIMPL expressions. *)

FROM Node IMPORT node, nodeType, nodeFirst, nodeRest, nodeEmpty, nodeClass, NodeCI ass, nodeSymboI;

FROM Token IMPORT tokenClass, strlngType, typeType;

FROM Symbol IMPORT symbol, symbol Type, symboI Forma Is, symbol List, symbolstring,

sINext, sISymbol, slEmpty, symbo1C IassEquaI, SymbolClass, symbolClass, numFormaIs;

FROM MyTerminaI IMPORT fatal;

FROM LexAn IMPORT compError;

PROCEDURE opAppropriate(op:tokenCI ass; arg:node):BOOLEAN;

BEGIN

CASE op OF

Plus, Minus, UMinus, Times, Divide:

RETURN typeCompatibIe(nodeType(arg), tlnteger);

| Greater, GreaterEquaI, Less, LessEaual:

RETURN typeCompatibIe(nodeType(arg), tlnteger) OR typeCompatibIe(nodeType(arg), tChar);

| And, Or, Not:

RETURN typeCompatlb Ie(nodeType(arg), tBoolean);

| Equal, NotEqual:

RETURN TRUE;

ELSE

fata I("opApproprI ate: unknown op type");

END;

END opAppropriate;

PROCEDURE typeCompatibIe(11, 12:typeType):BOOLEAN;

BEGIN

IF (tl - tUnknown) OR (t2 - tUnknown) THEN RETURN TRUE;

ELSE

RETURN tl - t2;

END;

END typeCompatibIe;

PROCEDURE caIICheck(rout1ne:symboI; args:node);

(* Tricky because formats are stored backwards In symbol, but forwards

in the call to the routine. We do nothing if the symbol Is not a procedure or function; that check is handled in the parser. *)

VAR nFormals, nActuaIs:CARDINAL;

dummy:node;

BEGIN

IF (symboICIass(routIne) « Proc) OR (symboICIass(routIne) * Func) THEN nFormals :- numFormaIs(rout1ne); nActuals :- numActuaIs(args);

IF nActuals < nFormals THEN

compError(* too few arguments to routine*);

ELSIF nActuals > nFormals THEN

compError(*too many arguments to routine*);

END;

dummy :■ argsMatch(symboI Forma Is(routine), args);

END;

END calICheck;

PROCEDURE orgsMatch(fI Ist:symboILIst; a I 1st:node)inode;

(* This procedure matches two lists, one of which is backwards. It does It by recursing down one list all the way, then iterating down the other list while unrecursing. *)

BEGIN

IF sIEmpty(flist) THEN RETURN a I 1st;

(continued)

BYTE LISTINGS SUPPLEMENT 61

allst argsMatch(sINext(fIist) , a I 1st);

IF nodeEmpty(alist) THEN RETURN a Iist;

ELSE

argCheck(sISymboI(fIist). nodeFirst(alist));

RETURN nodeRest(a Iist);

END;

END;

END argsMatch;

PROCEDURE argCheck(formalisymbol; actuaI:node);

VAR s:stringType;

BEGIN

IF NOT typeCompatibIe(symboIType(formaI), nodeType(actuaI)) THEN compError('type of formal does not match type of actual');

END;

END argCheck;

PROCEDURE numActuaIs(actuaIs:node):CARDINAL;

VAR count:CARDINAL;

BEGIN

count 0;

WHILE NOT nodeEmpty(actuals) DO INC(count);

actuals :* nodeRest(actuaIs);

END;

RETURN count;

END numActuals;

PROCEDURE readCheck(actuaIs:node);

VAR argmode;

BEGIN

IF nodeEmpty(actuals) THEN

compError('READ requires an argument');

ELSE

REPEAT

arg nodeFIrst(actuaIs);

IF nodeCIass(arg) <> nSymbol THEN

compError('READ must have a variable as an argument'); ELSIF NOT symbo1C IassEquaI(nodeSymboI(arg), Variable) THEN compError('READ must have a variable as an araument'); ELSIF NOT (typeCompatibIefnodeTypefarg}, tlnteaer) OR typeCompatibIe(nodeType(arg), tCharj) THEN compError('READ can only read integers or characters');

END;

actuals : = nodeRest(actuaIs);

UNTIL nodeEmpty(actuaIs);

END;

END readCheck;

PROCEDURE writeCheck(actuaIsmode);

VAR argmode;

BEGIN

IF nodeEmpty(actuaIs) THEN

compError('WRITE requires an argument');

ELSE

REPEAT

arg :« nodeFirst(actuaIs);

IF NOT (typeCompatibIe(nodeType(arg), tlnteger) OR

typeCompatibIe(nodeType(arg), tChar)) THEN compError('WRITE can only write integers or characters’);

END;

actuals :» nodeRest(actuaIs);

UNTIL nodeEmpty(actuaIs);

END;

END wr1teCheck;

PROCEDURE binopCheck(op:tokenCI ass; leftarg, rightarg:node):BOOLEAN;

BEGIN

IF NOT opAppropriate(op, leftarg) THEN

compError('inappropriate arg type: left arg*);

RETURN FALSE;

END;

IF NOT opAppropriate(op, rightarg) THEN

compError(*inappropriate arg type: right arg');

62 BYTE LISTINGS SUPPLEMENT

RETURN FALSE;

END;

IF NOT typeCompatible(nodeType(leftarg), nodeType(rightarg)) THEN compError(’argument types not compatible*);

RETURN FALSE;

ELSE

RETURN TRUE;

END;

END binopCheck;

PROCEDURE unopCheck(op:tokenClass; arg:node)-.BOOLEAN;

BEGIN

IF NOT opAppropriate(op, arg) THEN

compError(*inappropriate arg type’);

RETURN FALSE;

ELSE

RETURN TRUE;

END;

END unopCheck;

PROCEDURE assignCheck(var:symboI; exprinode);

BEGIN

IF NOT typeCompatible(symbolType(var), nodeType(expr)) THEN compError('types not assignment compatible’);

END;

END assignCheck;

PROCEDURE boolCheck(n-.node);

BEGIN

IF NOT typeCompatibIe(nodeType(n), tBoolean) THEN compError(’Boolean expression expected’);

END;

END boolCheck;

PROCEDURE returnCheck(routine:symboI; expr;node):BOOLEAN;

BEGIN

IF (NOT nodeEmpty(expr)) AND (symbo1C I ass(routine) <> Func) THEN compError(’only functions can return values');

RETURN FALSE;

ELSIF nodeEmpty(expr) AND (symboICIass(routine) <> Proc) THEN compError('function must return a value’);

RETURN FALSE;

ELSIF (NOT nodeEmpty(expr)) AND

(NOT typeCompatibIe(symboIType(routine), nodeType(expr))) THEN compError(’return type not compatible with function type’); RETURN FALSE;

ELSE

RETURN TRUE;

END;

END returnCheck;

BEGIN

END TypeChecker.

prolog.doc

TEXT

"AI in Computer Vision" John L Cuadrado and Clara Y. Cuadrado. January, page 237. Prolog.doc references Pdprolog.exe, which is available in the FromBYTE85 file area on BIX (PC/MS-DOS only).

A.D.A PROLOG Documentation Version 1.7f for the Educational and Public Domain Versions October 28, 1985 Copyright Robert Morein and Automata Design Associates 1570 Arran Wav Dresher, Pa. 19025 (215)-646-4894 News Release 1.7f fixes the last bugs (heh). ANYONE who has ever purchased a copy of any version of A.D.A. PROLOG is entitled to a no-charge update. Simply send us your original disk or a photocopy of the receipt. We have included in prerelease form Simon Blackwell’s magnificent expert system shell. This system is tailored to A.D.A. PROLOG and includes forward and backward chaining, and a linkage method of insuring database consistency. Bayesian reasoning, rule editing, and documentation are forthcoming. The system was developed on VML PROLOG, but it is our intention to expeditiously insure that it runs under PD

( continued )

BYTE LISTINGS SUPPLEMENT 63

PROLOG as well. To that end, we have added I/O redirection, 8 i nc ® '® how

Simon stores things to disk. Copyright Notice The public domain PD PROLOG system has been contributed to the public domain for unrestricted use with one exception: the object code may not be disassembled ^ "lodified.

Electronic bulletin boards and SIG groups are urged to aid in giving this software the widest possible distribution. This documentation may be reproduced freely, but it may not be Included in any other documentation without the permission of the author. Introduction We are pleased to present the third major version of PD PROLOG, version 1.7. Version 1.7 continues to refine "problems" and adds the entertaining feature of IBM PC video screen support. The memory requirements are somewhat greater than the oriqinal, since it is uses the large memory model. It compensates in thoroughness. The memory requirement is about 210K bytes of TPA, and it wi benefit from up to 253k bytes. The ovailolble workspace is 100K bytes. We S^e that ™u’ll get some fun out of this PROLOG It will af or you exposure to THE fifth generation language at the cost only of some "?t 8l ' ec ‘ u81 ,

effort. The motive is perfectly explicable: We want you to think of Automata Design Associates for fifth generation software. It also gives us a nice worm feelina The memory requirement is 200 k of transient program area, P lus whatever space is needed to execute programs from within PROLOG DOS or MSDOS 2 0 are required. The program does not require IBM PC compatibility to run, although the screen access routines do require compatibility. Pr0< ? uc ^ 8 Automata Design Associates Automata Design Associates s P e8 ' 8l '^ es in software for artificial intelligence and robotic appIications. A PROLOG language system is available in various configurations. A LISP interpreter wiI be

introduced in March of 1985. There are five vers 1008 1 ° f M cnos Sr°PCDOS Automata Design Associates. All of them run under the MSDOS or PCDOS operating systems. Other environments will be supported soon. .Public Domain PROLOG This serves to further the general awareness of the public about PROLOG It also is an excellent adjunct to anyone learning the language. Most of the core PROLOG described by Clocksin and Mellish in the book Programming In PROLOG is implemented. A complete IBM PC video screen support library is Included in this and all other A.D.A. prologs. Trace predicates are not This version is available from us for $10.00 postoge paid. .Educational PROLOG At extremely modest cost this affords on educational institution or individual a PROLOG system which provides the maximum available programming area aval la e within the 8086 small programming model. Tracing, a debugging aid, allows monitoring a program as it runs. User settable spy points selectively allow this Exhaustive tracing is also available. I/O redirection gives some file ability. An "exec" function allows the execution of a program or editor from within PROLOG, thus encouraging an interactive environment. An interrupt menu is added, permitting the control of tracing, toggling the printer, and screen printing. Definite clause grammar support is now included. The °\

Educational PROLOG is $29.95. .FSM PROLOG A small increment in price adds full random access file capability. Character and structure I/O are a lowed. The "asserta and "assertz" predicates are expanded and work with a clause indexing ability. One can assert clauses anywhere in the database under precise pattern matching control. A tree structured 1e ^ 80 ‘ ^°Pl n 9® y ®J* lOG and floating point arithmetic are other enhancements. The cost of FSM PROLOG is $49.95 .VMI PROLOG — Virtuol Memory (Replaces type VMS) At reasonable cost the addition of virtuol memory gives an expansion of capabilities of on order of magnitude. The database on disk Is treated transparently. No special provisions need be made by the user. Virtual and resident databases # b * mixed. A unique updating algorithim preserves the format of the database as typed by the user while making only those changes nec ® ss8r y ?

equivalent to the database in central memory The cost of VMI PROLOG is $99 95 VML PROLOG Large model Virtual Memory System A.D.A. PROLOG is a remarkable fifth generation developement tool for . th ® !!" p ! ''

intelligent strategies and optimized control. It is both the kerne for applications of virtually unlimited scope and a sophisticated developement tool that multiplies the productivity of the programmer many times. With a cost/performance ratio exceeding that of any other product an ‘‘ ° .

comDatibiIity insured by compliance to the Edinburgh syntax, performance is enhanced by numerous extensions, many of them invisible to the ^ser. A quic overview of some of the features discloses: 1) Invisible c0, " p ' lat '° n ° semantic network preserves the flexibility of the interpreted mode and the speed of a compiler. The programmer con compile and recompile any portion of a module at any time. The edit/compile/test cycle is short ond free of strain. An interface is provided to an editor of choice. 2) Floating point arithmetic with a full complement of input and output methods, transcendental and conversion functions. 3) Virtuol memory. Module size and number is unrestricted. Resident and virtual modules may be coresident. Compilation incremental. The cache algorithim is sophisticated. Changes made in the database con be updated to disk by a single command. 4) A powerful exec function, and acceptance of stream Input make integration into applications practical. 5) Many additional built-in predicates enhance the efficiency of

64 BYTE LISTINGS SUPPLEMENT

the system. 6) Debugging facilities let you see your program run without any additional generation steps. 7) Totally invisible and incremental garbage collection. There is NEVER any wait for this function. The cost of this system is $200 for the MSDOS version. Upgrade Policy Half the cost of any A.D.A. PROLOG interpreter may be credited to the purchase of a higher level version. The full cost of VMS prolog may be applied to the purchase of VMI or VML PROLOG. Updates to a particular level product vary from $15.00 to $35.00.

Run-time Packages Software developers wishing to integrate an A.D.A. product into their system should inquire about specialized run-time packages available at reasonable cost. Technical Information Technical information may be obtained at (215) - 646- 4894 Perhaps we can answer the following questions in advance: There is no support for: APPLE II, Atari, Commodore, or CPM 80 .

Other machines from these manufactures may be supported in the future. The MSDOS products are available on 5" and 8" diskettes. To Place Your Order: You may place your order at the following number: (215)-646-4894 - day and night.

Returns The software may be returned within 30 days of purchase for a full refund. This applies whether or not the software has been used. We do ask that manuals, disks and packaging be returned in excellent condition. How to run the Demonstration Programs without Knowing What You're Doing We strongly advise that you purchase the book Programming in PROLOG by Clocksin and Mellish, publisher Springer Verlag, 1981. For the impatient we give some advice. Type the demonstration program you wish to run. There must be at least one entry point within the program. Note: Please understand that these are demonstrations programs. Regarding user interface, they are poorly written. You will probably have to read Clocksin and Mellish to appreciate that the following examples of input are not equivalent: "yes." , "yes" . The animals program - "animal" Most of the examples require C & M for comprehension. The program "animals", however, can be appreciated by anyone.

It is a traditional example of an expert system. We had hoped to include the animals program on disk, but we have found to our dismay that the version which we used is allegedly copyrighted by the implementors of PROLOG 86.

Don't be surprised - even "happy birthday" is copyrighted. We will simply point out that the November *84 issue of Robotics Age included a version of the animals game, which you can, at the risk of copyright infringement, type in. There is only one change that need be made. The "concat" function used in that program has arguments of the form: concat( [atoml, atom2,...], result ).

In order to make the concat definition more closely resemble that of "name", which is described by Clocksin and Mellish, the argments have been reversed: concat( result, [atoml, atom2,...] ) Assuming that you have typed in the program and made the change just noted, the following steps are required to run it: Run the prolog.exe file. The prompt "?-" will appear. Type "consult(

'animals' ).<CR>". Here <CR> indicates you are to type a carriage return. The PROLOG system will load "animals" and compile it into an internal form. When the "?-" prompt appears PROLOG is ready to run the "animals" guessing game.

The object of the program is to deduce the animal you are thinking of. To start it off type "help.<CR>". PROLOG will respond by asking a question.

Because of the way the animals program is written, you must respond in a rigid format. You may type "yes<CR>", "no<CR>", or "why<CR>". Eventually the program will terminate with either a guess as to what animal you are thinking of, or a remark that the animal is not within its domain of knowledge. The program has learned, however. You may run the program again to see what effect additional knowledge has on the program’s behavior. The program fragment "console" shows how you may improve the console input routines of any of these programs. The Hematology Diagnosis Program - "hemat" Although the logical structure is not as sophisticated as that of "animals", it is interesting for several reasons: 1) The program evaluates numerical data to arrive at a diagnosis. 2) Although inaccurate, it demonstrates that useful question answering systems are not difficult to write in PROLOG. 3) There are some mistakes in the program, which only slightly impede its usefulness.

This program uses structure input. Terminate all your answers with a period, as in "y.<CR>", or "no.<CR>". The starting point is "signs.<CR>". PROLOG will prompt you for signs of anemia. The program attempts to diagnose two varieties of a hemolytic anemia. The program could use a good working over by a hematologist and we would be delighted to collaborate. Prime Number Generator - "sieve" This program demonstrates that anything can be programed in PROLOG if one tries hard enough. Asking the question "primes( 50, L ).<CR>" causes a list of prime numbers less than 50 to be printed out.

"Sieve" is heavily recursive and quickly exhausts the stack space of the small model interpreters. Grrules This is an example of the use of the definite clause grammer notation. PD PROLOG does not have this translation facility, but ED PROLOG and all of our other versions do. It is possible to perform the translations by hand If you have thoroughly read C Sc M. Then you would have the pleasure of asking: ?-sentence( X, [every,man,Ioves,a,woman],

[] ). and having the meaning elucidated as a statment in the predicate calculus. Special Offer # 1 For some inexplicable reason, demonstration

( continued )

BYTE LISTINGS SUPPLEMENT 65

progroms are hard to come by. We are too busy writing PROLOG fill this gap.

We wi I reward the contribution of "cute" sample progroms with the following: 1) A free copy of type VMS virtual memory PROLOG 2) The sample program w II be published as an Intact file together with whatever comments or advertlsments the outhor may see fit to Include, on our distribution disks.

i) Exceptional contributions may merit a copy of type VML large model virtual memory PROLOG which now Incorporates a UNIX1 style tree structured domain *y*t*m« Special Offer # 2 If you ore a hardware manufacturer and would like a PROLOG language for your system, the solution is simple. Just send us one of your machines! Provided your system Implements a "C" compiler, it will

ED PROLOG Y«„ n L t ! m ? I lat *, - K Tr ? d «»>ork AT & T. Writing Progroms For

ED PROLOG You do not type In progroms at the prompt. There is no built

T ^ e comn ' and consu 11( user )" is accepted but does not cause PROLOG to enter on editing mode. We feel that the most universally acceptable editing method B th « us « r use a text editor of choice, which can be

invoked from within PROLOG by the "exec" predicate. Use Wordstar or your customary editor to write a program. Then run PD PROLOG and use the consult function to load the program. In all cases except PD PROLOG, you con run your editor without leaving PROLOG by use of the "exec" predicate. Running the V Interpreter COMM A NDS.- Give commands in lower case. TO RUN: Invoke PROLOG.EXE After the ?- prompt appears, type "consult( <fiIename><CR> )", where

! s J he desired database. To exit, type M exi tsys .<CR>" TO ASK A QUESTION. At the prompt, type "<expression>.<CR>", where <expression> is a question as described by Clocksin and Mellish. Be sure to terminate the

The d ues tion may be up to 500 characters long. TO INPUT A STRUCTURE AT THE KEYBOARD: The structure may be up to 500 characters in length. Be sure to terminate with a period. TO ASK FOR ANOTHER SOLUTION' * 8 ° lu "r b ? 8 Prid'd, the PROLOG interpreter will ask "More?

ABORTYrfargh ? 1® ty ?! d 1 1 the inter P r «t«r perform a search. TO

ABORT A SEARCH: Simply type the escape key. The interpreter will respond with interrupted. . and return to the command prompt. TO LOAD ANOTHER DATABASE: ype consuIt(<fiIename>).<CR>" The file name must have the extension " PRO" It is not necessary to include the extension in the argument of consult! The’ file name as given must not be the same as a predicate name in the file or any fiIe which wiI I be loaded. TO REMOVE A DATABASE: Type

"forget(<filename>) ; <CR>" TO EXIT TO THE OPERATING SYSTEM: Type "ex 1tsys,<CR>" e system is totally interactive; any commands the operator gives ore and must be valid program statements. Statements must terminate with a period.

is no+ m n a Cn?iH h pprti ftr k * * f '1® a1s0 accept a path name. Any name which

is not a valid PROLOG atom (refer to C & M) must be enclosed In single

quotes. Thus one could say consult( expert ) but one would need single quotes with consult( b:\somples\subtype\expert* ). To exit the system, type exitsys.<CR> Atoms may contain MSDOS pathnames if they are enclosed by

8 l n9 +in,» UO u® 8 ’ *" ‘\ b: \ 8am P | ««\anlmal ’ . You may consult more than one file

at a time. However, all names are public and name conflicts must be avoided.

IffAr+ de thi n h W K IC ^ m °~ u ® 8 are loaded may, in cases of poor program design, affect the behavior. Command Line Arguments ED PROLOG accepts one command ine argument, which s the name of a "stream" which replaces the console for mput The stream" in MSDOS is a pipe or file which supplies input unt it end-of-file is reached. Control then reverts back to the console. To avoid

?hi S fi^ rS ! r r SS ? 9 ® 8 wh8n «"d-of-flle is reached, the last command in

the file should be see( user )." A Reference of Note With minor exceptions, the syntax is a superset of that described by Clocksin and Mellish in the book Programming n Prolog by W.F. Clocksin and C.S. Mellish. published by Springer Ver la 9 i * n BerI in. Heidelberg, New York, and Tokyo. We shall refer to this book as C & M . There are very few syntactical differences, mostly unrecognized and/or minor. When an operator is declared using the "op" * statement, the operator must be enclosed in single quotes in the "op" statement itself, if it would not otherwise be a legal Edinburgh functor. Subsequently however, the parser will recognize it for what it is, except in the unop statement, where it must again be enclosed in single quotes. Variable numbers of functor paramaters are supported. A goal may be represented by a variable, which is less restrictive than the C & M requirement that all goals be functors. The variable must be instantiated to a functor when that goal is pursued. Rules which appear inside other expressions must be enclosed in parenthesis if the operator is to be recognized as a logical connective. All infix operators described by C & M and user defined infix, prefix, and postfix operators with variable associativity and precedence are supported exactly as in C & M. The Built In Predicate Library Available Operators in PD and ED PROLOG Column 1 gives the function symbol Column 2 gives the precedence. The range of precedence is 1 to 255. A zero in the precedence column indicates the symbol is parsed as a functor, and precedence is meaningless in this case. Column 3 gives the associativity. A zero in the associativity column indicates the symbol is parsed as a functor, and associativity is meaningless in this case. Column 4 indicates which version the function is available in. Unless otherwise noted,

66 BYTE LISTINGS SUPPLEMENT

the function is available in all versions. Nonstandard predicates are indicated by "NS", op/pred precedence associativity availability "!" 0 0 "|" 0 0 40, XFX "—" 40, XFX "\\«" 40, XFX "\\==" 40, XFX "/" 21. YFX "@="

40, XFX ">=" 40, XFX "=<" 40, XFX ">" 40, XFX "<" 40, XFX "-" 31, YFX "*" 21, YFX "+" 31, YFX 40, XFX 255, YFY (not in PD PROLOG) "?-"

255, FY "arg" 0, 0, "asserta" 0, 0, "assertz" 0, 0. "atom" 0, 0,

"atomic" 0, 0, "clause" 0, 0, "clearops" 0, 0, "els" 0, 0, NS "concat" 0,

0, "consult" 8, FX, "crtgmode" 0, 0, NS "crtset" 0, 0, NS "curset" 0, 0, NS "curwh" 0, 0, NS "debugging 0, 0, "dir" 0, 0, "display" 0, 0, "dotcolor" 0,

0, NS "drawchar" 0, 0, NS "drawdot" 0, 0. NS "drawline" 0, 0, NS "exec" 0, 0,

"exitsys" 0, 0, NS "forget" 0, 0, NS "functor" 0, 0, "get0" 8, FX,

"integer" 0, 0, "is" 40, XFX, "listing" 0, 0, "mod" 11, XFX, "name" 0, 0,

"nl" 0, 0, "nodebug" 0, 0, (not in PD PROLOG) "nonvar" 0, 0, "nospy" 50, FX,

(not in PD PROLOG) "not" 60 FX "notrace" 0. 0, (not in PD PROLOG) "op" 0, 0,

"popoff" 0, 0. NS "popoffd" 0, 0, NS "popon" 0, 0, NS "popond" 0, 0, NS

"print" 0, 0, "prtscr" 0, 0, NS "put" 0, 0, "ratom" 0, 0, "read" 0, 0,

"recon" 0, 0, (Note: this is "reconsuIt") "repeat" 0, 0, "retract" 0, 0

"rnum" 0, 0, "see" 0, 0, (not in PD PROLOG) "seeing" 0, 0, (not in PD PROLOG)

"seen" 0, 0, (not in PD PROLOG) "skip" 0, 0. (not in PD PROLOG) "spy" 50, FX,

(not in PD PROLOG) "tab" 0, 0. "tell" 0, 0, (not in PD PROLOG) "telling" 0.

0, (not in PD PROLOG) "told" 0, 0, (not in PD PROLOG) "trace" 0, 0, (not in PD PROLOG) "true" 0, 0, "unop" 0, 0, "var" 0, 0, "write" 0, 0, Description of the Modifications. call( <goal> ) The predicate as defined in C & M is obsolete. The purpose was to permit a goal search where the goal name was a variable instantiated to some functor name. A.D.A. permits writing of goals with such names, so the mediation of the "call" clause is no longer necessary. The "call" predicate may be trivially implemented for compatibility with the PROLOG definition caI I( X ) :- X. clause The function clause( X, Y ) has the new optional form clause( X, Y, I ). If the third variable is written, it is instantiated to the current address of a clause in memory. The only use of the result is with succeeding assertfa and assertfz statements, debugging "Debugging" prints a list of the current spypoints.

After each name a sequence of numbers may appear, indicating the number of arguments that is a condition of the trace. The word "all" appears if the number of arguments is not a condition of the trace. op( <prec>, <assoc>,

<functor> ) Defines the user definable grammar of a functor. The definition conforms to that In C k M. We mention here a minor but important point. If <functor> is not a valid PROLOG atom it must be enclosed in single quotes when declared In the "op" declaration. It is not necessary or legal to do this when the functor is actually being used as an operator. In version 1.6, a declared or built-in operator can be used either as an operator or as a functor. For example, +(2,3) « 2 + 3. is a true statement. Declared operators are annotated in the directory display with their precedence and associativity. Output predicates display write print put These functions have been modified to accept multiple arguments in the form: print( <arg1>,

<arg2>, <arg3>,... ) Thus, "put( a, b, c )" would result in the display of "abc". The names of some PROLOG atoms that may occur are not accepted by the PROLOG scanner unless surrounded by single quotes. This only applies when such an atom is read in, not when it is internally generated. Nevertheless, this presents us with a problem: We would like to be capable of writing valid PROLOG terms to a file. In some cases, it is necessary to add the single quotes. In other cases, such as human oriented output, they are an irritant.

The modified definitions of the following predicates are an attempt at a solution: display Operator precedence is ignored, all functors are printed prefix and single quotes are printed if needed or they were supplied if and when the atom was originally input, write Operator precedence is taken into account and operators are printed according to precedence. Single quotes are printed under the same conditions as for "display." print Operator precedence is taken into account and operators are printed according to precedence.

Single quotes are never displayed. This is a human oriented form of output and should never be used for writing of terms for the PROLOG scanner. get0 read The functions "get0" and "read" have been extended to support input from a stream other than the one currently selected by "see". To direct output to a file or other stream, an optional argument is used. For example, "get0( char, <flle name> )" or "get0( char, user )" would cause Input to come from <file name> or the console. If the file has not already been opened, "get0" will fall. Atoms enclosed by single quotest, eg. *\nthis is a new line* can contain the escape sequences '\n', *\r*, '\t* and * V * . If these atoms are printed by "display" or "write" they are printed just as they are. If they are printed by the "print" clause they are translated as follows: *\n* results in the printing of a carriage return and a line feed. '\r* results in the printing of a carriage return only. *\t* results in the printing of a tab character. allows the printing of a single quote within a quoted atom.

The "portray" feature is not presently implemented. Description of the New Predicates clearops- Nullify the operator status of every operator in the

(continued)

BYTE LISTINGS SUPPLEMENT 67

database. concat( (<varlable> | <functor>), <Ust> ) A list of functors or operators is concatenated into one string, which becomes the name of a new atom to which <variable> or <functor> must match or be instantiated. dir( option ) Provide an alphabetized listing to the console of atoms, constants, or open files. Without options, simply type "dir.<CR>". Options are: dir( pred ) - list clause names only, dir( files ) - list open files only, exitsys Exit to the operating system. forget( <file name> ) Make a database unavailable for use and reclaim the storage it occupied. ratom( <arg>, <stream> )- Read an atom from the input stream, to which <arg> matches or is instantiated. <stream> is optional. If <stream> is not given, the input stream defaults to the standar input. Input is terminated by a CR or LF, which are not included in the stream. Arithmetic Capabilities Integer arithmetic is supported. Numbers are 32 bit signed quantities. The following arithmetic operators are supported: "/", <, <-, >, >«, mod. Arithmetic

operators must never be used as goals, although they may be part of structures. It is legal to write: X « a + b which results in the instantiation of X to the struture (a + b). But the following is not legal: alpha( X, Y ) :- X + Y, beta( Y ). Evaluation of an arithemtic expression is mediated by the “is" and inequality predicates. For instance, the following would be correct: alpha( X, Y, Z ) :- Z is X + Y. beta( X, Y) :- X + 2 < Y + 3. IBM PC Video Display Predicates A high level method is provided for drawing and displaying on the screen of IBM PC and compatible computers, els Clear the screen and position the cursor at the upper left hand corner. crtgmode( X ) Matches the argument to the mode byte of the display which is defined as follows: mode meaning 0 40 x 25 BW (default) 1 40 x 25 COLOR 2 80.x 25 BW 3 80 x 25 COLOR 4 320 x 200 COLOR 5 320 x 200 BW 6 640 x 200 BW 7 80 x 25 monochrome display card crtset( X ) This sets the mode of the display. The argument must be one of the modes given above. curset( <row>, <column>, <page> ) Sets the cursor to the given row, column, and page. The arguments must be Integers. curwh( <row>, <column> ) Reports the current position of the cursor. The argument must be an integer or variable. The format is: 1) page zero Is assumed. 2) The row is In the range 0 to 79, left to right. 3) The column is in the range 0 to 24, bottom to top. dotcolor( <row>, <column>, <color> ) The argument <color> Is matched to the color of the specified dot. The monitor must be in graphics mode. drawchar( <character>, <attribute> ) Put a character at the current cursor position with the specified attribute. The arguments <character> and <attribute> must be integers. Consult the IBM technical reference manual regarding attributes. drawdot( <row>, <column>, <color> ) Put a dot at the specified position. The monitor must be in the graphics mode. The arguments must be integer. The argument <color> is mapped to integers by default In the following manner: drawline( <X1>, <Y1>, <X2>, <Y2>, <color> ) Draw a line on the between the coordinate pairs. The monitor must be in the graphics mode and the arguments are integer, prtscr Print the screen as it currently appears. Be sure that the printer is on line and ready before invoking this predicate, since otherwise, the system may lock up or abort. The integer argument <color> referred to in the above predicates is represented as follows: COLOR PALETTE 0 PALETTE 1 0 background background 1

green cyan 2 red magenta 3 brown white To change the palette and the background, see the IBM Technical Reference Bios listings for more information. Trace Files (type ED only) You can now dump your trace to disk, instead of (groan) wasting reams of printer paper. This option is described in the next section. The Interrupt Menu (type ED only) This menu has been modified. It was formerly called the ESCAPE menu, but the meaning of the ESCAPE key has been redefined. It is no longer necessary to display the menu to perform one of the menu functions. This reduces the amount of display which is lost by scrolling off the screen. At any time while searching, printing, or accepting keyboard input, you can break to this menu. It is generally not possible to do this during disk access, since control passes to the operating system at this time. Two keys cause this break to occur: ^V: The menu is displayed and a command is accepted at the prompt "INTERRUPTS'. After a command, the menu is redisplayed until the user selects a command which causes an exit. *1: The menu Is not displayed. Command is accepted at the prompt "INTERRUPTS' until the user selects a command which causes an exit. ESC: Typing this key causes a termination of the PROLOG search and control returns to the user command level with a prompt of Notice that

previously, the ESC key invoked this menu. As the resulting menu indicates, the following functions are possible: A: Abort the search and return to the prompt. 0 Open a trace file. The user is prompted for the file name. The file receives all trace output. If a file is already opened it is closed with all output preserved. C Close the trace file if one is open. Otherwise there is no effect. ^C: Immediately exit PROLOG without closing files. This is not advised. ~P: Typing <Control>P toggles the printer. If the printer is on, all input and output will also be routed to the printer. S: If the machine in use is an IBM PC compatible machine, the currently displayed screen will be printed. If the machine is not an IBM PC compatible, do not use this function. T: If trace is in use, most of the trace output can be temporarily

68 BYTE LISTINGS SUPPLEMENT

turned off by use of this function, which is a toggle. R: Entering another ESC causes a return to the current activity (keyboard input or search) with no residual effect from the interruption. Conserving memory space Success popping is controlled by the predicates "popond", "popoffd", "popon", and "popoff". Success popping is means of reclaiming storage which is used on backtracking to reconstruct how a particular goal was satisfied. If it is obvious that there is no alternative solution to a goal this PROLOG system is smart enough to reclaim that storage. In this system, succees popping is an expensive operation. Therefore, there is a tradeoff of memory versus time. On the other hand, discrete use of success popping can actually speed up a program by recreating structures in a more accessible form. The definitions of the control predicates is given in this manual and their use is totally optional. The modulation of success popping has no effect on program logic (read solution.) The "cut" can save substantial time and computational overhead as well as storage. Although the execution of the cut costs time, you can design your program to use cuts in critical places to avoid unnecessary backtracking. Thus the execution speed of the program can actually increase. Anyone who has read Cfocksin and Mellish is aware, of course, that the "cut" has a powerful logical impact which is not always desirable, popoff See the below definition, popon The inference engine does complete success popping for goals which appear after "popon". Consider this example: goal a, popon, b, c, popoff, d. If no alternative solutions exist for b, then success popping will reclaim storage by removing unnecessary records describing how "b" was satisfied. If the Prolog system cannot rule out possible additional solutions, success popping will never occur, regardless of your use of "popon". Since goal "d" occurs after "popoff", success popping will never occur, popoffd If no "popon" or "popoff" declarations occur in a clause, the default action is determined by "popoffd" and "popond". If "popoffd" has been invoked, the default is that success popping will not occur, popond The inverse of "popoffd". Turns on default success popping. printf( <stream>, <term1>,<term2>,... ) Prolog Tutorial Introduction Probably you have heard of the language PROLOG within the last year or so. You probably wondered the following things: 1) What does the name stand for? Names of computer languages are almost always acronyms. 2) What is it good for? 3) Why now? 4) Can I get a copy to play with? Congratulations!

You obviously know the answer to the fourth question. We now respond to the other three. 1) The name stands for "programming in logic." This we shall elaborate on in depth later on. 2) PROLOG is good for writing question answering systems. It is also good for writing programs that perform complicated strategies that compute the best or worst way to accomplish a task, or avoid an undesirable result. 3) PROLOG was virtually unknown in this country until researchers in Japan announced that it was to be the core language of that country’s fifth generation computer project. This is the project with which Japan hopes to achieve a domainant position in the world information industry of the 1990’s. PROLOG is one of the most unusual computer languages ever invented. It cannot be compared to FORTRAN, PASCAL,

"C", or BASIC. The facilities complement, rather than replace those of conventional languages. Although it has great potential for database work, it has nothing in common with the database languages used on microcomputers.

Perhaps the best point to make is that while conventional languages are prescriptive, PROLOG is descriptive. A statement in a conventional language might read: jf( cartwheels ■ TRUE ) then begin (some sort of procedure) X = X + 1; end A statment in PROLOG could just be a statment of fact about cars and wheels. There are many relationships that hold. For instance, has( car, wheels ). has( car, quant(wheeIs, four) ). round( wheels ). Each of these statments is an independent fact relating cars, wheels, and the characteristics of wheels. Because they are independent, they can be put into a PROLOG program by programmers working separately. The man who is a specialist on car bodies can say his thing, the wheel specialist can have his say, and the participants can work with relative independence. And this brings to light a major advantage of PROLOG: PARALLEL PROGRAMMING!!! With conventional programming languages projects can still be "chunked", or divided between programmers. But efficiency on a team project drops drastically below that of the individual programmer wrapped up in his own trance. As the number of participants grows the need for communication grows geometrically. The time spent communicating can exceed that spent programming! Although PROLOG does not eliminate the need for task coordination, the problem is considerably simplified. It also provides the ability to answer questions in a "ready to eat form." Consider your favorite BASIC interpreter. Based upon the statements about cars and wheels previously given, could you ask It the following question? has( car, X ), round( X ).

Does a car have anything which is round? The question instructs the PROLOG interpreter to consider all the objects that It knows are possessed by a car and find those which are round. Perhaps you are beginning to guess that PROLOG has the abilities of a smart database searcher. It can not only find

[continued)

BYTE LISTINGS SUPPLEMENT 69

the facts but selectively find them and Interpret them. Consider the prob em of a fault tree, as exemplified by this abbreviated one: {Car won t start* |

I [Engine turns over](No) —> [Battery voltage](no)-\ (Yes) v | [Check battery* | [Smell gasolIne](yes) —> [Try full thrott e cranking* | (failure)

/_/ I (detaiIs omitted) The fault tree is easily programmed In BASIC.

Later we shall show that PROLOG supplies a superior replacement for the fau t tree Though the tree is capable of diagnosing only the problem for which it was designed, PROLOG dynamically constructs the appropriate tree from facts and rules you have provided. PROLOG is not limited to answering one specific question. Given enough Information, it will attempt to find all deductive solutions to any problem. PROLOG PRIMER I. Rules ond Facts This is where you should start if you know nothing about PROLOG. Let us consider a simple statment in PROLOG, such as: 1) has( car. wheels ). This statement is a tact. The word "has" in this statment is known either os a functor or predicate. It is a name for the relationship within the parenthesis. It mplies that a car has wheels. But the order of the words inside the bracket is arbitrary and established by you. You could just as easily soy: 2) hos( wheels, car )•

If you wrote this way consistently, all would be well. The words has, wheels, and car are all PROLOG atoms. "Wheels" and "car" areconstants. A database of facts con illustrate the data retrieval capabilities of PROLOG. For instance: 3) has( car, wheels ). has( car, frame ). has( car, windshield ). hos( car, engine ). You could then ask PROLOG the ques*i°n: 4> ha s ( car. Part ) The capital "P" of Part means that Part is a variable. PROLOG will make Part equal to whatever constant Is required to moke the question match one of the facts in the database. Thus PROLOG will respond: Port - wheels.

More?(Y/N): If you type "y" the next answer will oppeor: Part - frame. More?(Y/N): If you continue, PROLOG will produce the answers Part - windshield and Port = engine. Finally, you will see: More?(Y/N):y No. Indicating that PROLOG has exhausted the database. Incidentally, when a variable is set equal to a constant or other variable, it is said to be Instantiated to that obiect. Notice that PROLOG searches the database forwards and in this case, from the beginning. The forward search path is built Into PROLOG and cannot be changed. An author of a program written in a prescriptive angu<»g« '• quite conscious of the order of execution of his program, wh le in PROLOG t is not directly under his control. The other major element is the rule which is a fact which is conditionally true. In logic this is called a Horn clause: 5) has( X, wheels ) iscar( X ). The fact iscar( car ) and the above rule afi equlvoient to 6) has( car, wheels). The symbol :- is the.“rule sign." The expression on the left of :-ls the "head" and on the right is the body. The variable X has scope of the rule, which means that it has meaning only within the rule. For instance, we could have two rules in the database using identically named variables. 7) has( X. transportation ) ^as( X car ). has( license, X ). 8) has( X. elephant ) istrainer( X ). hasjob( X ).The variables X in the two expressions are completely distinct and hove nothing to do with each other. The comma between hos( X, car ) and has( icense,X ; means "and" or logical conjuction. The rule will not be true'unless b ?* h clauses has(X. car) and hos( license. X ) are true. On the other hand if there is a rule 9) hos( license. X ) passedexam( X ). consider what PROLOG will do in response to the question: 18) has( harry, transportation ). (Notice that harry has not been capitalized because we do not want it taken as 0 ?u|

We could however, say ’Harry* enclosed in single quotes.) It will scan the database and use (7). in which X wlI I be instantiated to harry. The rule generates two new questions: 11) has( harry, car ) .12) has( ' c ®"*®’

Assuming that harry has a cor, the first clause of (7) is satisfied and the

database is scanned for a match to (12). PROLOG picks up rule (9) in which X

is instantiated to harry and the question is now posed: 13) passedexam( harry ). If there is a fact: passedexam( harry ). in the database then all is well and harry has transportation. If there is not, then PROLOG will succinctly tell you: No. But suppose Harry has money and can hire a chauffer as any good programmer can. That could be made part of the program in the following way

The rule which PROLOG tried to use was: 14) has( X, transportation ) :- ^as(

X car ), has( license, X ). At any point following it there could be included another rule: 15) has( X, transportation ) :- has( X, money ). or simply the bald fact: 16) has( harry, transportation ). These additional rules or facts would be used in two circumstances. If at any point a rule does not yield a solution, PROLOG will scan forward from that rule to find another appIicab Ie one. This process is known as "backtracking search" and can be qu!te time consuming. If in response to the "More?" prompt you answer "y PROLOG wiI I search for an additional distinct solution. It will attempt to find an alternate rule or fact for the last rule or fact used. If that faiI:s, 1 1 wi back up to the antecedent rule and try to find an alternate antecedent. And it will continue to back up until it arrives at the question you asked, at which Doint it will say: No. "Antecedent" to a rule means that it gave rise to its* use. For example, (7) is the antecedent of (9) in the context of the question (16). II. Grammar Jt is a boring subject, but it must be discussed. All PROLOG statements are composed of valid terms, possibly a rule sign {

70 BYTE LISTINGS SUPPLEMENT

"), commas representing conjunction ("and"), and a period at the very end. A term is a structure, constant, variable, or number. What is a structure? It is a kind of grouping: 1) Structures consist of a functor, and a set of objects or structures in parenthesis. 2) Objects are constants, variables, numbers, or lists, which we have not discussed yet. 3) A constant or functor must be a string of letters and numbers, beginning with a lower case letter, unless you choose to enclose it in single quotes ( ’howdy pardner* ), in which case you are freed from these restrictions. 4) A variable must be a string of letters and numbers beginning with a capital letter. 5) A functor may optionally have arguments enclosed in parenthesis , as in: hascar( X ) or hascar. An example: "has( X, transportation )." is a structure. III. Input / Output You now know enough to write simple databases and interrogate them profitably. But before we examine more sophisticated examples, it will be necessary to add input and output to the language. There are built in functions which appear as rules which are satisfied once. Thus the statment: write( * He I Io world.* ). can be included on the right side of a rule: greetings( X ) :- ishuman( X ), write( 'Hello world.* ). You can also write "write( X )" where X is some variable. Note that ’Hello world.* is not enclosed in double quotes. Single quotes, which denote a constant, are required. Double quotes would denote a list, which is another thing entirely. Provided that a match to "ishuman" can be found, the builtin function "write" is executed and the message printed to the screen. The builtin read( X ) reads a "structure" that you input from the keyboard. More formally, we have read( <variable> or <constant> ) write( <variable> or <constant> ) If you write read( Input ), then the variable "keyboard" will be assigned to whatever is typed at the keyboard, provided that the input is a valid PROLOG structure. The builtin "read" will fail if instead of Keyboard we wrote read( baloney ), where "baloney" is a constant, and the user at the keyboard did not type exactly "baloney." When you input a structure in response to a "read" statement, be sure to end it with a period and an <ENTER>. There is a convenient way of putting the cursor on a new line. This is the builtin "nl". For example: showme :- write( *line 1* ), nl, write( ’line 2* ). would result in: line 1 line 2 There is also a primitive form of input/output for single characters. It will be discussed later. IV. A Fault Tree Example Consider the "won’t start" fault tree for an automobile: {Car won't start} | | [Engine

turns over](No) —> [Battery voItage](no)-\ (Yes) v | {Check battery} | [Smell

gasoline](yes) —> {Try full throttle cranking} | (failure) /-/ | |

/-/ || III [Check for fuel line Ieaks](yes)—

>{Replace fuel line} | (no) j j | | | TCheck for defective carburator](yes)—\

I (no) v I {Repair carburator} \-\ | | [Is spark present](no)—>[Do points

open and close](no)-\ | (yes) v /-/ | {Adjust points} |

/-/ | | | [Pull distributor wire, observe

spark](blue)—\ | (orange) v j j {Check plug wires & cap} | | | [Measure voltage on coil primary](not 12V)—\ | (12V) v | | {Check wiring, ballast resistor} | | | [Check condenser with ohmmeter](conducts)—\ | (no conduction) v | | {Replace condenser} | | | [Open and close points](voItage not 0 - 12)—\ | (voltage swings 0 - 12) v | j {Fix primary circuit} | | | {Consider hidden

fault, swap components] | | \-{Call a tow truckl!} A PROLOG program to

implement this is simple. Each statment represents a decision point fragment of the tree. The PROLOG interpreter dynamically assembles the tree as it attempts a solution. ’car wont start* :- write( 'Is the battery voltage low?* ), affirm, nl, write( 'Check battery* ). 'car wont start' :- write( ’Smell gasoline?' ), affirm, nl, ’fuel system*, 'fuel system’ write( 'Try full throttle cranking' ). ’fuel system' :- write( 'Are there fuel line leaks?' ), affirm, nl, write( 'Replace fuel line.’ ). ’fuel system’ :-write( 'Check carburator’ ). 'car wont start* :- write( 'Is spark present?' ), not( affirm ), nl, 'no spark*, 'no spark' wrlte( ’Do points open and close?' ), not( affirm ), nl, write( 'Adjust or replace points.' ). 'no spark* :- write( ’Is the spark off the coil good?’ ), affirm, write( ’Check plug wires and cap.' ). 'no spark* write( 'What is the voltage on the primary of the coil:

' ), read( Volts ), Volts < 10, nl, write('Check wiring and ballast resistor.'), 'no spark' :- write( 'Does the capacitor leak?’ ), affirm, write( 'Replace the capacitor.* ). 'no spark* :- not( ’primary circuit* ). 'primary circuit' :- write( 'Open the points. Voltage across coil?:'), nl, read( Openvolts ), Openvolts < 1, write( 'Close the points. Voltage across coil?:'), read( Closevolts ), Closevolts > 10, nl, write( 'Primary circuit is OK.' ). 'no spark' wrlte( 'Consider a hidden fault. Swap cap, rotor,points,capacitor.' ). 'Car wont start' write( 'Get a tow truck!!' ). —End program— The above is a simple example of an expert system. A sophisticated system would tell you exactly the method by which it has reached a conclusion. It would communicate by a "shell" program written in PROLOG which would accept a wider range of input than the "valid structure" required by the PROLOG interpreter directly. V. Lists Consider a shopping list given you by your wife. It is a piece of paper with items written on It in an order that probably symbolizes their importance. At the top it may say

(continued)

BYTE LISTINGS SUPPLEMENT 71

January

EGGS!!! dog, if carrots, hamburger, and carrots cannot

followed by carrots, hamburger, and finally a flea collar for the you can find one. In PROLOG such a list would be written: 1) [eggs,

fleacollar] The order of a list is important so that eggs be reversed and PROLOG be uncaring. Let us put the list in

a structure: shopping( [eggs, carrots, hamburger, fleacollar] ). Then if you wished to isolate the head of the list you could ask the question: shopping(

[ Most important | Rest ] ). and PROLOG would respond: Most important * eggs, Rest - [carrots, hamburger, fleacollar]. The vertical bar "j" is crucial here. It is the string extraction operator, which performs a combination of the CDR and CAR functions of LISP. When it appears in the context [X|Y] it can separate the head of the list from the rest, or tail. You may have gained the impression that PROLOG is a rather static language capable of answering simple questions, but It is far more powerful than that. The string extraction operator is the key. It permits PROLOG to whittle a complex expression down to the bare remainder. If the rules you have given it permit it to whittle the remainder.down to nothing, then success is achieved. An

example of this is the definition of "append." Let us suppose you have not yet

done yesterday’s shopping, let alone today’s. You pull it out of your wallet and sootch tape it to the list your wife just gave you. Yesterday’s list was: [tomatoes, onions, ketchup] Combined with [eggs, carrots, hamburger, fIeacoliar] we

otain[eggs,carrots,hamburger,fleacollar,tomatoes,onions,garlic]. To take one list and to attach it to the tail of another list is to "append" the first to

the second. The PROLOG definition of append is: Rulel: appendf [], L, L )

Rule2: append( [X|List1]. List2, [X|List3] ) :- append( List 1. List2, List3 ]. The general scheme Is this: The definition consists of one rule and one fact. The rule will be used over and over again until what little is left the fact. The [] stands for empty list, which is like a bag without in it. This is an example of a recursive definition. Suppose we ask:

a,b,c d, e, f d, e, f L i st3 End. How

matches anything append(

( [a,b,c], [b.c].

[d.e.f], Whatgives ). 1. Rule 2 is invoked with arguments Whatgives ). 2. Rule 2 is invoked again with arguments: (

List3 ). 3. Rule 2 is invoked again with arguments: ( [b], [d.e.f], 4. The arguments are now ([], [d.e.f], List3 ). Rule 1 now matches, does this cause a list to be constructed? The key is to watch the third argument. Supplied by the user, It is named “Whatgives". The inference engine matches it to [X|List3] in rule 2. Now lets trace this as rule two is successivly invoked: Whatgives | | | v Rule2: [X|List3l (listl = [b,c])

Lm\ l [Plu.u--'* (Us,r • !c)) - > V ! V J \ \

L ( in Rulel = reason: Notice that rule It invokes. So

t3’ ’ ] .e.f]

__ .cl]

(Listl” - [], ie., empty set.) | \ | \ | \ Rulel:

) End. L in rule 1 is [d,e,f] for the following rule 2 never alters List2. It supplies it to whatever in rule 1 is the original List2, or [a.b.c]. This

example would not have worked if the order of rules one and two were reversed. The PROLOG inference engine always attempts to use the the first rule encountered. You could imagine it as always reading your program from the top down in attempting to find an appropriate rule. Since rule 2 would always satisfy, an unpleasant thing would have happened if the order were reversed. The program would loop forever. I hope that this tiny introduction to PROLOG whets your appetite. You should now purchase the book Programming In Prolog W.F. Clocksin and C.S. Mellish Springer - Verlag BerI in,Heidelberg,New York. 1981,1984 Springer - Verlag

72 BYTE LISTINGS SUPPLEMENT

L i netest.pas

TEXT

"Turbo Pascal 3.0" Mark Bridger.

February, page 281

program LINETEST;

for i :* 0 to 15 do

var

for j :« 0 to 9 do

1, j : integer;

draw(20*i, 20*j, 319-20*i, 199-20*j, i+j)

beg i n

write(chr(7)) {Beep}

graphmode;

end.

Pa 1ette(1);

Btrans.pas

TEXT

"Turbo Pascal 3.0" Mark Bridger.

February, page 281

program BTRANS;

while not(EOF(F)) do

var

beg i n

F,G: file; {untyped files for blockmoves}

blockread(F, buffer, 1,1);

buffer: array[1..128] of byte;

blockwrite(G, buffer, 1,1)

I: integer;

end;

beg i n

close(F); close(G);

assignfF, * infile.dat 1 );

wr ite(chr(7)); {Beep}

assign(G, ’outfile.dat’);

end.

reset(F); rewrite(G);

Trans.pas

TEXT

"Turbo Pascal 3.0" Mark Bridger.

February, page 281

program TRANS;

while not(EOF(F)) do

var

beg i n

F*,G: file of byte;

read(F, ch);

ch: byte;

wrlte(G, ch)

begin

end;

assignfF, * inf I1e.txt *);

close(F); close(G);

assign(G, ’outfi1e.txt');

write(chr(7)); {Beep}

reset(F); rewrite(G);

end.

Ca1c.pas

TEXT

"Turbo Pascal 3.0" Mark Bridger.

February, page 281

program CALC;

beg i n

var A,B,C: rea1;

C:- C * A;

N, I: integer;

C:- C * B;

beg i n

C:- C/A;

N:- 5000;

C:- C/B

A:- 2.71828;

end;

B:« 3.14159;

wr i te(chr(7));

C:» 1;

write1n(’Error ■ C - 1)

For I:« 1 to N do

end.

( continued )

BYTE LISTINGS SUPPLEMENT 73

Float.pas

TEXT

"Turbo Pascal 3.0" Mark Brldger.

February, page 281

program FLOAT;

y:- ln(x);

var I: integer;

y:« exp(x);

x.y: real;

y:« sqrt(x);

beg I n

y:* arctan(x);

x:» 1;

x:* x + 0.01

for I:- 1 to 1000 do

end

beg i n

end.

y:- sin(x);

Sieve.pas

TEXT

"Turbo Pascal 3.0" Mark Bridger.

February, page 281

program SIEVE;

then

const

begin

size - 8190;

prime:* I + I +3;

var

k:« I + prime;

flags: array[0..size] of boolean;

wh11e K <* size do

I, prime, K, count, iter: integer;

begin

begin

flags[K]:* false;

wr iteln(*Start one iteration.*);

K:* K + prime;

for iter:* 1 to 10 do

end;

begin

count:* count + 1

count:* 0;

end;

for I:* 0 to size do

wr i te1n(count:1,' primes.*);

flags[I]:* true;

end;

for I:* 0 to size do

writeln(chr(7)) {Beep}

if flags[I]

end.

Qsort.pas

TEXT

"Turbo Pascal 3.0" Mark Bridger.

February, page 281

Eprogram Quicksort(input.output); const

max = 100; type

standardArray * array[0..max] of real; var

numbers: standardArray; last: integer;

procedure swap(var a,b ; real); var

t : reaI; beg i n t :* a; a :* b; b := t; end;

procedure prIntArray(top : integer); var

i : integer; begin

writ eIn(*-MARK-*); end;

procedure getArray(var top:integer); const

worstCase : standardArray =

(100.0, 99.0, 98.0. 97.0. 96.0, 95.0, 94.0. 93.0. 92.0, 91.0.

74 BYTE LISTINGS SUPPLEMENT

90.

0.

89,

.0.

88,

.0.

87.

.0.

86,

.0.

85,

.0.

84,

.0.

83.

.0.

82

.0.

81

.0.

80.

0.

79,

.0.

78.

.0.

77.

.0.

76.

.0.

75

.0.

74.

.0.

73.

.0.

72,

.0.

71

.0.

70.

0,

69,

.0,

68.

.0.

67.

.0.

66,

.0.

65,

.0.

64.

.0.

63.

.0.

62

.0.

61

.0.

60.

0.

59,

.0.

58.

.0.

57.

.0.

56.

.0.

55,

.0.

54.

.0.

53.

.0.

52,

.0.

51

.0.

50.

0.

49,

.0.

48.

.0,

47.

.0.

46.

.0.

45

.0.

44.

.0.

43.

0.

42

.0.

41

.0.

40.

0.

39,

.0.

38.

.0.

37.

.0.

36.

.0.

35,

.0.

34.

.0.

33.

.0.

32,

.0.

31

.0,

30.

0.

29,

.0.

28.

.0.

27.

.0.

26.

.0.

25,

.0.

24.

0.

23.

.0.

22,

.0.

21

.0.

20.

0.

19,

.0.

18.

.0,

17.

.0.

16.

.0.

15,

.0.

14.

.0,

13.

0.

12.

.0.

11

.0.

10.

0.

9,

.0,

8.

.0.

7.

.0.

6.

.0.

5.

.0.

4.

.0.

3.

0.

2,

.0.

1

.0.

0.

0)

i

begin(* getArray *) top :* 100; numbers := worstCase; printArray(top); end; (* getArray *)

procedure bubbIeSort(start,top: integer; var subArray: standardArray); var

Index: integer; switched: boolean; begin (* bubblesort *) repeat begin

switched :- false;

for index :« start to top-1

do

begin

if (subArray[index] > subArray[index+1]) then begin

swap(subArray[index],subArray[index+1]); switched :■ true; end; end; end;

until switched = false; end;

procedure findMedian(start, top: integer; var subArray: standardArray); var

middle : integer; sorted: standardArray; begin (*findMedian

(start+top)div 2;

‘start]; top]; middle];

middle

sorted

sorted

sorted

:■ subArray :■ subArray :■ subArray

bubbIeSort(1,3,sorted); if sorted[2] ■ subArray[middIe] then

swap(subAr ray[start],subArray[middIe]) e I se

if sorted[2] ■ subArrayftop] then

swap(subArray[start],subArray[top]);

end;

procedure sortSect ion(start,top:integer); var

swapUp: boolean; s,e,m: integer; begin

if top-start < 6 then

bubbIeSort(start,top,numbers) e I se beg i n

findMedian(start,top,numbers); swapUp :■ true;

s :■ start; e top; m :■ start; while e > 8

( continued )

BYTE LISTINGS SUPPLEMENT 75

beg I n

if swapUp - true then

beg in .

while (numbers[e] >- numbers[m]) and (e > m) do

e e -1;

If « > n

then

begin

swap(number8[e],numbers[mJ);

m : * e ;

end;

swapUp :■ false; end

e I se

while (numbers[s] <« numbers[m]) and (s<m) do

s :* 3+1;

1 f s < m then begin

swap(numbers[s],numbers[m]); m :* 8 end;

swapUp := true; end; end;

SortSection(start,m-1);

SortSection(m+1.top); end;

end; (* sortsection *) begin

getArray(last); sortSection(0,last); printArray(last); end.

tankard.Ibr BINARY

"The Literary Detective," Jim Tankard.

February, page 231. Download lu.exe to unpack this library.

OREM FREQUENCY ANALYZER 1 20 REM

30 REM BY JIM TANKARD

40 REM 3003 CHERRY LANE

50 REM AUSTIN, TEXAS 78703

60 REM

70 DIM AX(26),B%(26): REM THESE ARRAYS HOLD THE TWO FREQUENCY COUNTS TO BE COMPARED 80 LET SI% « 0 90 D$ = CHR$ (4)

100 REM GETS NAMES OF FILES 110 INPUT “WHAT FILE CONTAINS THE FIRST FREQUENCY COUNT?";N$

120 INPUT "WHAT FILE CONTAINS THE SECOND FREQUENCY COUNT?";M$

130 REM OPENS FIRST FILE AND READS ITS FREQUENCIES INTO AX(I)

140 PRINT D$;"OPEN ";N$

150 PRINT D$;"READ ";N$

160 FOR I = 1 TO 26

170 INPUT C$: LET C% = VAL (C$)

180 LET A%( I) - C%

190 NEXT I

200 PRINT D$;"CLOSE ";N$

210 HOME

220 REM OPENS SECOND FILE AND READS ITS FREQUENCIES INTO BX(I)

230 PRINT D$;"OPEN “;M$

76 BYTE LISTINGS SUPPLEMENT

240 PRINT D$;"READ ";M$

250 FOR I = 1 TO 26

260 INPUT C$: LET C% = VAL (C$)

270 LET B%(I) - C%

280 NEXT I

290 PRINT D$;"CLOSE ";M$

300 REM COMPUTES DIFFERENCE INDEX 310 FOR I * 1 TO 26

320 LET SIX « SIX + ABS (AX(I) - BX(I)) 330 NEXT I

340 REM PRINTS RESULTS 350 HOME

360 PRINT "FIRST SAMPLE: ";N$

370 PRINT

380 PRINT "SECOND SAMPLE: ";M$

390 PRINT

400 PRINT "DIFFERENCE INDEX: ";SIX 410 END

0REM FREQUENCY ANALYZER 2 20 REM

30 REM BY JIM TANKARD

40 REM 3003 CHERRY LANE

50 REM AUSTIN. TEXAS 78703

60 REM

70 DIM AX(26,26),B%(26,26): REM THESE ARRAYS HOLD THE TWO FREQUENCY COUNTS TO BE COMPARED 80 LET SIX = 0 90 D$ - CHR$ (4)

100 REM GETS NAMES OF FILES

110 INPUT "WHAT FILE CONTAINS THE FIRST FREQUENCY COUNT?";N$

120 INPUT "WHAT FILE CONTAINS THE SECOND FREQUENCY COUNT?";M$

130 REM OPENS FIRST FILE AND READS ITS FREQUENCIES INTO AX(I.J)

140 PRINT D$;"OPEN ";N$

150 PRINT D$;"READ ";N$

160 FOR I = 1 TO 26

170 FOR J = 1 TO 26

180 INPUT C$: LET CX - VAL (C$)

190 LET AX(I.J) - CX

200 NEXT

210 NEXT

220 PRINT D$;"CLOSE ";N$

230 HOME

240 REM OPENS SECOND FILE AND READS ITS FREQUENCIES INTO BX(I.J)

250 PRINT D$;"OPEN ";M$

260 PRINT D$;"READ ";M$

270 FOR I - 1 TO 26

280 FOR J = 1 TO 26

290 INPUT C$: LET CX - VAL (C$)

300 LET BX(I.J) = CX

310 NEXT

320 NEXT

330 PRINT D$;"CLOSE M ;M$

340 REM COMPUTES DIFFERENCE INDEX

350 FOR I - 1 TO 26

360 FOR J - 1 TO 26

370 LET SIX * SIX + ABS (AX(I.J) - BX(I,J))

380 NEXT

390 NEXT

400 REM PRINTS RESULTS

410 HOME

420 PRINT "FIRST SAMPLE: ";N$

430 PRINT

440 PRINT "SECOND SAMPLE: ";M$

450 PRINT

460 PRINT "DIFFERENCE INDEX: ";SIX

470 END

[continued]

BYTE LISTINGS SUPPLEMENT 77

February

10

REM

TEXT GOBBLER 1

20

REM

30

REM

BY JIM TANKARD

40

REM

3003 CHERRY LANE

50

REM

AUSTIN. TEXAS 78703

60

REM

70 OIM Z(100): REM STORES INITIAL FREQUENCIES OF LETTERS 80 DIM ZX(100): REM STORES FREQUENCIES

OF LETTERS AFTER NORMALIZING TO 1000 LETTERS 90 DIM Z%(100): REM STORES FREQUENCIES OF

LETTERS AS INTEGERS NORMALIZED TO 1000 LETTERS 100 DIM Z$(100): REM STORES FREQUENCIES OF LETTERS IN STRINGS 110 R$ = CHR$ (13)

120 D$ = CHR$ (4)

130 AS$ * CHR$ (42)

140 TEXT : HOME

150 PRINT « TEXT GOBBLER 1“

160 PRINT

170 PRINT "THIS PROGRAM COUNTS THE SINGLE LETTER FREQUENCIES IN A SAMPLE OF PROSE TEXT."

180 PRINT

190 PRINT "IT WILL THEN PRINT OUT A TABLE OF THOSE FREQUENCIES ON YOUR PRINTER."

200 PRINT

210 PRINT "IT WILL ALSO STORE THE FREQUENCIES IN A FILE SO THEY CAN BE COMPARED WITH THE FREQUENCIES FROM ANOTHER SAMPLE BY MEANSOF ’FREQUENCY ANALYZER 1’.“

220 PRINT

230 INPUT "WHAT FILE CONTAINS THE TEXT YOU WANT TO ANALYZE? ";N$

240 PRINT D$;"OPEN “;N$

250 PRINT D$;"READ ";N$

260 FOR I - 1 TO 100 270 LET ST = 0 280 LET A$ = ""

290 : GOSUB 1000 300 PRINT A$

310 NEXT I

320 PRINT D$;"CLOSE ";N$

330 PRINT CHR$ (7): REM RINGS BELL WHEN THROUGH READING TEXT 340 GOSUB 5000 350 TEXT : END

1000 REM READS TEXT 240 CHARACTERS AT A TIME 1010 GET C$: PRINT C$;

1020 LET ST = ST + 1 1030 IF C$ = R$ THEN RETURN 1040 GOSUB 2000 1050 A$ *> A$ + C$

1060 IF ST = 240 THEN RETURN 1070 GOTO 1000

2000 REM COUNTS FREQUENCIES OF CHARACTERS.

SPACES AND LETTERS 2010 LET XI = ASC (C$)

2020 LET Cl = Cl + 1: REM COUNTS TOTAL NUMBER OF CHARACTERS

2030 IF XI = 32 THEN LET B1 - B1 + 1: GOTO

2080: REM COUNTS TOTAL NUMBER OF SPACES

2040 IF XI > 96 AND XI < 123 THEN LET XI = XI 32: REM ELIMINATES LOWER CASE LETTERS 2050 IF XI > 64 AND XI < 91 THEN LET CH =

CH + 1: REM COUNTS TOTAL NUMBER OF LETTERS 2060 LET Z(X1) = Z(X1) + 1: REM INCREMENTS ARRAY ELEMENT SERVING AS COUNTER 2070 IF C$ = AS$ THEN GOTO 320: REM LOOKS FOR ASTERISK AT END OF TEXT 2080 RETURN

5000 REM NORMALIZES FREQUENCIES TO SAMPLE OF 1000 AND GETS THEM READY TO STORE 5010 FOR I = 65 TO 90

5020 LET ZX(I) = (Z(I) / CH) * 1000: REM NORMALIZES TO SAMPLE OF 1000 5030 LET Z%(I) = INT (ZX(I) + .5): REM

78 BYTE LISTINGS SUPPLEMENT

5040

5050

6000

6010

6020

6030

6040

6050

6060

6070

6080

6090

6100

6110

6120

6130

6140

6150

6160

6170

6180

6190

6200

6210

6220

6230

8000

8010

8020

8030

8040

8050

8060

8070

8080

8090

8100

8110

8120

8130

8140

8150

8160

10000

10010

10020

10030

10040

10050

10060

10070

CHANGES FREQUENCY TO INTEGER VALUE LET Z$(I) = STR$ (Z%(I)): REM CHANGES INTEGER TO STRING NEXT I

REM PRINTS MENU PRINT PRINT

PRINT " PRESS ANY KEY TO CONTINUE. 1 ':

GET Q$: PRINT Q$

HOME

PRINT " WHICH DO YOU WANT TO DO?"

PRINT

PRINT " 1. PRINT THE LETTER FREQUENCY COUNT." PRINT

PRINT " 2. STORE THE LETTER FREQUENCY COUNT IN A DISK FILE."

PRINT

PRINT " 3. RUN THIS PROGRAM AGAIN TO

GET THE FREQUENCY COUNT FOR ANOTHER SAMPLE."

RUN 'FREQUENCY ANALYZER 1 # ." EXIT THIS PROGRAM."

CHOOSE 1, 2, 3. 4 OR 5."

PRINT PRINT " 4 PRINT PRINT " 5 PRINT PRINT "

GET Q$: PRINT

IF Q$ * "1" THEN GOSUB 8000

IF Q$ = "2" THEN GOSUB 10000

IF Q$ = "3" THEN PRINT D$;"RUN TEXT GOBBLER 1"

IF Q$ « "4" THEN PRINT D$;"RUN

FREQUENCY ANALYZER 1"

IF Q$ = "5" THEN END GOTO 6030

REM PRINTS FREQUENCY RESULTS WITH PRINTER HOME

PRINT "TURN ON YOUR PRINTER, THEN HIT ANY KEY.": GET Q$: PRINT Q$

PR# 1

FILENAME

NUMBER OF CHARACTERS NUMBER OF SPACES LETTER ACTUAL

65 TO 90

"; CHR$ (I),Z(I),Z%(I)

PRINT "

PRINT PRINT "

PRINT PRINT "

PRINT PRINT "

PRINT FOR I =

PRINT "

NEXT I PR# 0 RETURN

REM STORES THE FREQUENCY MATRIX ON

A DISK FILE

HOME

INPUT "WHAT NAME DO YOU WANT TO GIVE TO THE FILE?";N$

PRINT D$;"OPEN ";N$

PRINT D$;"WRITE ";N$

FOR I = 65 TO 90: PRINT Z$(I): NEXT I PRINT D$;"CLOSE"

RETURN

";N$

" ;C1 " ;B1

NORMALIZED"

10

REM

TEXT GOBBLER 2

20

REM

30

REM

BY JIM TANKARD

40

REM

3003 CHERRY LANE

50

REM

AUSTIN, TEXAS 78703

60

REM

70

LET

W1 = 32

80

DIM

Z(26.26): REM STORES INITIAL

FREQUENCIES OF LETTERS

90

DIM ZX(26,26): REM STORES

FREQUENCIES

OF LETTERS AFTER NORMALIZING

TO 10000 LETTERS

100

DIM Z%(26,26): REM STORES

FREQUENCIES

Table captionOF LETTERS AS INTEGERS NORMALIZED TO 10000 LETTERS

110

120

STORES FREQUENCIES OF

170

180

190

200

210

220

230

240 250

260 270 280 290 300 310 320 330 340 350 360 1000 1010 1020 1030 1040 1050 A$ 1060 1070 2000

2010 2020

2030

2040

2050

2060

2070

2080

2090

2100

2110

2120

5000

DIM Z$(26,26): REM

DIM T ZP$(26 26)* N REM STORES FREQUENCIES

OF l1?teSsin'strings with spaces so tables

WILL BE LINED UP 130 R$ - CHR$ (13)

140 D$ - CHR$ (4)

150 AS$ - CHR$ (42)

160 ;St : “ E TEXT GOBBLER 2"

PRINT "THIS PROGRAM COUNTS THE LETTER „

PAIR FREQUENCIES IN A SAMPLE OF PROSE TEXT.

PR T NT

PRINT "IT WILL THEN PRINT OUT A TABLE OF THOSE FREQUENCIES ON YOUR PRINTER.

PRINT “IT WILL ALSO STORE THE FREQUENCIES W A FILE SO THEY CAN BE COMPARED WITH THE FREQUENCIES FROM ANOTHER SAMPLE BY MEANSOF ’FREQUENCY ANALYZER 2.’"

555 "WHAT FILE CONTAINS THE TEXT YOU WANT TO ANALYZE? ";N$

PRINT D$;"OPEN ";N$

PRINT D$;"READ ";N$

FOR I • 1 TO 100 LET ST - 0 LET A$ = ""

: GOSUB 1000 : PRINT A$

NEXT I

PRINT D$;"CLOSE ";N$

GOSUB 5000

T REM READS TEXT 240 CHARACTERS AT A TIME GET C$: PRINT C$;

LET ST = ST + 1 IF C$ = R$ THEN RETURN GOSUB 2000 A$ + C$

IF ST = 240 THEN RETURN

REM COUNTS FREQUENCIES OF CHARACTERS,

SPACES AND LETTER PAIRS

LET Cl = C1 S + I^REM COUNTS TOTAL

rxf.V"? B1 - B1 ♦ 1: REM COUNTS TOTAL NUMBER OF SPACES

Jl ELIMINATES^ LOWER dsE LETTERS

g *V rem AND counts 9 total N LET nu C m H be = r of letters

?? C$ » AS$ THEN GOTO 340: REM LOOKS FOR ASTERISK AT END OF TEXT _

IF XI < 65 OR XI > 90 THEN LET W1 - 32.

GOTO 2120: REM IF CHARACTER IS NOT A LETTER. ASSIGNS 32 TO W1 LET XI - XI - 64: REM CHANGES ASCII

rsf-v™ wotur&M sk.ps

“TO*,) *1 ■ A re£ TT “ncrements

ARRAY ELEMENT SERVING AS LETTER PAIR COUNTER fp?Il= XI: REM STORES NUMBER FOR OLD LETTER IN W1 BEFORE GETTING NEXT CHARACTER

rem UR normalizes frequencies and gets them

READY TO STORE

5010

5020

5030

5040

FOR I - 1 TO 26

LET ZX(i!j)°- 2 (Z(I. j ) / CH ) * 10000: REM

norm^IzesYo SAMPLE OF 10000

LET Z%(I,J) = INT (ZX(I.J) + -5): REM

80 BYTE LISTINGS SUPPLEMENT

February

5050

5060

1 5070 5080

5090

M „ +

5100

5110

5120

7000

7010

7020

7030

7040

7050

7060

7070

7080

7090

7100

7110

7120

7130

7140

7150

7160

7170

7180

7190

7200

7210

7220

7230

10000

10010

10020

10030

10040

10050

10060

10070

10080

10090

10100

10110

10120

10130

10140

10150

10160

10170

10180

10190

10200

10210

10220

10230

10240

10250

10260

10270

CHANGES FREQUENCY TO INTEGER VALUE

LET Z$(I,J) = STR$ (Z%(I,J)): REM CHANGES

INTEGER TO STRING

REM ADDS SPACES TO STRINGS SO TABLE

WILL BE LINED UP

LET ZP$(I,J) = Z$(I,J)

IF LEN (ZP$(I,J)) = 1 THEN LET ZP$(I,J) = " " + ZP$(I,J)

IF LEN (ZP$(I,J)) * 2 THEN LET ZP$(I,J) = ZP$(I,J)

NEXT

NEXT

PRINT CHR$ (7): REM RINGS BELL WHEN THROUGH READING TEXT REM PRINTS MENU PRINT : PRINT

PRINT " PRESS ANY KEY TO CONTINUE.":

GET Q$: PRINT Q$

HOME PRINT " PRINT PRINT "

1 .

WHICH DO YOU WANT TO DO?"

PRINT THE LETTER FREQUENCY

PRINT PRINT "

2.

COUNT."

STORE THE LETTER FREQUENCY

PRINT PRINT "

3.

COUNT IN A DISK FILE."

RUN THIS PROGRAM AGAIN TO

PRINT PRINT "

4.

GET THE FREQUENCY COUNT FOR ANOTHER SAMPLE."

RUN ’FREQUENCY ANALYZER 2'.

PRINT PRINT "

5.

EXIT THIS PROGRAM."

PRINT PRINT " GET Q$:

PRINT

CHOOSE 1. 2, 3, 4 OR 5."

IF Q$ = "1" THEN GOSUB 10000

IF Q$ = "2" THEN GOSUB 13000

IF Q$ = "3" THEN PRINT D$;"RUN

TEXT GOBBLER 2"

IF Q$ = "4" THEN PRINT D$;"RUN FREQUENCY ANALYZER 2"

IF Q$ = "5" THEN END GOTO 7030

REM PRINTS FREQUENCY RESULTS WITH PRINTER TEXT : HOME

PRINT "TURN ON YOUR PRINTER, THEN HIT ANY KEY.": GET Q$: PRINT Q$

PR# 1

PRINT CHR$ (9);"80N"

PRINT CHR$ (27);"Q"

HTAB 33: PRINT "FILENAME ";N$

PRINT

HTAB 33: PRINT "NUMBER OF CHARACTERS ";C1 PRINT

HTAB 33: PRINT "NUMBER OF SPACES ";B1 PRINT

HTAB 21: PRINT "FIRST LETTER SECOND LETTER"

PRINT HTAB 33

FOR I = 1 TO 26

PRINT " "; CHR$ (64 + I);" ";

NEXT I PRINT

FOR I - 1 TO 26

PRINT " "; CHR$ (64+1);" ";

FOR J - 1 TO 26 PRINT ZP$(I,J);" ";

NEXT NEXT PRINT PR# 0 RETURN

(continued)

BYTE LISTINGS SUPPLEMENT 81

February

13000

REM STORES THE DISK FILE

FREQUENCY MATRIX ON A

13010

HOME

13020

INPUT "WHAT NAME

DO YOU WANT TO GIVE TO THE FIIE?";N$

13030

PRINT D$;“OPEN "

;N$

13040

PRINT D$;"WRITE

";N$

13050

FOR I * 1 TO 26

13060

FOR J * 1 TO 26

13070

PRINT Z$(I,J)

13080

NEXT

13090

NEXT

13100

PRINT D$;"CLOSE"

13110

RETURN

scanpoem.doc

TEXT

Table caption"Poetry Processing" by Michael Newman

Table captionFebruary, page 221. Also download scanpoem.exe and scanpoem.pas.

I have provided a Pascal program (Editor’s note: The Microsoft Pascal source code and executable version are available from BYTEnet Listings, xxx-xxx-xxxx, as SCANPOEM.PAS and SCANPOEM.EXE. The executable version requires any MS-DOS or PC-DOS machine) that implements the syllabification algorithm and illustrates how the Poetry Processor "reads" a user’s poem according to a user-specified metric scheme.

The present algorithm is not perfect, but it produces a readable, if not dictionary-perfect, syllabified word 95% of the time. To run the program, prepare two files.

TEST.POE must contain the lines of poetry. You can write TEST.POE as a text file with each line of the poem on a separate line. A second text file, TEST.FRM, should have a line containing a string of dots (.) and dashes (-) Indicating the accentual scheme that each line of poetry is supposed to follow. Slashes indicating the end of a foot are optional.

As an example, a Shakespearean sonnet (iambic pentameter)

will have a TEST.FRM file consisting of 14 lines of

Each line in TEST.FRM must end with an asterisk. After editing the TEST.FRM and TEST.POE files, you can run the program by entering its name, SCANPOEM. The computer will "read" the poem, printing in upper case the appropriately stressed syllables.

Note that the program is a prototype version of the algorithm. It will not not handle text with capital letters, apostrophes, or punctuation, so be careful not to include them these features in TEST.POE. When using this demonstration program, you will undoubtedly find that some words are not properly syllabified. I leave it to the readers to improve upon the a Igorithm.

0:2

Textbox: Machine Reading Of Metric Verse by Paul Holzer

A computer can definitively scan a line of poetry for its stress pattern principally in one of two ways: (1) an algorithm can deduce the syllabic structure and the stressed syllables from analysis of the letters that make up the word, or (2) the computer can look-up of every word in a dictionary database that holds the syllabification and accentuation of every word. The look-up method requires a large database, and the algorithmic approach is complex and requires a deep analysis of English phonetics and spelling.

One of the features of a poetry processor is that the poet-user can specify the meter of every line of a poem. For example, the string represents iambic

82 BYTE LISTINGS SUPPLEMENT

pentameter. Dots indicate an unstressed syllable and

dashes represent a stressed one. The slash "/" indicates the end of a foot, the basic metric unit. The opening line of Shakespeare's 18th Sonnet

shall I comPARE thee TO a SUMmer’s DAY?

is an example of a line of iambic pentameter with the stressed syllables are in upper case.

After writing a poem, users might request a metric scan of the poem. I wiI I describe here a method for doing this which is not based on one of the two general solutions I mentioned in the first paragraph. Instead, the processor will break each word into its syllables and then redisplay each line, with each syllable in upper or lower case according to the position of the dots and dashes in a user-specified metric form. So, were Shakespeare trying to compose trochaic pentameter, with the metric pattern the processor would reply with

SHALL i COMpare THEE to A sumMER’S day?

He would read this to himself, trying to put the stress on the upper case syllables. Noting the rhythmic clumsiness, he might rewrite his line as follows:

To a summer's day I shall compare thee and the processor would respond:

TO a SUMmer’s DAY i SHALL comPARE thee.

Sounds betterl

The main task for the computer is to break each word into its syllables. The algorithm is based on a systematic application of what appear to be the general rules by which

English words break into syllables. Of course, there are no fixed rules, as evidenced by the fact that different dictionaries give different syllabifications for the same word.

The following is a simple version of the algorithm:

1. Break the word up into a sequence of alternating vowel and consonant groupings. Thus MICROCOMPUTER becomes

M I CR 0 C 0 MP U T E R. Wherever there is a vowel or group of contiguous vowels, there will be a syllable.

We need only assign the neighboring consonants to the syllable on right or to the one on the left.

2. If the first vowel-group has a consonant-group to its left, then assimilate this consonant-group to the vowel-group. This leads, in our example, to

MI CR 0 C 0 MP U T E R.

3. If the final vowel-group has a consonant-group to its right, then assimilate this consonant-group to the vowel-group. We now get MI CR 0 C 0 MP U T ER.

4. For the remaining unassigned consonants, do the

following:

a) if the consonant stands alone, attach it to the following vowel. Thus we get MI CR 0 CO MP U TER.

b) if there are two consonants, split them. We get MIC RO COM PU TER.

c) if there are three consonants, then

I) if there is a doubled consonant, then split the pair; thus APPLY -> A PPL Y -> AP PLY.

(continued)

BYTE LISTINGS SUPPLEMENT 83

February

13000

REM

DISK

13010

HOME

13020

INPU1

13030

PRIN1

13040

PRIN^

13050

FOR :

13060

FOR ,

13070

PRIN‘

13080

NEXT

13090

NEXT

13100

PRIN

13110

RETU

scanpoem.de

TEXT

Table caption"Poetry Pr« February, |

I have pro Pascal sou BYTEnet LI SCANPOEM.E PC-DOS mac and i I Iust according

The pi readabIe, the time. TEST.POE i TEST.POE separate containin accentuaI follow. S

As c

wl I I has

asterisk. can run i computer appropri«

Not

It will or punct features you wiI I syI Iabif a Igorith

0:2

flrst^f It dou bled consonant, but the

«£.ri ^x'* b «.. «<•

initial stryng 9 of h | , ettirs r i i n h orde? W to e take*- m t St preproc#ss the peculiarities of English orthographj? * k " t0 account certain

os a'special ionsonant. ( ThJI Certo,n exceptions); treat it compute ~> c o mp u te -> co mp ute -> con, put..

2 ‘ two-letter sequences into

"qu",°and "ck S con#onon *•• e.g..

3. Identify common suffixes For

examp'e, the algorithm opplled to “blameless" would

bl a m e I . ss -> bio me less.

However, when " I ass" ? e .

the in “blame" would h! d a8 .° 8uff,x - then yielding blame less r ® cogn,2dd as silent.

4 ' r;;:;rr y ■.

rather than " e nact". th enoct becomes “en act".

set ct m rules b and7repro<!ess?ng 0 steps ° reasonob| y small syllabification of all worrti 9 ? t P to guarantee correct some of the inherent difficult!IsT ® XOmples wNI '"ustrote

th. fragment -bitl- ?,"! "°' d "•"Ok.bit.- anl...

ext.n* ive »rd p,J„ x »5J?5

*■ ars^r.T:!:.!: *<*>••= >

would treat it correctly* t! 0 ^’ ?" d the al 9 0r ithm ;‘! , ; i ^ d ‘i'f 8ep <T°te | y. y anJ th! clr.ict* pronounce modified to isolate “re^as’a Wer !. the al 9 0r ithm "react" correctly, but turn "reacl^inJo vU'JcJ" 0 *

formulat! e a°ru!e U thot S |!ads a to S the the b ? St opproach is to requiring table look^s^r^JoruUo" !*** ° f C0S88

Pascal soCrcf e code P a!d a ixecutoMe^ Edit?r ' S "° te: The M ’crosoft SCANPOEM L EXE! " 9 The X «ec^ tab I XX ’

PC-DOS machine) that imp I eme!ts*thl° n on >' M S-DOS or

and illustrates how the Poetry P^!.!™) 0 " f '®°* ion ol 9crithm

occording to a user-spec in.7met??c TcLJe * ° US6r ' S P ° em

readable^tf e not°d?ctionary-p.rfect^svl i K,'* produces «

84

byte listings supplement

As an example, a Shakespearean sonnet (iambic pentameter) will have a TEST.FRM file consisting of 14 lines of

Each line in TEST.FRM must end with an asterisk. After editing the TEST.FRM and TEST.POE files, you can run the program by entering its name, SCANPOEM. The computer will "read" the poem, printing in upper case the appropriately stressed syllables.

Note that the program is a prototype version of the algorithm. It will not not handle text with capital letters, apostrophes, or punctuation, so be careful not to include them these features in TEST.POE. When using this demonstration program, you will undoubtedly find that some words are not properly syllabified. I leave it to the readers to improve upon the a Igorithm.

About the Author:

Paul Holzer (140 W. 16th St. Apt 3W New York, NY 10011) is a financial analyst and programmer for PaineWebber, Inc. He has a B.A. in Philosophy from Princeton University and an M.A. in Applied Mathematics from City University of New York.

scanpoem.pas

TEXT

"Poetry Processing." See scanpoem.doc.

program scanpoem(input.output); j Program written by Paul Holzer, Oct. 10, 1985 } const max I eng = 30; numsuf ■ 11; max I in = 80; maxver = 20; maxsyl = 20; maxchn ■ 20; maxfin ■ max Iin+maxsyI; tstsize = 2; left =0; right * 1;

type

charset « set of char; var

copyright: string(36); in_fiIe: text;

poem: arrayT1..maxver 1 of Istring(max 11n};

form: array[1..maxverJ of IstrIng(maxsyI);

chain: array[1..maxchnl of string(maxI eng);

finline: string(maxfin);

f i lenom: string(12);

tword: string(maxI eng);

vowels, letters, xletters: charset;

sibs, dentals: charset;

brknwrd: string(maxI eng);

i. j» k, n, pos, numver, numwrds: integer;

fch, pch: char;

stress: boolean;

xgrid: array[0..12] of string(2); sufmat: arrayT1..numsuf] of string(4); inword: array[1..tstsize] of strlng(maxI eng); mids: charset;

rassim: array[1..29] of charset; va I ue

copyright :■ *(C) 1985 Michael Newman, Paul Holzer*; letters :« [* a *..*z*,*E*,* I*,*Y*]; xletters :■ [ *0’..*9* ,*:*,*;’,*<*]; vowels :■ [*a*,*e‘,*I*,*o*,*u',*y*];

(continued)

BYTE LISTINGS SUPPLEMENT 85

sibs [’x 1 ,’z’, 1 J*,’g’ dentals :■ ['d', 1 t 1 ];

* 8 * , * c *, 5 , 1 ];

’k *,'I*,’m’,'n*,*p*

xgrid[0 3 xgrid[4] xgrId[8] xgrId[12] :* ‘gn f ;

*t*,*w’

'ck*;

xgr id

T

:« ’ch*

’gh*; :« * rh *;

xgr id

'3'

’ph*

xgr id

’sh*

' th';

xgr id

’7'

’wh*

‘qu *; ’si •;

xgr id

9

:« *gu*

xgr id

[11] ’ti

sufmat[11 := , **ly’; sufmat[2] := '***y’; sufmat[3] :* ’**er•;

sufmat[ 4 ] :■ **agE'; sufmat[ 5 ] := **est'; sufmat[ 6 ] :** * *ing';

sufmat[7] :» ‘ness*; sufmat[8] ’less'; sufmat[9J :* **fuI *;

sufmat[10] := *ment'; sufmat[11] :« ’tirnE’;

rassim

,1

=« [■

’ r *,

rassim

[6 ]

C

1 r * ,

rassim

12

; s

[];

rassim

‘18’

rassim

28

; s

•r*

rassim

23

>•

I* ] ; rass i m T 3 ] : s

r # •n*]; rassim[10] rassim[13] :* [ *m',* I']; rassim[19 *n’,*m',* I *]; rassim * I']; rassim[26]

[ , r , »*r]; rassim[ 5 ] : =

= [ * r *, * I’ ] ; rassim[11] ; rassim[15] := [*r* ,' I* :■ [ • r * ]; rassim[22]

29]:■['r']; rass»m[24J:=

= L ' I ’. * r * J;

[*r•, • I U;

,*s*, 'n [ * r [ * I •, * r

procedure swapch(vars x, y: char); var 2 : char; beg i n

z ;■ x; x y; y z end;

function min(x, y; Integer); integer; beg i n min :* x;

if y < x then min :* y end;

function lowcase(ch: char); char; j returns lower case form of a letter }

begin

lowcase := ch; if ord(ch) > 64 then

lowcase := chr((ord(ch) mod 32) +

end;

96)

function upcase(ch: char); char; j returns upper case form of a letter } begin

upcase :* ch; if ord(ch) > 64 then

upcase :* chr((ord(ch) mod 32) + 64)

end;

procedure strip(vars qword: string; var Ing: integer); .

{ strips leading blanks and returns length of a string of letters *

var i: integer;

tword: string(maxI eng);

begin { strip \

for i := 1 to maxleng do tword[i] :* i ;= 0; Ing 0;

repeat i := i + 1 until tword[i] in repeat

Ing := I ng + 1; qword[lngj :« tword[i]; i ;« I + 1;

until not (tword[i] in letters); end { strip

qwo r d[i]; Ietters;

procedure siI Iify(consts qword: string; vars bword: string);

{ the main procedure for syllabifying a word, and described in detai in comments below. In general, it works by initially putting the alternating sequences of consonant and vowel groups of a word into the

86 BYTE LISTINGS SUPPLEMENT

matrix fiber, then attaching the consonants to the vowels, where the syllables are, according to certain rules }

var i,j,pos: integer;

fiber; array[ 1 .. 20 ] of string( 6 );

Iastcons, chng, plural, issuf: boolean;

isplur, ispast, isswap: boolean;

ch, ch 2 : char;

frag, suffix: string(4);

last, lastodd, Ing: integer;

tword; string(maxI eng);

x, m, y: char;

spI it: integer;

function iscons(ch: char): boolean;

{ returns true if ch is a consonant, false otherwise * begin

if ch in vowels then iscons := false else iscons :** true

end;

function cmotch(inch: char; patch: char): boolean;

j returns true if inch = patch or if patch = false otherwise 5

beg i n

cmatch := false;

if patch = then cmatch :* true e I se

if inch = patch then cmatch :« true

end;

function fndsuf(consts frag: string; vars suffix: string): boolean; j returns true if the string frag matches one of the suffixes in sufmat, and returns the suffix in suffix \ var i,j,k: integer; fnd: boolean;

begin \ fndsuf }

for i :« 1 to 4 do suffix[i]

i := 0 ;

repeat i :* i + 1 ; fnd := true; for j :■ 1 to 4 do

if not cmatch(frag[j], sufmat[i,ij) else for k :» 1 to 4 do suffix[k] : untiI fnd or (i s numsuf); fndsuf :■ fnd end { fndsuf };

then fnd sufmat[

:= false

.k]

function tr(m: char): integer [PURE]; begin

if m in xIetters then tr :*■ ord(m) - 25 else tr :* ord(m) - 97

end;

procedure initfib; Ai ..

{ cnverts final ’e’ of tword to the "consonant" *E’ , then sorts the alternating consonant/vowel groups into the rows of the 20 x 6 character matrix fiber. The last row containing a letter is returned in last \ var i,j,pos: integer;

ch: char;

lastcons: boolean;

begin { initfib \ if tword[lng] ■ *e' then

if iscons(tword[Ing- 1 ]) then begin tword[lng] *E';

If isplur then begin

if tword[Ing- 1 ] in sibs then tword[lng] := ’e' end else

if ispast then begin

if tword[Ing- 1 ] in dentals then tword[lng] :« ’e’

end

end;

for i :« 1 to 20 do for j :■ 1 to 6 do

[continued)

BYTE LISTINGS SUPPLEMENT 87

fIber[I.J] * *

the syllable separator symbol "/" Is Initially placed between all groups

for i :■ 2 to 20 do fiber[l, 6 ] :■ '/*•

|.«MS=s = sa.«Bs aa r: = sBM«an B Bsa S saa««»a a = s B s a * a ss*«SBs = a a BS =sss» = = !

blanks are Ignored. Consonant groups are placed In odd-numbered rows, vowel groups In even-numbered ones. ^

| :■ 1 ; J :■ 1; pos :« 1 ; lastcons :« true; ch :■ tword[pos]; while pos <« Ing do

If ch * * * then begin pos :» pos + 1 ; ch := tword[pos]; end

e I se beg In

if lastcons « iscons(ch) then begin fiber[I,J] : = ch;

j J + 1

end

else begin

i i + 1; j 1;

fiber[i,j] := ch;

j j + i;

lastcons := not lastcons

end;

pos :*= pos + 1 ; ch := tword[pos]

end;

Iast :* i ; end j initflb };

beg in { siI Iify \

issuf := false; isplur :« false; ispast := false; isswap :■ false;

for i ;= 1 to maxleng do tword[i] ;= qwordfi]; strip(tword, Ing);

if (tword[Ing] - ’s’) and (tword[Ing- 1 ] <> 's') then begin Ing := Ing - 1; isplur := true end else

if Ing > 4 then

if (tword[Ing] = ’d’) and (tword[lng - 1 ] = 'e’) then beg Ing :* Ing- 1 ; ispast ;* true

in

end;

if Ing > 3 then

if tword[lng] » ’e’ then _ _ . x

if (twordflng- 1 ] in [ • I * . * r ’ ] ) and not (tword[Ing- 2 J in vowels) then begin

swapch(tword[Ing], tword[lng- 1 ]); isswap :** true

end;

^tword is now scanned from right to left, and the following letter conversions are made in the following case statement:

'gn* is converted to the xletter *<’;

*gu* followed by a vowel is converted to *9*;

*qu’ is converted to * 8 *;

* ch', *gh*, * ph', * rh', *sh*, 'th*, and 'wh* are converted to *1, *2*, *3* , *4’, ’ 5 \ ’ 6 \ *7*, respectively;

*ck’ is converted to * 0 ’;

*i• followed by a vowel is converted to the "consonant" * 1 ', but ’si* and *tl* are further converted to and ; *y* followed by a vowel is converted to "consonant" 'Y*.

for i Ing downto 2 do begin ch := twordfi]; case ch of

*n': if twordfi- 1 ] = *g* then begin twordfi- 1 ] :* *<*; twordfi] := * ';

end;

•u*: if (twordfi- 1 ] = ’g*) and (tword[i+ 1 ] in vowels) then begin tword[i-l] :* *9*;

88 BYTE LISTINGS SUPPLEMENT

•h’

tword[i] :* * '; end

C S6 if tword[i- 1 ] = *q* then begin tword[i- 1 ] := * 8 ' ; tword[i] :* * *;

end; beg i n

chng :* true; ch 2 :* tword[i-l]; case ch 2 of

Table caption’k’

* c *: tword

i- 1 *

:* * 1 ';

’g*: tword

i-i

:= *2*;

* p*: tword

i-i

*3*;

* r’: tword

'i-i

:* *4*;

•s*: tword

‘i-i 5

:* ’5';

* t': tword

[i-i

:= ’ 6 ’;

*w*: tword

i-i'

:= *7*;

otherwise chng

:* false

end;

if chng then

tword[iJ :* *

end;

if tword[i- 1 ]

= * <

c* then fc

tword[i- 1 ] : =

* 0 *;

tword[i]

. _ »

•

end;

begin

if tword[i+l]

i n

vowels ti

tword[i 1

:*= '

1*5

if tword[i- 1 J

= ’s’ tl

tword

l[ i -1 J :*=

tword

i[i]

, i »

end

e 1 se

end

'if tword[i- 1 ] = *t* then begin twordTi- 1 ] :■ *;*; tword[i] :* '

end end;

if tword[i+l] in vowels then tword[i] :* *Y';

V

otherwise

end;

end;

pos 0 ;

for i := 1 to Ing do

if tword[i] <> * * then begin pos := pos + 1 ; tword[pos] :* twordfij end

else Ing :«= Ing - 1 ;

^initialize syllabification by calling initfib

initfib;

* = 7 === 7 !Th^c - nt Tetters, get the lost four ond test whether they

HrH suf ix by coiltni fndsuf. 9 If o suffix is found, then remove it Ind repeot the process. by_co II ing_init ^'b = with = the = word = m ,nus = , ts = suff , x.

if last > 4 then begin

for i :« 1 to 4 do frog[i] tword[Ing-4 +1 ];

if fndsuf(frog, suffix) then begin for i ;■ 1 to 4 do

If suff!x[i] <> •*' then Ing Ing - 1; issuf :■ true;

Initfib

end;

end;

fiber[Iast, 6 ] if odd(last) then begin fiber[last- 1 , 6 ] :• * lastodd :* last - 2 ; end

e I se begin

(continued)

BYTE LISTINGS SUPPLEMENT 89

lostodd :■ last - 1

end;

We now inspect all consonant groups starting with the first to follow a vowel (row 3 of fiber) and ending with the last group to precede a vowel (row lastodd). We associate the consonant in each group with the preceding or following vowel groups according to rules described in comments below. In these comments, upper case letters stand for arbitrary consonants.

i 3;

while i <■ lastodd do begin if

f i ber[i,2] - • • then if fiber [1,1] <> *x' then

e I se

fiber[I,6] :« * * else fiber[i-1,6] :«

j exactly 1 consonant \ I /C/ »> /C }

if fiber[i,3]

e I se

f iber fiber f i ber f i ber end

1 , 6 ] := 1 - 1 . 6 ] i i

then begin

\ exactly 2 consonants } j /CD/ -> C/D J

, 3] :■ fib . 2 ] := •/•

f i ber[i, 2];

if fiber[l,4] ■ * ' then begin { exactly 3 consonants \

" f1.3];

x fiber[f,1]; m :« fiber[l,2]; y fiber split := right; if y ■ m then split :■ left e I se

if m In mids then

if y in rassIm[tr(m)] then split left; case split of

a i n

{ /CDE/ «> CD/E {

Table caption| /CDE/ -> C/DE \

Table captionend;

otherwise

end;

Table captionend

Table captionelse begin

beg i n f i ber

[i-i.

6 ] := * *;

f i ber

1.6

; b • • •

f i ber

!'- 4 '

fiber[1.3]

fiber

[1.3]

•/*

end; beg i n f iber

; i-i .

6 ] 1 *:

fiber

,1.6]

:■ ’ ';

fiber

,i .4,

:■ f iber[i,3]

fiber

:■ fiber[1,2}

f I ber

[1.2]

V

end; i := i + 2; end;

i 4 or 5 consonants }

f i ber

[1-1.

6 ] • •:

f i ber

i. 6] := * •;

f i ber

i.5]

:* fiber[I,4];

f i ber

:= f iber[ i ,3];

fiber

[1.3]

V

Put the syllabified word back together, ignoring spaces in fiber and converting special consonants back to normal spelling.

for i := 1 to maxleng do bwordfi] pos :« 0;

for i := 1 to last do

for j :« 1 to 6 do begin ch := fiber[ i, j] ;

if ch in (letters + [V*]) then begin pos :« pos + 1; bword[pos] ;= lowcase(ch) end

e I se

if ch in xletters then begin pos := pos + 1;

bword[pos] := xgrid[ord(ch)-48,1]; pos := pos + 1;

bword[pos] := xgrid[ord(ch)-48,2];

end;

90 BYTE LISTINGS SUPPLEMENT

end;

Reattach the suffix, if any, as final syllable.

*

if isswap then

if bword[pos] * '/* then swapch(bword[pos-2],bword[pos-1]) e I se

swapch(bword[pos], bword[pos-1]); if issuf then begin pos := pos + 1; bword[pos] :* */*; for i := 1 to 4 do

if suffix[i] <> then begin pos := pos + 1; bword[pos] := suffix[i]

end;

end;

if isplur then begin pos := pos + 1; bword[pos] :* ’s’

end;

if ispast then begin pos :» pos + 1; bword[pos] := 'd*

end;

end j siI Iify };

procedure break In(consts tline: string; var numwrds: integer);

{ breaks a line of poetry into a matrix of words, so that chain[i,j] is the j-th letter of the i-th word }

var I, J, pos; integer; beg I n

for i :■ 1 to maxchn do

for j ;* 1 to maxleng do chain[i,j] * ’;

pos :■ 0 ; i :* 0 ; while pos < maxi in do begin repeat

pos :* pos + 1

until (pos « maxlin) or (tIine[pos] in letters); if pos < maxlin then begin i i + 1 ; j 1 ; repeat

chain[i, j] :* tline[pos];

J :■ j + 1 ; pos :■ pos + 1 until (pos * maxlin) or not(tIine[pos] in letters)

end

end;

numwrds :■ i; end;

procedure pstress(ch: char; stress: boolean);

{ converts a letter of upper case if parameter stress is true \ begin

if ch in letters then

if stress then write(upcase(ch)) else write(lowcase(ch))

e I se

write(ch)

end;

begin { scanpoem j wr iteIn;

{ read in the poem }

assign(in_fiIe, 'test.poe*);

reset(in_fI Ie); i :■ 0;

while (not EOF(In_fiIe)) and (1 < maxver) do begin

I :■ I + 1;

read In( ln_f iIe, poem[i])

end;

close(in_fiIe); numver :» i; j read In the form } assign(in_f1 Ie, ’test.frm’); reset(In_f1le); i :* 0;

( continued )

BYTE LISTINGS SUPPLEMENT 91

while (not EOF(in_fiIe)) and (I < maxver) do begin

! I + 1;

read In(in_fiIe, form[i])

end;

c lose(in_fiIe);

if i < numver then numver :■ I;

j---—----

Each line read will be processed in sequence, by calling breakln on the line, calling sillify on each word of the line, and reconstructing the finished line in finline. finline is then displayed with syllables in upper case according to the pattern of dots and dashes in form.

for i :« 1 to numver do begin

for j 1 to maxfin do finline[j] :* • •; break In(poem[i],numwrds); pos := 0 ;

for j ;* 1 to numwrds do begin siI I Ify(chaln[j], brknwrd); k 0 ; repeat

k := k + 1; pos :■ pos + 1; finline[posl :■ brknwrd[k] untiI brknwrd[kJ « ' *

end;

pos :■ min(pos, maxfin- 1 ); finline[pos] := • •; f\nI Ine[pos +11 :■ •*•; j :« 1 ; pos :■ 0 ; fch :« form[i, jj; while fch <> '** do begin

If fch <> •/• then begin

if fch * then stress true else stress :« false; repeat

pos := pos + 1 ; pch :* fin Iine[pos]; pstress(pch, stress) untiI pch in [* •*•/•]

end;

j :■ j + 1 ; fch :■ form[i, J]

end;

pos :■ pos + 1 ;

while not (fin Iinefposl * ’*') do begin wr ite(fin Iinefpos]); pos :■ pos + 1

end; wr i teIn

end;

end.

readsim3.me TEXT

"A SIMPL Compiler, Part 3: Extensions." See simpl3.bix.

0uide to Part 3 of "A SIMPL Compiler." The file includes Modula-2 source code for the entire SIMPL Compiler. You will need the Monitor program from "Building a Computer in Sodtware (October ’85) and the VM2 Assembler (November ’85). There are thirteen modules to this final version of the compiler.

CodeGen CodeWrite

Compiler (MOD file only)

ExprParser Ini t LexAn Node Parser Routines SymboI SymboI Tab I e Token

TypeChecker

92 BYTE LISTINGS SUPPLEMENT

The programs were developed using MacModula-2, but conversion to other Modula-2 systems should be straightforward. I would appreciate hearing about any conversion dificulties or bugs. You can reach me on BIX as "jba" or by U.S. mail at 1643 Cambridge St. #34, Cambridge, MA 02138. Happy Compiling!

Jonathan Amsterdam

[Editor’s note: Because of the 8 character filename limit of MS-DOS, the above modules have been combined into one file. You whould break them into separate files before attempting to compile them.]

natIang.Ibr BINARY

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. February, page 189. Download lu.exe to unpack.

readnat.me TEXT

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. February, page 189.

This disk contains a very compact "least common denominator" activation network editor and simulator written in xlisp.

The program supports a maximum of 23 nodes in XLISP.

two versions are provided; one for xllspl.2 and another for the more modern xlispl.4.

There are a few sample networks included. Clock is a 3 node timing "circuit", and PARSE is a network of syntax for "John ate up the street" where the minimal attachment parse is chosen.

these *.net files are saved and can be loaded by the program using the "F L file" command. NOTE: THE PARSE.NET FILE TAKES APPROX. 5 MINUTES TO LOAD ON AN IBM PC.

♦.pit files are created with the File Plot option they are time versus activation level graphs which can be printed on any printer. If you use the plot function without resetting activation values to 0, the plot cycles will begin with the current activation values. A *?* on the printout means that two or more nodes have the same value. The ? substitutes for an overstrike.

sa.Isp is the program for version 1.4. To load it, run xlisp, and then call (load "sa" t t) and then call (editnet)

sa12.lsp Is a modified version for xlisp 1.2 using nlambda functions instead of macros, handexpanded backquotes, and several interation and predicate functions (from version 1.4) explicitly defIned.

To run It, run xlisp 1.2, call (load "sa12") and then cal I (editnet)

YOU MUST HAVE "devlce-ansi.sys" In your CONFIG.SYS FILE IN ORDER FOR THE CURSOR CONTROL FUNCTIONS TO WORK PROPERLY.

[continued)

BYTE LISTINGS SUPPLEMENT 93

cIocknet TEXT

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. February, page 189.

m a foo m s foo 15 m a bar m s bar 49 m a zot m I a foo bar

m I i foo zot

m I I bar foo

m I a bar zot

m I a zot foo

m I I zot bar

clockpIt TEXT

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. February, page 189.

bar ■ B foo - A

0.0 0.5 1.0

+ 1

0

T 1

A

B

1

A

B

2

A

B

3

A

B

4

A

B

5

A

B

6

A

B

7

A

B

8

A

B

9

A

B

10

A

B

11

A

B

12

A

B

13

A

B

14

A

B

15

A

B

16

A

B

17

A

B

18

A

B

19

1

►

20

B

A

21

B

A

22

B

A

23

B

A

24

B

A

foo.net

TEXT

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. February, page 189.

m a foo m s foo 50 m a bar

m I a foo bar m I i bar foo

94 BYTE LISTINGS SUPPLEMENT

f oo .pit TEXT

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. February, page 189.

bar * B foo * A 0.0

+ 1

0 -B

1 - B

2 - B

3

4

5

6

7

8

9 - A

10 - A

11 - A

123— AA

14 - A

15 - A

16 - A

17 - A

18 - A

19 - A

B

A

A

B A

AB

A B

0.5

A

A

A

A

B

B

B

B

B

BB

B

B

B

B

B

B

1.0

parse.net TEXT

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. February, page 189.

m

a

John

m

s

John 25

m

a

npl

m

a

ate

m

a

V

m

a

up

m

a

adv

m

a

prep

m

a

the

m

a

street

m

a

np2

m

a

vpl

m

a

PP

m

a

vp2

m

a

s2

m

a

si

m

a John npl

m

a John ate

m

a npl John

m

a npl s2

m

a npl si

m

a ate v

m

a ate up

m

a v ate

m

a v vpl

m

a v vp2

m

a up adv

m

a up prep

m

a up the

m

a adv up

m

i adv prep

m

1

a

adv vpl

m

1

a

prep up

m

1

i

prep adv

m

1

a

prep pp

m

1

a

the street

m

1

a

the np2

m

1

a

street np2

m

1

a

np2 the

m

1

a

np2 street

m

1

a

np2 vpl

m

1

a

np2 pp

m

1

a

vpl V

m

1

a

vpl adv

m

1

a

vpl np2

m

1

i

vpl pp

m

1

1

vpl vp2

m

1

a

vpl si

m

1

a

PP prep

m

1

a

PP np2

m

1

i

PP vpl

m

1

a

PP vp2

m

1

a

vp2 v

m

1

l

vp2 vpl

m

1

a

vp2 pp

m

1

a

vp2 s2

m

1

a

s2 npl

m

1

a

s2 vp2

m

1

1

s2 si

m

1

a

si npl

m

1

a

si vpl

m

1

i

si s2

(continued)

BYTE LISTINGS SUPPLEMENT 95

February

porse.plt TEXT

"InterpretotIon of Natural February, page 189.

Language," Jordan Pollock and David L. Walt

prep - G vpl - K vp2 - M

si - 0

s2 - N

0.0

+ |

0 -?

1 -?

2 -?

3 -?

4 -??

5 -??

6 -? ?

7 -? ?

8 -?? ?

9 - ?MK ?

10 - G ? K ?

11 - G MF K?

12 - G M F N?

13 - G M N ?

14 - G M N

15 - G M N

16 - G M N

17 - G M N

18 - G M N

19- G lil N

20 - GM N

21 - G M N

22 - GM N

23 - GM N

24 - ? N

0.5

K

F K 0 F

0

K

F

0

1.0

K

F K

0 F «

0 F K 0 F K 0 F K 0 F K OFK

so.Isp TEXT

"Interpretation of Natural February, page 189.

Language," Jordan Pollock and David L.

Waltz.

(expand 45) ; make some space

: r:dt:::rtr:r* ,, '*-*****r*************************

. * editnet is the main routine

(defun editnet ()

(prog (net node It)

(setq net (-> Net new))

(CLS )

JurEi/^.i. \ force 9 C to ovoid xI isp bug (MENU (Quit File Modify Execute Showlinks)

(q (return)) ’

(f (MENU (Load Save Clear Plot)

(I (PUSH $FILES (openi (FNAME ".net")))) (s («=> net SAVE)) ;;;;

(c (=> net CLEAR))

(p (=> net PLOT (=> net SUBNET)

Cm fUFWii (laa ( PR 2 M ! T " how man >' c y c, es")))))

(m (MENU (Add-node Set-value Link Del -node Unlink) (a (setq node (PROMPT "name"))

(=> net ADD («> Node new node)))

(setq node («> net FIND “node"))

(*> node ERASE) '

(-> node SETVALUE (PROMPT "value"))

(-> node DRAW)) ;;

(setq It (or (MENU

(A—> I—o S<—> Xo-o Co->)

(s

(I

96 BYTE LISTINGS SUPPLEMENT

(»> (-> net FIND "from") LINKTO (-> net FIND "to") It))

(d (-> net DEL (-> net FIND "name")))

(u (=> (=> net FIND "from") UNLINK

(-> net FIND "to")))))

(e (MENU (Reset Cycle)

(r (=> net RESET))

(c (-> net RUN

(PROMPT "how many cycles") t nlI nil))))

(s (-> net SHOWLINKS (-> net FIND "node"))))

(go loop)))

(defmacro MENU (Items irest actions &aux command expr) (setq command (FIRST-CHAR (PROMPT items)))

(do11st (a actions expr)

(and (= (FIRST-CHAR (car a)) command}

(setq expr (cons 'progn (cdr a))))))

(defun FIRST-CHAR (x) ; first case I ess char

(bit-and 31 (ascii (symbol-name x))))

(d

efun PROMPT (str) ; read an atom

(cond ($FILES

(or (read (car $FILES))

(progn (close (car $FILES))

(setq $FILES (cdr $FILES)) (PROMPT str))))

(t (GOTO 1 1) (ERASETOEOL) (princ str) (princ “?“) (read))))

; I***************************************************

; * support functions

; it**************************************************

(defun PLABEL (a b c char fp) ; used by PLOT (princ a fp)

(dotlmes (J (- (/ $PW 2) 3)) (princ char fp)) (princ b fp) ..

(dot imes (j (- (/ $PW 2) 3)) (princ char fp)) (princ c fp)

(terpri fp))

(defun PRINTL (I fp) S print

(dolist (x I) (princ x fp) (princ " (terpri fp))

Iist w/o paren " fp))

(defun FNAME (typ) ; make a filename str

(strcat (symbol-name (PROMPT "file")) typ))

(defmacro PUSH (stack item) ; standard macro

‘(setq .stack (cons .item .stack)))

(defun PSCALE (vol) ; (0.100)-->(0,$PW-1)

(/ (* $PW val) $RES))

♦ Globa I varlab Ies

*********♦*♦*♦*♦♦***♦*******♦♦*****♦**********♦)(*****

(setq $RES 100) (setq $PW 60) (setq $ALV 20) (setq $ILV -45) (setq $FILES nil)

resolution of arlth. printing width activation link value Inhibition link value stack of Input files

it**************************************************

* primitives for handling screen updates

* below Is for ANSI standard; need to personalize

t***************************************************

(defun GOTO (I In col) (princ "NeT") (princ I In) (write-char 59) (princ col)

(princ *H))

(defun CLS ()

(princ "\e[2J"))

(defun ERASETOEOL () (princ "\e[0K"))

; move the cursor

; clear the screen

; ERASE to end of line

**************************************************** * macros for nonquoted object handling ****************************************************

(defmacro defclass • define a new class

(newclass superclass &rest Ivors)

'(progn (setq .newclass (Class ’new))

(.newclass ’isnew .superclass)

(.newclass ’Ivors ’.©ivars)

’(.superclass .newclass)))

(defmacro defmethod ; define a new method

(class selector args &rest body)

‘(progn (.class 'answer '.selector ’.args ’.body) ’(.class .selector)))

(defmacro «> (class selector &rest args) -.SEND message ’(.class ’.selector .©args))

; **************************************************** ; * The Net object

. ****************************************************

(defclass Net Object

(nodes ; just a I 1st of nodes

line)) ; and the next display line

(defmethod Net Isnew ()

(setq line 2) self)

**************************************************** * query methods

****************************************************

(defmethod Net SUBNET (&oux I n) ; get a subnetwork (setq n (PROMPT "how many nodes"))

(dotimes (i n (reverse I))

(PUSH I («> self FIND "node"))))

(defmethod Net FIND (str) ; get o node by name

(prog (out name)

(setq name (PROMPT str)) look (doIist (n nodes)

(and (eq (=> n NAME?) name)

(setq out n)))

(and out (return out))

(setq nome (PROMPT "the name of a node"))

(go look)))

; **************************************************** ; * method which modify networks

; ****************************************************

(defmethod Net ADD (node) ; add a node

(setq nodes (nconc nodes (cons node nil)))

(«> node RENUM line)

(setq line (1+ Iine))

98 BYTE LISTINGS SUPPLEMENT

(-> node DRAW))

(defmethod Net DEL (node) ; delete a node

(dolist (n nodes) (*> n UNLINK node))

(setq nodes (delete node nodes))

(«> self RENUMBER))

(defmethod Net CLEAR () ; empty network

(do list (n nodes) («> n CLEARLINKS))

(setq line 2)

(setq nodes nil)

(«> self REDRAW))

(defmethod Net RESET () ; reset all nodes

(dolist (n nodes) (=> n RESET))

(«> self REDRAW))

(defmethod Net RENUMBER () ; compact display

(setq line 2)

(dolist (n nodes)

(=> n RENUM line)

(setq line (1+ I ine)))

(=> self REDRAW))

; **************************************************** ; * methods for displaying, plotting, and saving nets

; ****************************************************

(defmethod Net REDRAW () ; REDRAW the screen

[dolist (n nodes) (=> n DRAW)))

(defmethod Net SHOWLINKS (node) ; graph 1 node [dolist (n nodes) (*> n SHOWTO node)))

; RUN iterates n cycles and animates and/or plots (defmethod Net RUN (n aflag pflag fp &aux piine)

(-> self REDRAW)

(and pflag (dotlmes (i $PW) (PUSH piine n •'))) (dotimes (i n)

(cond

(pflag

(princ (substr (strcat (itoa i) " ") 1 3)

, f P) .

(princ fp)

(mapl #'(lambda (x) (rplaca x " ")) piine) (dolist (n nlist) (*> n PLOT pline))

(dolist (ch pline) (princ ch fp))

(terpr I fp)))

(dolist (n nodes) (■> n SEND))

i dolist (n nodes) (*> n UPDATE aflag))

GOTO 1 1) princ 1) terprt)))

; SAVE creates a file with commands to recreate net (defmethod Net SAVE (&aux fp)

(setq fp (openo (FNAME M .net M )))

(dolist (n nodes) («> n DUMP fp))

(doIist (nl nodes)

(doI 1st (n2 nodes)

(«> nl DUMPLINK n2 fp)))

(close fp))

; PLOT makes ascii printer timeline files (defmethod Net PLOT (nlist cycles Sea ux fp)

(setq fp (openo (FNAME ".pit")))

(dolist (n nlist) (■> n LABEL fp))

(PLABEL M 0.0 M '•©.S'* M 1.0" ” M fp)

(PLABEL " +|- M M -j- M M -| M M - M fp)

(-> self RUN cycles niI t fp)

(close fp)

(-> self REDRAW))

[continued)

BYTE LISTINGS SUPPLEMENT 99

February

; **************************************************** ; * the Node object

; ****************************************************

(defclass Node Object (name

value initval contr lb aline 11 Inks alinks))

printing name activation value Initial value temp for col lection animation line Inhibition I inks activation I inks

(defmethod Node isnew (nm ^optional val line)

i setq name nm)

setq value (setq initval (or val 0))) setq contrib 0) setq aline (or line 2)) self)

; ****************************************************

; * these methods do the actual arithmetic ; * for spreading activation and lateral inhibition ; ****************************************************

(defmethod Node SEND (&aux c) ; Spread activation (cond ((not (zerop value))

(setq c (* value $ALV))

(doIist (I alInks)

(«> I RECEIVE c))

(setq c (* value $ILV))

(do IIst (I iI Inks)

(«> I RECEIVE c)))))

(defmethod Node RECEIVE (val) ; collect activation (setq contrlb (+ contrib val)))

; update value

(defmethod Node UPDATE(fIag &aux newval)

(setq contrib (min $RES (max (- $RES)

(/ contrib $RES))))

(setq newval

(cond ((minusp contrib)

(+ value (/ (* contrib value) $RES))) (t (+ value

(/ (* contrib

(- $RES value))

$RES)))))

(cond ((and flag (not (■ value newval))) ; animate («> self ERASE)

(setq vaIue newvaI)

(«> self DRAW))

(t (setq value newval)))

(setq contrib 0))

; ****************************************************

; * these methods are for "graphic" display

; ****************************************************

(defmethod Node DRAW () ; "draw" node

(GOTO aline (1+ (PSCALE value)))

(princ name))

(defmethod Node ERASE () ; erase node

(GOTO aline (1+ (PSCALE value)))

(ERASETOEOL))

(defmethod Node SHOWTO (node &aux sum) ; grphic links («> self DRAW)

(princ " ")

(setq sum (•> self BILINKS? node))

(princ (nth sum •(" " —> —o —*

<— <-> <-o <-*

o— o-> 0-0 0“*

*— *-> *—0 *-*)))

(and (eq self node) (princ "SHOWING"))

(terpri))

100 BYTE LISTINGS SUPPLEMENT

(defmethod Node PLOT (ol) ; put o char in plot

(rplaca (nthcdr (PSCALE value) ol)

(or (and (- “ " (nth (PSCALE value) ol)) (chr (+ 63 aline)))

•'?“)))

(defmethod Node LABEL (fp) ; make legend for plot

(PRINTL ‘(.name - ,(chr (+ 63 aline))) fp))

; ****************************************************

; * These are "predicates" used for querying a node

; ****************************************************

(defmethod Node LINKS? (node) ; what links to node? (+ (or (and (member node allnks) 1 ) 0 )

(or (and (member node Minks) 2) 0)))

(defmethod Node BILINKS? (node) ; bidirectional links? (+ (-> self LINKS? node)

(* 4 (•> node LINKS? self))))

(defmethod Node NAME? () ; whats your name?

name)

; **************************************************** ; * the next methods are used in saving a file

j ****************************************************

(defmethod Node DUMP (fp) ; commands to add node

(PRINTL *(m a .name) fp)

(or (* 0 value)

(PRINTL '(m s .name .value) fp)))

; commands to link

(defmethod Node DUMPLINK (node fp &aux I type)

(seta I type (-> self LINKS? node))

(or (zerop (bit-and 1 Itype))

(PRINTL *(m I a .name .(«> node NAME?)) fp)) (or (zerop (bit-and 2 Itype))

(PRINTL '(ml i .name .(-> node NAME?)) fp)))

; ****************************************************

; * these methods modify nodes

; ****************************************************

(defmethod Node UNLINK (node) ; remove Iway links

S setq allnks (delete node allnks)) setq II Inks (delete node iI inks)))

(defmethod Node RESET Q 5 reset to initial val

(setq value initval))

(defmethod Node SETVALUE (val) ; change the value (setq value (setq initval val)))

(defmethod Node LINKTO (node type); create a link (or (zerop (bit-and 1 type))

(setq alinks (cons node allnks)))

(or (zerop (bit-and 2 type))

(setq iI inks (cons node II inks)))

(or (zerop (bit-and 12 type))

(«> node LINKTO self (/ type 4))))

(defmethod Node RENUM (line) ; change display line (setq aline I 1 ne))

(defmethod Node CLEARLINKS () ; fix circular

(setq alinks (setq Minks nil))) ; lists for gc

so12.Isp TEXT

"Interpretation of Natural Language," Jordan Pollock and David L. Waltz. February, page 189.

(expand 45) ; make some space

; **************************************************** ; * edltnet Is the main routine ; ****************************************************

(defun edltnet (&aux net node It qflag) (setq net (■> Net new))

(CIS)

(nuII qfIag)

(while

(gc)

(MENU

!?

(s

nil))

(Quit File Modify Execute Showlinks)

(setq qflog t))

(MENU (Load Save Clear Plot)

I (PUSH $FIIES (openl (FNAME ".net")))) s («> net SAVE)) c (-> net CLEAR))

p (-> net PLOT (-> net SUBNET)

(PROMPT "how many cycles")))))

(m (MENU (Add-node Set-value Link Del-node Unlink)

(a (setq node (PROMPT “name"))

(*> net ADD (“> Node new node 0)))

(s (setq node («> net FIND "node"))

(-> node ERASE)

(-> node SETVALUE (PROMPT "value"))

(«> node DRAW))

(I (setq It (or (MENU

(A—> I—o S<—> Xo-o Co->)

(a 1)(l 2)(s 5)(x 10)(c 9))

0 ))

(-> (.> net FIND "from") LINKTO

(-> net FIND "to") It))

net DEL («> net FIND "name")))

(«> net FIND "from") UNLINK (-> net FIND "to")))))

(e (MENU (Reset Cycle)

(r (-> net RESET))

(c (-> net RUN

(PROMPT "how many cycles") t nil nil))))

(-> net SHOWLINKS (-> net FIND "node"))))

(i is

(ndefun MENU (Items &rest actions &aux command expr) (setq command (FIRST-CHAR (PROMPT items)))

(do list (a act ions)

(and (= (FIRST-CHAR (car a)) command)

(setq expr (cons 'progn (cdr a)))))

(eval expr))

(defun FIRST-CHAR (x) ; first case I ess char

(blt-and 31 (ascii (symbol-name x))))

(defun PROMPT (str) (cond ($FILES

read an atom

(t

(or (read (car $FILES))

(progn (close (car $FILES))

(setq $FILES (cdr $FILES)) (PROMPT str))))

(GOTO 1 1) (ERASETOEOL) (prlnc str) (prlnc "?") (read))))

102 BYTE LISTINGS SUPPLEMENT

; **************************************************** ; * support functions

; ****************************************************

(defun PLABEL (a b c char fp) ; used by (princ a fp)

(dotimes (j (- (/ $PW 2) 3)) (princ

S princ b fp)

dotimes (j (- (/ $PW 2) 3)) (princ (princ c fp)

(terpri fp))

(defun PRINTL (I fp)

(dolist (x I) (princ x (terpri fp))

fp)

; print (princ "

PLOT

char fp)) char fp))

Iist w/o paren

" fp))

(defun FNAME (typ)

(strcat (symbol-name (PROMPT (ndefun PUSH (stack item)

(aval (list 'setq stack (I

; make a fiIename str "file")) typ))

; standard macro ist 'cons item stack))))

(defun PSCALE (val)

(/ (* $PW val) $RES))

; (0,100)—>(0,$PW-1)

; **************************************************** ; * GIobaI var tables

; ****************************************************

(setq $RES 100) (setq $PW 60) (setq $ALV 20) (setq $ILV -45) (setq $FILES nil)

resolution of arith. prInting width activation link value inhibition I ink value stack of input files

; **************************************************** ; * primitives for handling screen updates ; * below is for ANSI Standard; need to personalize ; ****************************************************

(defun GOTO (I in col) (princ "\e[") (princ lin) (write-char 59) (princ col)

(princ *H))

(defun CLS ()

(princ "\e[2J"))

(defun ERASETOEOL () (princ "\e[0K"))

; move the cursor

; clear the screen ; ERASE to end of line

; **************************************************** ; * macros for nonquoted object handling ; ****************************************************

(ndefun defclass ; define a new class

!! newclass superclass ivars) set newclass (Class ’new))

eval (list newclass ’’isnew superclass)) eval (list newclass ’’ivars

(list 'quote ivars))))

(ndefun defmethod ; define a new method

!! class selector args &rest body) eval (list class ’'answer (list 'quote selector) I 1st 'quote args)

I ist 'quote body})))

(ndefun -> (class selector &rest args) ;SEND message (eval (cons class (cons (list 'quote selector)

args))))

{continued)

BYTE LISTINGS SUPPLEMENT 103

• **************************************************** ; * The Net object

; **************************************************** (defclass Net Object

(nodes ; just a list of nodes

line)) ; and the next display line

(defmethod Net isnew ()

(setq line 2) self)

; **************************************************** ; * query methods

; ****************************************************

(defmethod Net SUBNET (&aux I n) ; get a subnetwork (setq n (PROMPT "how many nodes"))

(dotimes (i n (reverse I))

(PUSH I («> self FIND "node"))))

(defmethod Net FIND (str &aux out name) ; get a node (whiIe (nu I I out)

(setq name (PROMPT str))

(dolist (n nodes)

(and (eq (*> n NAME?) name)

(setq out n)))

(setq str "the name of a node") out))

; **************************************************** ; * method which modify networks ; ****************************************************

(defmethod Net ADD (node) ; add a node

! setq nodes (nconc nodes (cons node nil)))

-> node RENUM line) setq line (1+ I ine))

-> node DRAW))

(defmethod Net DEL (node) ; delete a node

(dolist (n nodes) (■> n UNLINK node))

(setq nodes (delete node nodes))

(•> self RENUMBER))

(defmethod Net CLEAR () ; empty network

(dolist (n nodes) (=> n CLEARLINKS))

(setq line 2)

(setq nodes nil)

(«> self REDRAW))

(defmethod Net RESET () ; reset all nodes

(dolist (n nodes) («> n RESET))

(«> self REDRAW))

(defmethod Net RENUMBER () ; compact display

(setq line 2)

(doIist (n nodes)

(«> n RENUM line)

(setq line (1+ I ine)))

(«> self REDRAW))

; **************************************************** ; * methods for displaying, plotting, and saving nets ; ****************************************************

(defmethod Net REDRAW () ; REDRAW the screen

(CLS)

(dolist (n nodes) (=> n DRAW)))

(defmethod Net SHOWLINKS (node) ; graph 1 node (CLS )

(dolist (n nodes) («> n SHOWTO node)))

; RUN iterates n cycles and animates and/or plots (defmethod Net RUN (n aflag pflag fp &aux piine)

(«> self REDRAW)

104 BYTE LISTINGS SUPPLEMENT

(ond pflog (dotlmes (I $PW) (PUSH pllne " "))) (dotimes (i n)

(cond (pflag

(prlnc (substr (strcat (Itoa i) " ") 1 3)

/ fp ) ^

(princ fp)

(mapllst '(lambda (x) (rplaca x " ")) pI Ine)

(dolist (n nI 1st) (*> n PLOT pllne))

(do list (ch pllne) (princ ch fp))

(terpri fp)))

(dotist (n nodes) («> n SEND))

(dolist (n nodes) (=> n UPDATE aflag))

(GOTO 1 1)

(princ i)

(terpri)))

; SAVE creates a file with commands to recreate net (defmethod Net SAVE (&aux fp)

(setq fp (openo (FNAME ".net")))

(do Iist (dolist

(close fp))

; PLOT makes ascii printer timeline files (defmethod Net PLOT (nlist cycles &aux fp)

(setq fp (openo (FNAME ".pit")))

(dolist (n nlist) (=> n LABEL fp))

(PLABEL " 0.0" "0.5" "1.0. fp)

! PLABEL “ + |- M M -| M fp)

■> self RUN cycles nil t fp) close fp)

«> self REDRAW))

; **************************************************** ; * the Node object

; **************************************************** (defclass Node Object

(name

printing name activation value initial value temp for coI Iection animation line inhibition links activation links

va I ue

i nitvaI contrib aline

i I inks a I Inks))

(defmethod Node isnew (nm val)

(setq name nm)

(setq value (setq initval val))

(setq contrib 0)

(setq aline 2) self)

; **************************************************** ; * these methods do the actual arithmetic ; * for spreading activation and lateral inhibition ; ****************************************************

(defmethod Node SEND (&aux c) ; Spread activation (cond ((not (zerop value))

(setq c (* value $ALV))

(doli81 (I alinks)

S (»> I RECEIVE c)) setq c (* value $ILV)) dolist (I i I inks)

(«> I RECEIVE c)))))

(defmethod Node RECEIVE (val) ; collect activation (setq contrib (+ contrib val)))

update value

( continued )

BYTE LISTINGS SUPPLEMENT 105

(defmethod Node UPDATE (flag &aux newval)

(setq contrlb (min $RES (max (minus $RES)

(/ contrlb $RES))))

(setq newval

(cond ((minusp contrlb)

(+ value (/ (* contrlb value) $RES))) (t (+ value

(/ (* contrlb

(- $RES value))

$RES)))))

(cond ((and flag (not (■ value newval))) ; animate (-> self ERASE)

(setq value newval)

(-> self DRAW))

(t (setq value newval)))

(setq contrlb 0))

; **************************************************** ; * these methods are for "graphic" display ; ****************************************************

(defmethod Node DRAW () ; "draw" node

(GOTO aline (1+ (PSCALE value)))

(prlnc name))

(defmethod Node ERASE () ; erase node

(GOTO aline (1+ (PSCALE value)))

(ERASETOEOL))

(defmethod Node SHOWTO (node &aux sum) ; grphic links (»> self DRAW)

(prlnc " ")

(setq sum («> self BILINKS? node))

(prlnc (nth sum '(" " —> —o —*

<— <-> <—o <-*

o— o-> o-o o—*

*— *-> *—o *-*)))

(and (eq self node) (prlnc "SHOWING"))

(terpri))

(defmethod Node PLOT (ol) ; put a char In plot

(rplaca (nthcdr (PSCALE value) ol)

(or (and (- " " (nth (PSCALE value) ol)) (chr (+ 63 aline)))

"?")))

(defmethod Node LABEL (fp) ; make legend for plot

(PRINTL (list name (chr (+ 63 aline))) fp))

; **************************************************** ; * These are "predicates" used for querying a node ; ****************************************************

(defmethod Node LINKS? (node) ; what links to node? (+ (or (and (member node alinksj 1) 0)

(or (and (member node Minks) 2) 0;))

(defmethod Node BILINKS? (node) ; bidirectional links? (+ («> self LINKS? node)

(* 4 (*> node LINKS? self))))

(defmethod Node NAME? () ; whats your name?

name)

; **************************************************** ; * the next methods are used in saving a file ; ****************************************************

(defmethod Node DUMP (fp) ; commands to add node

(PRINTL (list *m 'a name) fp)

(or (=* 0 value)

(PRINTL (I i81 'm *s name value) fp)))

; commands to link

(defmethod Node DUMPLINK (node fp &aux I type)

(setq I type (-> self LINKS? node))

(or (zerop (bit-and 1 Itype))

106 BYTE LISTINGS SUPPLEMENT

(PRINTL (list 'm ’I ’a name («> node NAME?)) fp))

(or (zerop (bit-and 2 Itype))

(PRINTL (list ’m 'I 'i name (-> node NAME?)) fp)))

; ****************************************************

; * these methods modify nodes

; ****************************************************

(defmethod Node UNLINK (node) ; remove Iway links (setq alinks (delete node alinks))

(setq ilinks (delete node Minks;))

(defmethod Node RESET () ; reset to initial val

(setq value initval))

(defmethod Node SETVALUE (val) ; change the value (setq value (setq initval val)))

(defmethod Node LINKTO (node type); create a link (or (zerop (bit-and 1 type))

(setq alinks (cons node alinks)))

(or (zerop (bit-and 2 type))

(setq Ilinks (cons node ilinks)))

(or (zerop (bit-and 12 type))

(=> node LINKTO self (/ type 4))))

(defmethod Node RENUM (line) ; change display line (setq aline Iine))

(defmethod Node CLEARLINKS () ; fix circular

(setq alinks (setq ilinks nil))) ; lists for gc

• **************************************************** ; * XLISP 1.4 quasi-compatible functions ; ****************************************************

(ndefun dolist (iexp &rest exprs)

(mapcar (cons 'lambda (cons (list (car iexp))

exprs))

(eval (cadr iexp)))

nil)

(ndefun dotimes (iexp Screst exprs)

(eval (list 'progn

(list 'setq (car iexp) -1)

(cons 'repeat

(cons (cadr iexp)

(cons (list * setq

! car iexp)

list '1+ (car iexp))) exprs))))))

defun zerop (x) (- x 0)) defun minusp (x) (< x 0;)

stramdsk.c TEXT

"Programming Tools and the Atari 520st", Bruce Webster.

February, page 331. Also download ST.doc

ALERT /* ALERT /* ALERT

DOWNLOAD! ST.doc for the revised ST upgrade procedure

DOWNLOADl ST.doc for the revised ST upgrade procedure

DOWNLOAD! ST.doc for the revised ST upgrade procedure

[continued)

BYTE LISTINGS SUPPLEMENT 107

RAM DISK ACCESSORY version 1.1 - sept 10. 1985,

Gert Slavenburg, Mountain View, CA.

For Atari 520ST with RAM extension to 1 MByte.

Link this program with accstart,%1,osbind,vdibind,aesbind

This Is the first, experimental version of the RAMdisk. It should be installed as a DESK ACCESSORY on the Bootdisk.

(that is it should be called either DESKI,DESK2, or DESK3.ACC). Before re-booting, and thus activating It, the menu entry "install disk" should be used to install drive "D" with Icon-label "RAMDISK". Then save the desktop to make the newly installed drive permanent. Now re-boot end enjoy.

(write protect if you're paranoid - I am)

This version (1.1) avoids any directory knowledge by just copying the whole disk that it is booted on into the RAMdisk. This makes booting seem to take forever. Throw away any files on the RAMdisk that you don’t want by Just deleting them !

You may get annoyed by my trick to let the RAMdisk give a beep every 30 seconds. This was a debugging tool for me to see if it's still alive, and I get worried now if I don’t hear it anymore... To remove it, Just replace the "beep" statement in procedure "sleep".

known bugs :

1) GEMDOS refuses to do full diskette copy to/from the

RAMdisk. Don't know why it does that, since the BPB's are identicaI.

Lots of fun - Gert

*/

^include "portab.h"

^Include "obdefs.h"

#incIude "define.h"

#include "gemdefs.h"

^include "osblnd.h"

struct bpb .More..

\ WORD recsiz, /* see BIOS:rwabs.c for more info */

c I s I z, c I s izb, rdIen, fsiz, fatrec, datrec, numcI, bfIags;

/*

/* stupid AES binding arrays - what a drag */

int contrI[12]; int intin[1281; int ptsin[128J; int intout[l28l; int ptsout[l28J;

/* better find out what’s REALLY NEEDED ★/

/* the variables below are really serious */

#

typedef LONG (*PFL)(); /* define "pointer to function returning a long" */ typedef WORD (*PFW)(); /* define "pointer to function returning a word" */

PFL getbpb; PFW mediach; PFL rwabs;

/* pointer to the systems original getbpb function */

/* pointer to the systems original mediach */

/* pointer to the systems original rwabs */

struct bpb rdiskbpb = { 512, 2, 1024, 7, 5, 6. 18, 351, 0

/* same as Single Sided microdiskette */

Int data[184320]; /* 720 sectors of 512 bytes */

/* same as Single Sided microdiskette */

108 BYTE LISTINGS SUPPLEMENT

LONG RDgetbpb(dev)

WORD dev;

* if (dev !« 3)

return( (*getbpb)(dev) ); /* pass all non-RAMdisk to old handler */

e I se

} return( fcrdiskbpb ); /* return our bpb */

} 1

WORD RDmediach(dev)

WORD dev;

if (dev I* 3)

return((*mediach)(dev)) ; /* pass all non-RAMdisk to old handler */

e I se

return( 0 ); /* RAMDISK media never changes */

LONG RDrwabs(rw,buf.count,recno.dev) WORD rw; int *buf;

WORD count, recno, dev;

I int I, *p;

if (dev 1- 3)

return( (*rwabs)(rw,buf,count,recno,dev) ); /* pass it on */ else

\ if (rw > 1) rw —2; /* we never change media anyway */

while ( count > 0 )

{ p * &data[((long) recno) * 256L];/* both casts necessary - C068 bug */ if (rw**0) /* read */

for (i«0; 1<256; i++) *buf++ « *p++; else /* write */

for (i=0; i<256; i++) *p++ ■ *buf++; count—; recno++;

return(0L);

i

instalI() /* take over DISKIO vectors. MUST RUN AS SUPERVISOR */

{

long *bpbvect « 0x472; long erwvect * 0x476; long *mcvect ■ 0x47e; long *devset ■ 0x4c2;

getbpb * *bpbvect; /* save old vectors */

mediach = (PFW) *mcvect; rwabs * (PFL) *rwvect;

♦bpbvect * RDgetbpb; /* install new ones */

*mcvect « RDmediach;

♦rwvect ■ RDrwabs;

/* vectors set-up, include in deviceset : */ ♦devset « (>»«devset) | (0x8L);

sleep() /* sleep forever */

\ int i; while (1)

{ i « evnt_timer(30000,0); /* wait 30 Sec. */ Bconout(2,7); /* BEEP to show I’m alive */

main()

appl-Inlt();

Rwabs(0,dota,720,0,0);

xbios(38,InstalI); s I eep();

/* this Is needed even to link - Yack 111! 111 */

/* copy drive A: into RAMdlsk data array */

/* INSTALL vectors in SUPV MODE */

/* accessories never end . */

( continued )

BYTE LISTINGS SUPPLEMENT 109

February

St.doc TEXT

"Programming Tools and the Atari 520ST", Bruce Webster. February, page 331. Also download ST2.doc.

atari/tech.st #239, from bwebster, 14398 chars, Thu Jan 30 23:46:40 1986

TITLE: *** ALERT! ALERT! ALERT! ***

Checked into my arpa/uucp mail node for the first time in about a month and found the following message. Could make for some interesting complaints about the Feb BEST OF BIX section.

This is a modification to gert's original posting. You should read it carefully if you are planning to upgrade your ST as there are some important modifications. I got this from a posting on net.micro.atari.

>From bammi@cwruecmp.UUCP (Jwahar R. Bammi) Wed Dec 18 13:09:35 1985 Path: umcp-cs!seismo!harvard!thInk!mit-eddie!genrad!decvax!cwruecmp!bammi Newsgroups: net.micro.atarI

Subject: Re: one meg upgrades - PLEASE READ or fry your ST References: <157@lmagen.UUCP>

> NWMWMWMNMWMWMMMMMMMpO p gOSS the ST~~~~~~~~~~~~~~~~~~~

>

> i just fried my ST and after talking to atari and my local dealer i

> have tracked down the problem. It is related to the 1 Meg upgrade

> and the new proms, it seems that the early postings of "how to

> upgrade ...." left out 4 critical resisters (60 ohm 10% tol); 2 must

> be placed on the CAS lines and 2 on the RAS lines, all 4 go on the

> MMU (i know it isnt really an MMU) side, the upgrade will work fine

> w/o the resistors until you put in the new proms, the difference in

> the current drain will cost you all your memory chips and possibly

> the MMU.

> —

> god bless LIly St. Cyr

> -Rocky Horror Picture Show

>

> Name: James Turner

> Mail: Imogen Corp. 2650 San Tomas Expressway, P.0. Box 58101

> Santa Clara, CA 95052-9400

> AT&T: (408) 986-9400

> UUCP: ...{decvax,ucbvax}!decwrI!imagen!turner

After reading the above article, I downloaded the revised procedure from Compu Serve. I have had the upgrade for about 3 months, and has worked without a flaw. I would have probably added the proms without the resistors. Thanks to Mr. Turner for the warning.

Here is a copy of the revised procedure:

NOTE: This is an REVISED,TESTED version of the original text downloaded from CompuServe. December 6, 1985

(This was REVISED AND TESTED by an annonymous engineer on Atari's developement staff. The addition of the resistors should provide a long life to your machine, but the warning below is STILL IN EFFECT. This is not an official sanction of the modification. USE WITH CARE!!!)

Here's the 1 Meg upgrade directions:

I have brought this over un-editted from the arpanet info-st mailing list. I TAKE NO RESPONSIBILITY FOR ITS CONTENT OR ACCURACY. I HAVE NOT TRIED THIS MODIFICATION ON MY OWN ST AS YET. I AM PASSING THIS ALONG TO THOSE WHO DO WISH TO TRY IT.

FOLLOW THE DIRECTIONS AT YOUR OWN RISK.

—Dwight McKay (75776,1521)

From: gert@pescadero

110 BYTE LISTINGS SUPPLEMENT

WARNING: This is a hardware modification that will void the warranty of your 520ST. If you do not have the appropriate tools or experience you have a substantial chance of ruining your 520ST. Proceed at your own risk! This modification has been in my 520ST without any problems for 6 days now. However, I have (of course) not checked with knowledgable sources at Atari to verify if this modification endangers the long term machine reliability and/or software compatibility (I suspect it may endanger their software compatibility if enough of us do it!)

Tools & components needed :

16 256k * 1 RAM chips, 150 ns access time type, e. g. NEC

41256C-15 (avilable at e. g. Fry's Electronics, Sunnyvale,

CA for $2.77 each)

A good quality, preferrably temperature controlled soldering iron, with a minature tip (tip should be narrow enough to avoid touching 2 I. C. pins at the same time). E. g. Weller type soldering station.

Good quality resin core solder (thin).

Approximately 4 foot of #24 AWG insulated wire and a good stripper for it and 2 feet of #22 AWG solid tinned copper bus wire. You will have to route 3 wires over a sequence if I.C. pins.

Desoldering wick and solder suction tool.

Philips typ e screwdriver (for opening your ST), tweezers pI iers, etc.

A steady hand and self-confidence.

Explaination of the modification :

(Please read the rest of this document before starting. It may save you time and an 520ST)

The current memory inside the 530ST consists of 16 256K*1

RAM chips. Address (A0..A8) lines are common to all those

chips. The WriteEnable line is also common to all chips.

Data (in and out} lines are of course individual. The RAS (row-address strobe) line is common to all chips. The 8 chis foring the high order byte group have one common CAS line, and the 8 forming the low order byte group have one common CAS line (CAS is used as enable for write operations, such that WriteEnable can be common to both groups). The high order group from MSB to LSB consists of U45, 44, 43, 42, 38,

34, 33, 32. The low order group of U30, 29, 28, 25, 24, 28,

27, 26. Note that all chips are adjacent, though the

numbering has gaps. RAS0, CAS0H, and CAS0L are supplied from U1 pin 8,6 and 7 respectively (The 0 indicates bank 0)

Bank 1 that you are going to build in will be "piggy-backed" on top of the current chips, where all pins of the new chips EXCEPT RAS (pin 4) and CAS (pin 15) are soldered to the old chips equivalent pins. Thus they will end up sharing addresses, data, WriteEnable and power and ground with the existing chips.

All RAS pis of the new chips are wired together and will be supplied with the "RASI" signal generated on pin 18 of U15 (the memory controller, marked 3H-2119C or so). The CAS pins of the 8 new high order byte chips (on top of U45..U32) are wired together and supplied from the "CAS1H" signal generated on pin 22 of U15. Analogously, the CAS pins of the new U30 to U16 are wired together and supplied with "CASH" from pin 21 of U15.

How to go about it:

Step 1: Open up your 520ST, pull off the keyboard connector

and remove the main circuit card from its top and bottom shielding. Make sure to remember which screws go where and note the keyboard connector orientation.

Step 2: Oesolder all of existing RAM chips. (DO NOT if you do, and worse, the since you can't solder rellably (If at all)). To to heat the island on the wires straight. After do over to the component side the capacitor out with the

the capacitors adjacent to the SKIP THIS STEP. You'll lose time modification will no be reliable pins obstructed by the capacitors desolder them, I found it easiest non component side, and bend the ing that or each capacitor, turn and heat the islands wile pulling tweezers.

Step 3: Open up the holes of all the desoldered capacitors, using a combiation of de-soldering wick and suction tool. Do this from the non component side. If certain holes are difficult to open up, you may want to use a wood splinter, (push it through while heating). Be careful I to remove all solder debris!! THE REASON for opening the holes NOW is that they will be less accessible once you've done the other steps! Patience is a virtue.

(NOTE: Step 2 k 3 are the only ones that may damage your ST PC board. Be sure not to use excessive force while pul I Iing out the capacitors. If you damage your PC board anyway, cure the problem now and not later).

Step 4: In this step we will piggyback the new RAM's on top of the old oes. Be sure to connect all pins except pin 4 (RAS) and 15 (CAS). The best way to go about this is to do chip by chip. First, bend the pins of the new RAM's suchthat hey are perpendicular to the package (instead of having slightly spread "cowboy legs"). Use pliers to bend pin 4 and

15 such that the legs are 180 degrees from their normal position, so they stick up in the air above the plane of the top surface of the chips. Don't make an absolute sharp 180 degree bend since some manufacturers' pins may snap off. Leave a little curve in the leg, but insure that is above the plane of the top surface of the chip.

Using #22 AWG to #16 AWG tinned solid copper wire you will form three buses along the top surface of the new d-rams. Cut a #22 AWG solid copper wire the length of the 16 d-rams on the PCB. The RAS bus is formed by soldering all the pin 4's of the new d-rams to the solid copper wire. The bus wire must be seated against the top surface of the new d-rams without a gap. This insures clearance between the top shield and the pins of the d-rams.

After soldering all 16 d-rams to the bus clip off any portion of the pins that extend above the top of the bus wire. Now cut a #22 AWG solid copper wire the length of the

16 d-rams. Place the bus wire along the top surface of the new d-rams in contact with all the pin 15's of the new d-rams. Solder every pin 15 to this bus and as above insure that the wire is seated solidly against the top surface of the new d-rams. Cut off all excess pin length sticking up above the top of the bus wire. Using diagonal cutters remove the section of the bus connecting the new U30 pin 15 to the new U32 pin 15. This divides the bus in half with the new U16, 17, 18, 24, 28, 29 having a common pin 15. The new U32, 33, 34, 38, 42, 43, 44, 45 now have a common pin 15, seperated from the other common bus.

(NOTE: until step 6 is finished, do no i power to your ST. This intermediate state damage your memory chips!!)

n any way apply of affairs will

Step 5: Remount all the desoldered capacitors. Bend the pins like they were before resoldering, suchthat they wiI I not touch the lower shielding. Solder from the non component side.

Step 6: Orient the 520ST PCB so that you are looking at the solder side of the PCB (non-component side), with the row of

112 BYTE LISTINGS SUPPLEMENT

d-rams nearest you. Find the double square pattern of pads at the 68-pin socket of the memory controller, U15 (3H2119). The following is a guide to locating the six memory controller pins necessary to complete the wiring. The socket is numbered contercIockwise, starting with pin 1, the square pad (look closely) in the middle of the bottom outside row. The sequence, moving counterclockwise from pin 1, first on the outside square ONLY: (NOTE: the sequence ")(" means to make a 90-degree turn counterclockwise, i.e. around the corner)

1,3,5,7,9)(10,12,14,1*6,18,20,22,24,26)(27,29,31,33,35,37,39, 41,43)(44,46.48,50,52,54,56,58,60)(61,63,65,67

The sequence, moving counterclockwise along the inside square only, and starting with the left side of the bottom row:

(62.64,66,68,2,4,6.8)(11,13,15,17,19,21,23,25)(28,30,32,34,3 6,38,40,42)(45.47,49,51,53,55,57,59)

Six 68-ohm 1/4W plus/minus 10% carbon film resistors must be added when adding memory. These series terminating resistors minimize undershoot which may damage BOTH BANKS of d-rams if omitted. Solder a 68-ohm resistor to pin 18 of U15, RAS1. Solder a #24 AWG stranded wire from the remaining end of the 68 -ohm resistor to the pin 4 bus (RAS) of all the new d-rams. that is the new U16, 17, 18, 24, 25, 28, 29, 30, 32, 33, 34, 38, 42, 43, 44, and 45.

Solder a 68-ohm resistor to pin 22 of U15, CASH1. Solder a #24 AWG stranded wire from the remaining end of the 68-ohm resistor to pin 15 bus (CAS) of the new U45,44,43.42,38,34,33,32.

Solder a 68-ohm resistor to pin 21 of U15, CASH. Solder a #24 AWG stranded wire from the remaining end of the 68-ohm resistor to pin 15 bus (CAS) of the new U30, 29,28,25,24,18.17,16.

For best results in all three cases above solder the wires coming from the resistors to the middle of the three bus wires in a "T" fashion rather than at one end of the buses.

Use a continuity tester to find the following three traces — do not depend on visual inspection. Now install three 68 -ohm series terminating resistors in the original 512K bank of ram. Be very careful while soldering to these narrow traces, since excessive heat can easily lift a trace from the board. Use an Exacto knife to gently remove solder mask from traces.

Cut the trace leading from pin 8, RAS0, of U15 near U15. Solder a 68-ohm resistor in series with the trace.

Cut the trace leading from pin 6, CAS0H, of U15 near U15. Solder a 68-ohm resistor in series with the trace.

Cut the trace leading from pin 7, CAS0L, of U15 near U15. Solder a 68-ohm resistor in series with the trace.

Step 7: Sit back. Use Brain. Do you feel confident about the quality of your work? No mistakes? Check evrythlng once again if you are but a little uncertain. Applying power with errors might make your ST into a decorative, nonfunctional piece of art. OK. Either rebuild your ST into its shielding and cabinet, or put it onto a surface clear of wires and solder remians and connect It to monitor, disk and supply. Boot It.

It It boots, you're probably there. Test if the new memory works by looking at the phystop variable ($42E) with SID if you have the developer stuff. It should read $100000 (1M hex). Also note that memcntlr ($424) now holds 5 instead of 4, and that v_bas_ad ($44E) now holds $F80000 (screen bitmap

[continued)

BYTE LISTINGS SUPPLEMENT 113

origin). If you don't have the developer stuff, try a single drive copy and check that you get the whole disk In one buffer Instead of two.

If the new memory does not seem to exist, use SID to deposit and retrieve words on locations $80000 and up (1/2 Meg hex). If bit errors occur, the ST bootROM did not detect the extension (it checks ail bits of 512 locations by testing a psedo random sequence, before accepting a memory bank). Try to pin point the faulty chip(s) and remove the error.

If It doesn't boot, you're in trouble. I'm sorry. It is difficult to give hints on what to do here. So many possibilities. Desoldering the new chips probably won't work (if the old ones were functional, the ST would still boot). Check for hidden short:circuit on the RAM pins. May also be that you have a flaky new pin connection.

That's alI there is...

Usenet: CSnet: Arpa: CompuServe:

Jwahar R. Bammi

.!decvax!cwruecmp!bammi

bammi@case

bammi%case@csnet-reI ay 71515,155

gimpeI.Ibr BINARY

"Processing Strings in Snobol4," James F. Gimpel.

February, page 175. Download lu.exe to unpack this library.

LOWS ■ 'abcdefghijkImnopqrstuvwxyz*

UPS = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ*

INPUT( 'NAMES', 2 )

PATTERN = TRIM(NAMES)

L00P1 PATTERN = PATTERN | TRIM(NAMES) :S(L00P1)

PATTERN - PATTERN . NM

L00P2 LINE - INPUT :F(END)

L00P3 LINE PATTERN = REPLACE(NM, LOWS, UPS ) :S(L00P3)

OUTPUT = LINE :(L00P2)

END

LISTING2.TXT

DEFINE( 'ROMAN(N)T') :(ROMAN_END)

ROMAN N RPOS(1) LEN(1) . T :F(RETURN)

•0,1I,2II,3III,4IV,5V,6VI,7VII,8VIII,9IX,'

+ T BREAK(',') . T

ROMAN « REPLACE( ROMAN(N),*IVXLCDM*,'XLCDM**') T + :S(RETURN)F(FRETURN)

ROMAN_END

LISTING3.TXT

DEFINE ( 'SELECT(S)N* ) N

SELECT

S RPOS(1) LEN(1)

N = RANDOM(N)

S (N-1) ARB . SELECT N SELECT_END

DEFS - TABLEQ

:(SELECT_END)

: (RETURN)

DEFS

DEFS

DEFS

STACK

'SENT' 'NOUN' 'VERB'

= '<SENT>

*0The <NOUN> <VERB>s the <N0UN>1' '0boy1man2dog3<NOUN> who <VERB>s the <N0UN>4' '0bitelwaIk2pet3Iick4smack5*

LI

L2

SENTENCE *

STACK POS(0) '<' BREAK('>') . NM '>' STACK * SELECT( DEFS[NM] ) STACK STACK BREAK('<') .S =

F(L2)

(LI)

F(L3)

114 BYTE LISTINGS SUPPLEMENT

SENTENCE - SENTENCE S :(L1)

13 SENTENCE * SENTENCE STACK

Table captionLISTING4.TXT

DEFINE( ’PUSH(X)’ )

DEFINE( ’POP()’ )

DEFINE( ’TOP()’)

DATA( ’LINK(NEXT,VALUE)’ )

:(STACK_END)

PUSH

PUSH.POP - LINK( PUSH.POP, X )

PUSH - .VALUE( PUSH_POP )

:(NRETURN)

POP

IDENT( PUSH_POP)

:S(FRETURN)

POP - VALUE(PUSH.POP)

PUSH_POP « NEXT( PUSH_POP )

:(RETURN)

TOP

IDENT( PUSH_POP)

:S(FRETURN)

TOP = .VALUE( PUSH.POP )

:(NRETURN)

Table captionSTACK.END

LISTING5.TXT

LET = ’ABCDEFGHIJKLMNOPQRSTUVWXYZ’

DIGITS = ’0123456789’

IDEN - (ANY(LET) (SPAN(LET DIGITS) | ”)) . *PUSH()

+ NULL . *EV()

INTEGER - SPAN(DIGITS) . *PUSH()

PRIMARY - IDEN | INTEGER | ’(’ *E ’)’

FACTOR - PRIMARY | ’-* PRIMARY . *NEG()

TERM * FACTOR

+ ARBNO( FACTOR . *MUL() | •/• FACTOR . *DIV() )

E = TERM ARBNO( ’ + ’ TERM . *ADD() | TERM . *SUB() )

dvorak.bas TEXT

"Keyboard Efficiency," Donald W. Olson and Laurie E. Jasinski. February, page 241. Also download dvorak.txt.

100 TEXT : HOME : VTAB 10

110 PRINT "QWERTY VS. DVORAK"

120 PRINT

130 PRINT "BY D.W.OLSON AND L.E.JASINSKI"

140 DIM LA$(2),LI$(200),CH$(40),AA(40)

150 DIM FI(122.2),x(l22,2).Y(122.2).SK(122,2) 160 DIM CX(8,2),CY(8,2),DS(4,6)

170 DIM FT(8,2),HT(2,2),GT(2)

180 GOSUB 1000:SP - - 16336

200 REM MENU

210 HOME : VTAB 10

220 PRINT "1..START NEW FILE (ZEROS TOTALS)" 230 PRINT : PRINT "2..ADD TO CURRENT FILE"

240 PRINT : PRINT ”3..PRINT HARD COPY"

250 PRINT : INPUT A

260 ON A GOTO 300,400,900: GOTO 200

300 REM START NEW FILE

310 NL » 0:NW - 0:AA(0) - 32:CL - 1

320 FOR K » 1 TO 2: FOR F = 1 TO 8

330 FT(F.K) •= 0:CX(F,K) - 0:CY(F,K) - 0

340 NEXT : NEXT

350 HOME : GOSUB 500: GOTO 600

400 REM ADD TO CURRENT FILE

410 HOME : VTAB 23: PRINT LI$(NL)

420 PRINT : GOSUB 500: GOTO 600

500 REM PRINT TOTALS

A

BYTE LISTINGS SUPPLEI

119

510

515

520

530

540

550

555

560

570

580

585

590

595

600

610

620

625

630

635

640

645

650

655

660

665

670

675

680

685

690

700

710

720

730

735

740

745

750

755

760

HTAB 1: FOR I - 1 TO 12 VTAB Is CALL - 868: NEXT VTAB Is HTAB 26: PRINT "<ESC: PRINT "AFTER ";NW;" WORDS:

MENU>"

PRINT

1

+ FT(1,K) + FT(2,K

FT(6

FOR K =

HT(1,K)

HT(2,K)

GT(K) INVERSE NORMAL PRINT "

FOR F NEXT REM NL =

VTAB HTAB FOR J

GET CH$(J):AC - ASC (CH$(J)):AA(J) IF AC > 31 AND AC < 123 THEN 670 AC = 13 THEN LL * J: GOTO 680

> 1 THEN PRINT CHR$ = 1 THEN GOTO 635 NL - NL - 1: GOTO 200

»K) + FT(3,K) + FT(4,K)) »K) + FT(7, K) + FT(8,K))

TO 2

* INT (0.5

* INT (0.5 + FT(5,K HT(1, K) + HT(2,K)

: PRINT LA$(K);TOTAL INCHES: ";GT(K) PRINT "LEFT HAND: ";HT(1,K); SPC( 5 - LEN RIGHT HAND: ";HT(2,K)

1 TO 8:AX * INT (0.5 + FT(F,K)): PRINT AX; F: PRINT : NEXT K: RETURN GET NEXT LINE NL + Is POKE - 16368,0 23: HTAB 39: PRINT "|";

Is PRINT CHR$ (7);

1 TO 38

AC

( STR$(HT(1»K))));

SPC( 5 - LEN ( STR$ (AX)));

IF

IF

IF

IF

AC « 8 AND J AC = 8 AND J AC * 27 THEN GOTO 635

PRINT CH$(J);: IF J > 31 THEN PRINT CHR$ (7); NEXT J:LL = 39

(8); CHR$ (32); CHR$ (8);:J * J - 1: GOTO 635

CH$(LL)

LI$(NL)

* 32 1 TO

LL

":AA(LL)

: FOR J

LI$(NL) = LI$(NL) + CH$(J): NEXT REM ANALYZE LINE NUMBER NL HTAB 1: CALL - 868 FOR J - 1 TO LL

PRINT CH$(J);:AC * AA(J): IF AC IF AC > 96 THEN CL = 0 IF AA(J) = 32 AND AA(J - 1) < : IF AA(J) - 32 AND AA(J - 1) » 4! FOR K = 1 TO 2:F - FI(AC,K)

< > 32 THEN AX * PEEK (SP) + PEEK (SP)

► 32 THEN NW - NW + 1

> THEN NW - NW - 1

II JJ

765 CX(F,K) 770 FT(F,K) 775 SF

y{ac!k) - CY(

X(AC,K) - CX(F,K

X (AC, K FT(F

SK(AC,K): IF

F.K) + F ,K) +

,K):CY(F,K) = Y(AC.K) , K) + DS(II.JJ)

CL

AND AC >

780 IF SF > 0 AND SK(AA(J - 1),K) <

790 NEXT : NEXT : PRINT : PRINT 795 GOSUB 810: GOSUB 500: GOTO 600 800 REM FINGERS TO HOME ROW 810 FOR K = 1 TO 2: FOR F = 1 TO 8 820 IF CX(F.K) = 0 AND CY(F.K) = 0 THEN 830 II « 2 - CX(F,K):JJ = 3 - CY(F,K)

840 FT(F,K) = FT(F,K) + DS(II,JJ)

850 CX(F,K) = 0:CY(F,K) = 0

860 NEXT : NEXT : RETURN

900 REM PRINT HARD COPY

910 IF NL = 0 THEN 200

920 PRINT : PRINT CHR$ (4);"PR#1"

930 PRINT : PRINT : GOSUB 530: PRINT : PRINT 940 FOR I = 1 TO NL: PRINT LI$(I): NEXT I 950 PRINT : PRINT CHR$ (4);"PR#0"

960 GOTO 200

1000 REM KEYBOARD DATA

64 AND AC < 91 THEN 790 > SF THEN FT(SF,K) = FT(SF,K) +2.25

GOTO 860

1005 LA$(1) = "QWERTY 1010 READ AC: IF AC « READ N$: FOR K >

":LA$(2) = "DVORAK " 999 THEN 1200 1015 READ N$: FOR K = 1 TO 2 1020 READ FI(AC,K),X(AC,K),Y(AC,K),SK(AC,K) 1025 NEXT K: GOTO 1010

1032 DATA 32.SPACE,0,0,0,0,0,0,0,0

1033 DATA 33,!,1,0,2,8.1,0,2,8

1034 DATA 34,QUOTES,8,1,0,1,1,0,1,8

1035 DATA 35.#.3,0,2,8,3,0,2,8

1036 DATA 36,$.4.0,2,8,4,0,2,8

1037 DATA 37,%,4,1,2,8,4,1,2,8

1038 DATA 38.&,5,0,2,1,5.0.2.1

1039 DATA 39,APOSTROPHE,8,1,0,0,1,0,1,0

1040 DATA 40,(.7,0,2,1.7,0,2,1

1041 DATA 41.),8,0.2.1,8,0,2,1

116 BYTE LISTINGS SUPPLEMENT

February

1042 DATA 42.*,6.0,2,1,6.0,2,1

1043 DATA 43,+.8,2.2.1.8,2,1.1

1044 DATA 44,COMMA.6,0,-1,0,2,0,1,0

1045 DATA 45,-.8,1,2,0.8,1,0,0

1046 DATA 46,..7,0,-1,0,3,0,1,0

1047 OATA 47,/,8,0,-1,0,8,1,1,0

1048 DATA 48.0,8,0,2.0,8,0,2,0

1049 DATA 49,1,1,0,2,0,1,0,2,0

1050 DATA 50,2.2,0,2,0.2,0,2,0

1051 DATA 51,3.3,0,2.0,3.0.2,0

1052 DATA 52,4,4,0,2.0,4,0,2,0

1053 DATA 53,5,4,1,2,0,4,1,2,0

1054 DATA 54,6,5.-1.2,0,5,-1,2,0

1055 DATA 55,7,5,0,2,0.5,0,2,0

1056 DATA 56,8,6,0,2.0,6,0,2,0

1057 DATA 57.9.7,0.2.0,7.0,2,0

1058 DATA 58,COLON,8,0.0,1,1,0,-1,8

1059 DATA 59,SEMICOLON,8,0,0,0,1,0,-1,0

1060 DATA 60,<.6.0,-1,1,2,0.1,8

1061 DATA 61,-.8,2,2,0.8,2,1,0

1062 DATA 62,>,7.0,-1,1,3,0,1,8

1063 DATA 63,?,8,0,-1,1.8,1,1,1

1064 DATA 64,@.2,0,2,8,2.0,2,8

1065 DATA 65.A,1,0,0,8,1,0,0,8

1066 DATA 66,B,4,1,-1,8.5,-1,-1,1

1067 DATA 67,C.3,0,-1,8,6,0,1,1

1068 OATA 68,D,3,0,0,8.5.-1,0,1

1069 DATA 69,E.3,0.1,8,3,0,0,8

1070 DATA 70,F,4,0.0.8,5,-1,1,1

1071 DATA 71,G.4,1,0,8,5,0,1,1

1072 DATA 72,H.5,-1.0.1.5.0,0,1

1073 DATA 73,1,6.0,1,1.4.1,0,8

1074 DATA 74,J,5,0,0,1,3,0,-1,8

1075 DATA 75,K,6,0,0,1 ,4,0,-1 ,8

1076 DATA 76,L,7.0,0,1,8,0,1,1

1077 DATA 77,M,5,0,-1,1,5,0,-1,1

1078 DATA 78,N.5.-1,-1,1,7,0,0,1

1079 DATA 79,0,7.0,1,1,2,0,0,8

1080 DATA 80,P,8,0,1,1,4,0.1,8

1081 DATA 81,Q,1,0,1,8,2,0,-1,8

1082 DATA 82,R,4,0,1,8,7,0,1,1

1083 DATA 83,S,2,0,0,8,8,0,0,1

1084 DATA 84,T,4,1,1,8,6,0,0,1

1085 DATA 85,U,5,0,1,1,4,0,0,8

1086 DATA 86,V,4,0,-1,8,7,0,-1,1

1087 DATA 87,W,2,0,1,8,6,0,-1,1

1088 DATA 88,X,2,0,-1,8,4,1,-1,8

1089 DATA 89,Y,5,-1.1.1,4,1.1,8

1090 DATA 90.Z,1,0,-1.8,8,0,-1,1

1091 DATA 91,[.8.1,1,0,8,1,2,0

1092 DATA 92.\.8.3.1,0,8.3,1.0

1093 DATA 93.],8.2,1,0,8.2,2,0

1094 DATA 94,*,5,-1,2,1,5,-1,2,1

1095 DATA 95,_,8.1,2.1,8,1,0.1

1096 DATA 96.',1,-2,-2.0,1,-2.-2.0 1123 DATA 999

1200 FOR I - 65 TO 90:AC -1+32 1210 FOR K = 1 TO 2 1220 FI(AC.K) = FI(I,K):SK(AC,K) = 0 1230 X(AC.K) - X(I,K):Y(AC,K) = Y(I,K)

1240 NEXT K: NEXT I

1300 REM KEYBOARD SPACINGS

1310 U - ,75:V = ,81:AN =90+23

1320 DP = U * V * COS (AN * 3.1416 / 180)

1330 FOR I = 0 TO 4: FOR J = 0 TO 6 1340 DX - I - 2:DY - J - 3

1350 DS(I.J) = SQR (DX * DX * U * U + DY * DY * V * V + 2 * DX * DY * 1360 NEXT J: NEXT I: RETURN

DP)

(continued)

BYTE LISTINGS SUPPLEMENT 117

TEXT

"Turbo Pascal 3.0" Mark Bridger. February, page 281

program puzzIe;

(* A compute-bound program from Forest Baskett *)

const

size - 511; classMax ■ 3; typeMax » 12; d »8;

type

pieceClass ■

pieceType

position *

var

pieceCount :

class :

pieceMax :

puzzle :

P :

m,n :

• »j»k :

kount :

function fit (I : label 1; var

0..cIassMax; 0..typeMax; 0 ..sIze;

array array array array array posItIon; 0..13;

pieceClass] of 0..13; pieceType] of pieceClass; pieceType] of position; position] of boolean; pieceType, position] of boolean;

integer;

pieceType; j : position) : boolean;

k: position;

begin fit :« false; for k := 0 to pieceMax[i] do if p[l,k] then If puzzle[J+k] then goto 1; fit :■ true;

Is

end;

function place (l : pieceType; J : position) ; position;

label 1;

var

k: position; begin

for k := 0 to pieceMax[i] do if p[i,k] then puzzle[j+k] := true; pieceCount[class[i]] := pieceCount[cI ass[i]] - 1; for k j to size do If not puzzle[k] then begin place k; goto 1; end;

wr iteln(*PuzzIe filled.*); place :* 0;

1:

end;

procedure remove (i : pieceType; j : position);

var k : position;

begin

for k := 0 to pieceMax[i] do

if p[i,k] then puzzle[j+k] := false; pieceCount[class[i]] :* pieceCount[class[i]] + 1; end;

function trial (j : position) : boolean;

label 1;

var

1 : pieceType; k : position; begin

for i ;« 0 to typeMax do if pieceCount[cIass[i]] <> 0 then If fit (i, j) then begin k ;= pI ace ( I, j); if trial(k) or (k = 0) then begin wr iteIn(*Piece *,I + 1,*at *,k+1); trial := true;

118 BYTE LISTINGS SUPPLEMENT

goto 1;

end eIse remove ( i, j); end;

trial := false;

1 :kount := kount + 1;

end;

beg i n

wr I teIn('BegInning PUZZLE*); for m := 0 to size do puzzle[m] true;

for i :* 1 to 5 do for j :* 1 to 5 do for k ;■ 1 to 5 do

puzzIe[i+d*(j+d*k)] := false;

for i := 0 to typeMax do for m :* 0 to size do p[i,m] := false;

for i := 0 to 3 do for j :■ 0 to 1 do for k := 0 to 0 do

p[0,i+d*(j+d*k)] := true;

class[0] := 0; pieceMax[0] := 3+d*1+d*d*0;

for i := 0 to 1 do for j := 0 to 0 do for k :« 0 to 3 do p[1.I+d*(j+d*k)] :» true;

cIass[ 1 ] :*= 0; pieceMax[1] := 1+d*0+d*d*3;

for i := 0 to 0 do for j := 0 to 3 do for k := 0 to 1 do p[2,i+d*(j+d*k)] := true;

class[2] 0; pieceMax[2] := 0+d*3+d*d*1;

for i ;= 0 to 1 do for j :» 0 to 3 do for k := 0 to 0 do p[3,i+d*(j+d*k)] := true;

class[3] := 0; pieceMax[3] :*= 1+d*3+d*d*0;

for i 0 to 3 do for j :■ 0 to 0 do for k ;*= 0 to 1 do p[4,i+d*(j+d*k)] :* true;

class[4] := 0; pieceMax[4] : = 3+d*0+d*d*1;

for I :« 0 to 0 do for j :■ 0 to 1 do for k :» 0 to 3 do p[5,l+d*(j+d*k)] ;« true;

cIass[5] :*= 0; pieceMax[5] 0+d*1+d*d*3;

for I :« 0 to 2 do for j ;■ 0 to 0 do for k :■ 0 to 0 do p[6,i+d*(j+d*k)] :■ true;

class[6] :« 1; pieceMax[6] :* 2+d*0+d*d*0;

for I :■ 0 to 0 do for j :■ 0 to 2 do for k :* 0 to 0 do p[7,I+d*(j+d*k)] ;« true;

class[7] :* 1; pieceMax[7] :■ 0+d*2+d*d*0;

for i :* 0 to 0 do for j ;■ 0 to 0 do for k :■ 0 to 2 do p[8,i+d*(j+d*k)] :« true;

class[8] :* 1; pieceMax[8] :■ 0+d*«0+d*d*2;

for i :■= 0 to 1 do for j ;■ 0 to 1 do for k :■ 0 to 0 do p[9,i+d*(j+d*k)] :■ true;

class[9] := 2; pieceMax[9] := 1+d*1+d*d*0;

for i :* 0 to 1 do for j :■ 0 to 0 do for k :* 0 to 1 do p[10.i+d*(j+d*k)] :■ true;

c I ass[101 :■ 2; pieceMax[10] :■ 1+d*0+d*d*1;

for 1 ;« 0 to 0 do for j :■ 0 to 1 do for k :* 0 to 1 do p[11.i+d*(j+d*k)] := true;

closs[11] 2;

pieceMax[11] :■ 0+d*1+d*d*1;

for I :« 0 to 1 do for J :■ 0 to 1 do for k :« 0 to 1 do p[12,i+d*(J+d*k)] :* true;

(continued)

BYTE LISTINGS SUPPLEMENT 119

class[12] :* 3; pieceMax[l2]

pieceCount [0 pieceCount 11 pieceCount \2 pleceCount L3_ m :* 1 +d*( 1 +d* 1 ); kount 0 ;

« 1 +d* 1 +d*d* 1 ; - 13;

“ 3;

- 1 ;

- 1 ;

If fIt( 0 ,m) then n :■ place( 0 ,m) else wrIteln('Error.*); If trlal(n) then wrIteIn(’Success In ’,kount,' trials.’) else wrIteln(’Fallure. ' ) ; end.

badfI Ie. c TEXT

Programming Insight: "Badfile: CP/M System Programming In C," Louis Baker. February, page 157.

/* program to identify which file reside on "bad" track&sector */ /* Copyright 1985 Louis Baker all rights reserved */

#include "libc.h"

#define ESC 27 #define CR 13 #define LF 10

#define FF 255 /* code returned by find bdos call if no file */ ^define DFCB 92 /* 92 =« 5CH address of default file control blk */ ^define DMA 128 /* address of DMA */

struct dpb }

char spt[ 2 ];/* low order byte first */ char bsh;

int blmexm,dsm,drm,al,cks; /*not used */ char off[ 2 ];

} /* disk parameter block structure */ ;

struct fcbj

char drive; char fname[ 8 ]; char type[3]; char fex; char sys[ 2 ]; char free; char falg[l 6 ]; char cr; char r 0 ,r 1 ,r 2 ;

\ /* file control block */;

main (argc.argv) /* IDENTIFY FILE CORRESP. TO BAD SECTOR */ int arge;

register Int i;

static int mode,a Ig,track,sector,seept,offset,bIs,Iength,j; static int bad,bIksf,driven,bc,de; int *hI ;

struct feb *fcbp,*fcb2; struct dpb *dpbp; char name[13],byte;

/* CPM version number */

bc=12; de=0 /* unused */; j « bdos(bc,de) ;/* this works */ printf(" CP/M version number %x\n",j);

/* desired drive? */

printf("enter drive (defauIt=0,A=1,B=2,etc) "); scanf(" %d",&driven) /* scanf need pointers */;

/♦input desired mode of search */ printf("enter 0 if track/sector given, 1 if group"); scanf(" %d",&mode);

/* BIOS CALL to select disk if not default */ bc=driven-1;/* be registers for disk selection */

/* SELDSK 9th bios entry hi points to disk parameter

120 BYTE LISTINGS SUPPLEMENT

header */

if(be!=-1) hi = bioshI(9,bc.de); printf(" alloc, group of disk parameter header %x\n",hl); if(mode=* 1 ) { /* read in allocation group */ printf(" enter hex alloc, gp."); scanf("%x",&aIg);

/* use hi* adr of disk parameter header to get dp block */ hi * hi +5; /* 5 words » 10 bytes */

/* hi now points to dpb address */ printf(" address containing dpb address %x\n",hl); dpbp= *hl; /* dpbp* contents of what hi points to */ printf(" loc of dpb %x\n",dpbp);

/♦dpbp points to address in dpb field of dph */

else } v v

pr intf (" enter track(decima !)")*» scant(" %d",&track); printf(" enter sector (decimal)"); scant(" %d",&sector);

/* determine allocation group */

/* another way to locate dp block-BDOS CALL */ be * 31;

dpbp * bdoshI(bc,de) ;/* get dpb address, de unused */

/* now find allocation group */

seept * (dpbp->spt[0]) +256 * (dpbp->spt[1]) ;

printf(" sectors per track %d\n", seept);

offset* (dpbp->off[0])+256*(dpbp->off[1]);

printf(" offset %d\n".offset);

blksf * dpbp->bsh;

/* prIntf(" loc offset %x\n",&(dpbp->off)); */

printf(" block shift factor %d\n",bIksf); a I g *

( (track-offset)*secpt +sector -1 ) »(blksf);

| /* END of else clause */ check */

alloc.gp.- %x\n", alg); /* code working /* now search for that alloc, gp. */ ;

DFCB /* specify file control block

fcbp->drive* driven /* drive name */;

/* set file name,type.extent to wild card for (i* 0 ;i< 8 ;i++)

fcbp->fname[i]* *?’;

fcbp->type[ 0 ]= *?* ;fcbp->type[ 1 ]=’?*;fcbp->type[ 2 ]=*?*; fcbp->fex* •?• /* we don't use strings, which require \0 term. */ ;

/* loop over files max 64 dir. entries in CP/M*/ length * dpbp->drm;

printf(" directory length %d entries\n",Iength); for (bc*17,j=0; j<length;J++,bc*18) { mode * bdos(bc,fcbp);

/* DE*fcbp points to fcb. A*directory code

mode *FF if done else 0 to 3 */

/* echo pr Int f (

f cbp

up to here */ */;

? */

in variabIe if (mode**FF)

goto fini;

fcb2 * mode*32 + DMA ;/* point to found fcb */ /* loop over groups in this extent */ for(i*0;I<16;i++)|

if(fcb 2 ->falg[i]*=alg) goto found;

/* we could put here go if (fcb 2 ->fa Ig[i]*«’\ 0 ’) break;

} /* end of the for loop over extent*/

\ /* end of for loop over directory entries */ fini: prIntf(" no user file at that group\n");

goto term;

found;/* print file name, get size and approx, j-fcb 2 ->fex;

pr Intf(" bad record %d of extent %d\n'\ i + 1 ,j);

/* BDOS call for record count */

bc*35;

fcb 2 ->drive * fcbp->drIve;/* move drive i.d. to

make fcb out of file Info In DMA area */

hi » bdoshI(be,fcb2); /* CP/M to get record count*/

/* call to bdos or CPM equivalent, as answer in fcb */ if ( (fcb2->r2) -- 1 ) length - 65536;

to next file if falg=0 */

position */

[continued)

BYTE LISTINGS SUPPLEMENT 121

else length- ((Int)(fcb2->r0)) + 256*((Int)(fcb2->r1)); prlntf(" bod file: %d records\n",Iength);

/* position of bod sector NB- 1 record can be >1 sector In file */

Iength-(100*(16*j+I))/length;

prlntff" bad record approx %d percent Into fI Ie:\n",Iength); pfIIen(fcb 2 );

term: exit( 0 );/*return to system, job done */

i

pfilen(fcbp) struct fcb *fcbp;

{

struct fcb *fcb2;

static char pname[9],ptype[4];

regIster int I;

fcb2«fcbp;

pname[8]»’\0’;ptype[3]«’\0*;

/* move i no longer needed for position of bad gp. */ for (1-0;l<8;I++) pname[i]- fcb2->fname[i]; for (i-0;I<3;!++) ptypefi]- fcb2->type[i];

/* terminate string name-eIiminate trailing blanks in name */ for (1*7;!>-1;1—)J

I f (pname[ IJ—* * )pname[ I ]-*\0*;

else break; /* do NOT eliminate embedded blanks */

\

/* output file ID */

printf ("%s.%s\n",pname.ptype);

I

Ievien.Ibr BINARY

"Visual Programming," Ralph Levien,

February, page 135. Download lu.exe to unpack this library.

The following files accompany the article, "Visual Programming", by Raph

Levien, which appeared in the Feb. 1986 issue of BYTE, page 135:

SMALLVSD - This version of the visual syntax editor requires an IBM PC

and BYSO LISP, an implementation of LISP available from Levien Instrument Company, POBox 31, McDowell, VA 24459.

XLISPVSD - This version of the visual syntax editor requires an IBM PC and version 1.5d (or later) of XLISP, a public domain implementation of LISP that is available free of charge from BYTEnet Listings and the BYTE Information Exchange (BIX).

XLISP15D.EXE - This Is an executable version of XLISP, with special

modifications that allow it to run XLISPVSD, a version of the visual syntax editor. XLISP and the XLISP version of the visual syntax editor were written by David Betz. (Note that the article incorrectly identifies this version of XLISP as 1.5c.)

FIB - This is the source code for the Fibonacci function described

in the article "Visual Programming", and may be used with either the BYSO LISP or XLISP versions of the visual syntax editor.

GRINDEF - This is the source code for the grindef function described in the article "Visual Programming." XLISP does not include this function, so you must load it (as described below) before you can use it in XLISP.

XLISP15.EXE

Using the Visual Syntax Editor with XLISP 1.5d

To use the visual syntax editor with XLISP 1.5d, enter XLISP by typing XLISP15D

at the MS-DOS prompt. The program will respond

122 BYTE LISTINGS SUPPLEMENT

XLISP version 1.5d, Copyright (c) 1985, by David Betz >

To load the visual syntax editor, type

(load "XLISPVSD")

and the program wiI I respond

; loading "XLISPVSD”

T

From there, you can follow the examples as given in the article, "Visual Programming," except that to load the Fibonacci function, you type

(load "fib")

and to load the grindef function (described on page 138) you type (load "grindef")

Note: there is a typographical error in the article, and the syntax for using grindef to view the definition of a function in the visual editor is

(edv (grindef ’function-name))

Further information on XLISP is available in the March 1984 BYTE article, "An XLISP Tutorial," by David Betz, page 221.

GRINDEF

; (grindef sym) return the function definition associated with a symbol (defun grindef (sym)

(if (and (symbolp sym)

(boundp sym)

(consp (symbol-value sym))

(consp (car (symbol-value sym)))

(consp (cdar (symbol-value sym))))

‘(defun ,sym ,(cadar (symbol-value sym)) ,@(cddar (symbol-value sym))))) (defun cadar (x)

(cadr (car x)))

(defun cddar (x)

(cddr (car x)))

FIB

0 efun fib (x) (if (< x 2) 1 (+ (fib (- x 1))

(fib (- x 2)))))

SMALLVSD

"BYSO Visual Syntax Editor-Limited Version"

"Copyright (C) 1985 Raphael L. Levien"

"For private, non-commercial use only."

(putprop ‘defun *vsd ‘defund)

(putprop ‘quote *vsd ’quoted)

(defsetf in ins)

(defun vsd (I)

(let ((he (gensym)))

(els)

(vsdl (grindef I)

160)

(setc 3360)))

(defun vsdl (I p)

(if (eq he I)

(highlt I p)

(if (consp I)

(if (get (car I)

‘vsd)

(funcaI I (get (car I )

‘vsd)

I

P)

(adj (car I)

P

BYTE LISTINGS SUPPLEMENT 123

(vsd4 (cdr I)

(vsd3 (car I)

(vsd2^p))))

(defun ved2 (I p)

(let* ((8 (expand I))

(si (length s)))

(progl (setc (- p (+ si si))) (pstrlng s)))}

(defun vsd3 (a p)

(let* ((s (expand a))

(si (length s))

(b (- p (+ si si 4))))

(setc b)

(tyo 218)

(for i 1 si 1 (tyo 196))

(tyo 191)

(setc (plus 160 b))

(tyo 179)

(pstrlng s)

i tyo 195) setc (+ b 320)) tyo 192)

for I 1 si 1 (tyo 196))

(tyo 217)

b))

(defun adj (a p h)

(let* ((s (expand a))

(si (length s))

(b (- p (+ si si -316)))

(ds (array 'char (+ si 2))))

(aset 179 ds 0)

(aset 179 ds (+ 1 si))

(for I 1 si 1 (aset 32 ds I))

(setc (for I b (- (max b (car h)) 160)

160

(setc I)

(pstrlng ds)))

(tyo 192)

(for I 1 si 1 (tyo 196))

(tyo 217)

(max b (- (cdr h)

160 ))))

(defun vsd4 (a p)

(do ((I a (cdr I))

(c p))

((null I)

(cons (+ c 160)

, p)) ,

(setc (setq

c (+ p

(if (consp (car 156

-4))))

(tyo 196)

(tyo 26)

(setq p (+ (* 160 (/ (vsdl (car I)

(- P 4))

1 60 ) )

(remainder p 160)

160))))

(defun defund (I p)

(setc 0)

(msg "Function: " (cadr I) t

"VariabIes:")

(if (and (caddr I)

(atom (caddr I)))

(setq I (cdr I)))

(do ((tl (caddr I)

(cdr tl)))

((null tl))

(msg " " (car t!)))

(vsdl (if (cddddr I)

i cons ’proan (cdddr I)) cadddr I))

124 BYTE LISTINGS SUPPLEMENT

(defun quoted (I p) (vsd2 (cadr I)

(+ 160 p)))

(defun highlt (I p)

(let ((II (+ (getc 1)

0 ))

(he (gensym))) (prog2 (setc (getc 2) 1 )

(vsdl I p)

(setc II 1)))) (defun In (x y)

(if (nuI I y)

x

(nth (car y)

(in x (cdr y)))))

(defun ins (z y v)

(if (nuI I y)

(setq x v)

(setf (nth (car y)

(in z (cdr y)))

v)))

(defun edv (x)

(prog (curs com)

(setq x (subst nil nil x) curs

(if (and (consp x)

(eq (car x)

'defun))

(list (if (and (caddr x)

(atom (caddr x)))

4

nil))

(els)

3 ))

i setq cont x) dhlt x)

seta com (tyk)) if (- (low com)

27)

(stoped))

(if (» (high com)

72)

(setf (car curs)

(- (car curs)

D))

(if (« (high com)

75)

(setq curs (cons 1 curs))) (if (■ (high com)

77)

(setq curs (cdr curs)))

(if (« (high com)

80)

(setf (car curs)

(+ (car curs)

D))

(If (■ (low com)

99 )

(cheI))

(if (- (low com)

97)

(addarg))

(if (■ (low com)

105)

(Inal))

(if (- (low com)

100 )

(delei))

(If (* (low com) 116)

(continued)

BYTE LISTINGS SUPPLEMENT 125

(testel))

(go a)))

(defun tyk expr nil (setc (gate))

(car ((bios 22)

, 0))) , V

(defun dhlt (I)

(let ((he (In I curs)))

(vsdl I 160)

(setc 3360)))

(defun chel expr nil (msg "Change to")

(setf (In x curs)

(readel "Change to: "))

.(cls))

(defun readel (m)

(msg " a)tom or f)unctlon? ")

(If (» (low (tyk))

102 )

(progn (msg "function" t m)

(list (read)))

(progn (msg "atom" t m)

, (read))))

(defun addarg expr nil (msg "Add argument")

(setf (edr (lastcdr (In x curs)))

(list (readel "Argument: ")))

(cls))

(defun lastcdr (x)

(cond ((nuI 1 x) nil)

((nu11 (edr x))

x)

(t (lastcdr (edr x)))))

(defun inel expr nil (when curs (msg "Insert")

(setf (nthedr (car curs)

(In x (edr curs)))

(cons (readel "Insert: ")

(nthedr (car curs)

(in x (edr curs)))))

(cls)))

(defun delel expr nil (when curs (setf (nthedr (car curs}

(In x (edr curs))) (nthedr (+ (car curs)

1 )

(in x (edr curs))))

(If (not (nthedr (car curs)

(in x (edr curs))))

(if (« (car curs)

, 1 )

(setq curs (edr curs))

(defun testexp (prog (val)

(setq val (eval (msg "Value: ") (print val)

(msg "Press any

(setf (car curs) (- (car curs) 1 ))))

, v (cls)))

(exp)

exp))

key to return to editor:

))

")

(defun testel expr nil (If curs (progn (msg "w)hole display or highlighted area?

(if (= (low (tyk))

104)

(progn (msg "highlighted area" t)

(testexp (In x curs)))

(progn (msg "whole display" t)

(testexp x))))

(testexp x)))

(defun stoped expr nil (msg "Are you sure you want to exit the editor? ")

(If (* (low (tyk))

121 )

(progn (terprl)

(return x))

(cls)))

(defun ask (m)

126 BYTE LISTINGS SUPPLEMENT

February

(msg m) (read))

XLISPVSD

; BYSO Visual Syntax Editor-Limited Version ; Copyright (C) 1985 Raphael L. Levien ; ALL RIGHTS RESERVED

; Converted for XLISP version 1.5c on the IBM-PC by David Betz

(putprop 'defun 'defund 'vsd)

(putprop 'quote 'quoted 'vsd)

(setq *he* nil)

(defun vsd (I)

(let ((old-he *he*))

(cI ear)

(setq *he* (gensym))

(vsdl I 160)

(setq *he* old-he)

(setc 3360)))

(defun vsd3 (a p)

(let* ((si (fI ate a))

(b (- p (+ si si 4))))

(setc b)

(write-char 218)

(dotimes (i si) (write-char 196)) (write-char 191)

(setc (+ 160 b))

(write-char 179)

(prlnc a)

(write-char 195)

(setc (+ b 320))

(write-char 192)

(dotimes (1 si) (write-char 196))

(write-char 217)

b))

(defun adj (a p h)

(let* ((81 (flate a))

(b (- p (+ si si -316)))

(top (- (max b (car h)) 160))) (setc (do ((i b (+ i 160)))

((> I top) I)

(setc i)

(write-char 179)

(dotimes (i si) (write-char 32)) (write-char 179)))

(write-char 192)

(dotimes (i si) (write-char 196)) (write-char 217)

(max b (- (edr h) 160))))

(defun vsd4 (a p)

(do ((I a (edr I))

(c p))

(defun vsdl (I p)

(If (eq *he* I)

(hlghlt I p)

(If (consp I)

(if (and (symbolp (car I)) (get (car I) 'vsd)) (funcall (get (car I) 'vsd) I p)

(adj (car I)

P

(vsd4 (edr I) (vsd3 (car I) p))))

(vsd2 I p))))

(defun vsd2 (I p)

(progl

(setc (- p (* (flatc I) 2)))

(princ I)))

{continued)

BYTE LISTINGS SUPPLEMENT 127

((null I)

(cons (+ c 160)

P))

(setc (setq c (+ p (If (consp (car I)) 156

-4))))

(write-char 196)

(write-char 26)

(setq p (+ (* 160 (/ (vsdl (car I)

(- P 4))

160))

(rem p 160)

160))))

(defun defund (I p)

(setc 0)

(msg "Function: " (cadr I) t

"Variables:")

( l f (and (nth 2 I)

(atom (nth 2 I)))

(setq I (cdr I)))

(do ((tl (nth 2 I)

(cdr tl)))

((null tl))

(msg " " (car tl)))

(vsdl (If (nthcdr 4 I)

(cons ’progn (nthcdr 3 I))

(nth 3 I))

P))

(defun quoted (I p)

(vsd2 (cadr I)

(+ 160 p)))

(defun highlt (I p)

(let ((old-he *he*))

(let (r)

(set-inverse t)

(setq *he* (gensym))

(setq r (vsdl I p))

(setq *he* old-he)

(set-inverse nil)

r)))

(defun In (x y)

(if (nulI y) x

(nth (car y)

(in x (cdr y)))))

(defun ins (z y v)

(If (nuI I y)

(setq *x* v)

(setf (nth (car y)

(in z (cdr y)))

v)))

(defun edv (x)

(prog (com)

(setq *x* (subst nil nil x)

♦curs*

(if (and (consp *x*)

(eq (car *x*)

* defun))

(list (if (and (n:~ 2 *x*)

(etc- (nth 2 *x*)))

4

3 ))

nil))

(clear)

a

(dhlt *x*)

(setq com (get-key))

(if (= com 27) ; esccre

(stoped))

(if (= com 200) ;

128 BYTE LISTINGS SUPPLEMENT

(if *curs* (setf (car *curs*)

(1- (car *curs*)))))

(progn

(msg "atom" t m)

(if (« com 203) ; left

(read))))

(setq *curs* (cons 1 *curs*)))

(if (= com 205) ; right

(defun addarg ()

(setq *curs* (cdr *curs*)))

(msg "Add argument")

(if (* com 208) ; down

(setf (cdr (last (in *x* *curs*)))

(if *curs* (setf (car *curs*)

(1+ (car *curs*)))))

(list (readel "Argument: ")))

(if (« com 99) ; (c)hange

(c1 ear))

(chel))

(if (« com 97) ; (a)dd

(defun inel ()

(addarg))

(when *curs*

(if (« com 105) ; (i)nsert

(msg "Insert")

(inel))

(setf (cdr (nthcdr (1- (car *curs*))

(if (« com 100) ; (d)elete

(in *x* (cdr *curs*))))

(delei))

(cons (readel "Insert: ")

(if (« com 116) ; (t)est

(nthcdr (car *curs*)

(teste 1))

(in *x* (cdr *curs*)))))

(go a)))

(clear)))

(defun dhlt (1)

(defun delel ()

(let ((old-he *he*))

(setq ♦he* (in 1 *curs*))

(when *curs*

(setf (cdr (nthcdr (1- (car *curs*))

(vsdl 1 160)

(in *x* (cdr *curs*))))

(setq *he* old-he)

(nthcdr (1+ (car *curs*))

(setc 3360)))

(in *x* (cdr *curs*))))

(defun chel ()

(if (not (nthcdr (car *curs*)

(in *x* (cdr *curs*))))

(msg "Change to")

(ins *x* *curs* (readel "Change to: "))

(if (= (car *curs*) 1)

(clear))

(setq *curs* (cdr *curs*))

(setf (car *curs*) (1- (car *curs*)))))

(defun readel (m)

(msg " a)tom or f)unction? ")

(clear)))

(if (« (get-key) 102)

(defun testexp (exp)

(progn

(prog (val)

(msg "function" t m)

(setq val (eval exp))

(list (read)))

(msg "Value: ")

{continued)

Table captionBYTE LISTINGS SUPPLEMENT 129

(print val )

(msg "Press any key to return to editor: ") (get-key)

(clear)))

(defun testel ()

(If *curs*

(progn

(msg "w)ho I e display or highlighted area? ") (If (» (get-key) 104)

(progn

(msg "highlighted area" t)

(testexp (in *x* *curs*)))

(progn

(msg "whole display" t)

(testexp *x*))))

(testexp *x*)))

(defun stoped ()

(msg "Are you sure you want to exit the editor? ")

(if (« (get-key) 121)

(progn (terpr1)

(return *x*))

(clear)))

(defun ask (m)

(msg m)

(read))

; functions required for XLIS?

(defun setc (p)

(set-cursor (/ p 160) (rtr (j : : 36))

P)

(defun msg (&rest args)

(mapcar #’(lambda (x) (if (<*: ■ *. terpri) (princ x))) args))

(expand 1)

far re I I.Ibr BINARY

Programming Insight: "Molecules in Color," John J. Farrell.

February, page 149. Download lu.exe to unpack. For a TEXT file version, down load farreI I.Iib.

The following programs accompany the article "Molecules in Color", which describes C0L0R3D.BAS, a color IBM PC version of M0DEL3D.BAS, a Macintosh program that appeared in the February 1985 BYTE.

C0L0R3D.BAS - the program, which requires an IBM PC or compatible, and BASICA

The following are data files to be used with C0L0R3D.BAS:

B5H9.DAT

B10H14.DAT

C7H702N.DAT

NACL.DAT

CR(C6H6).DAT

CRDIBENZ.DAT

BENZENE.DAT

PATTERNS.DAT - This data file generates the patterns that you may use wit* C0L0R3D.BAS

130 BYTE LISTINGS SUPPLEMENT

farreI I.Iib TEXT

Programming Insight: "Molecules in Color," John J. Farrell. February, page 149. All the programs in one file.

1000 ' ********* COLOR3D.BAS *********

1010 ’ Draws a 3D, perspective image of o molecule on IBM PCs with BASICA. 1020 ’ For private, noncommercial use only.

1030 * John J. Farrell *** April 1, 1985

1040 ’ Inspired by Earl Kirkland’s M0DEL3D.BAS for the Mac, BYTE, Feb. 1985. 1050 SCREEN 1 'medium resolution; color

1060 COLOR 0,1 'background = black(0); cyan(1); magenta(2); white(3)

1070 KEY OFF

1080 DEFINT I-N: DEFSNG 0-Z: DEFSNG A-G

1090 DIM X(200), Y(200), Z(200), S(200), COL(200),COLPAT(200),TIL$(200)

1100 '

1110 ' Ask for input parameters.

1120 CLS: INPUT "Data file nome:", FILE$

1130 INPUT "Azim., polar angles (phi, theta):", PHI, THETA 1140 INPUT "Viewing distance:".VIEWD 1150 INPUT "Size magnitude:“,SMAG 1160 SMAG = 1.15*SMAG

1170 ’ DISTORT is used later to account for fact that one unit of x 1180 ’ on screen (horizonal) is not equal to one unit of z (vertical).

1190 DISTORT =1.2

1200 ’ Convert degrees to radians.

1210 PHI = PHI*3.14159/180!: THETA = THETA*3.14159/180!

1220 CP = COS(PHI): SP = SIN(PHI): CT = COS(THETA): ST = SIN(THETA)

1230 '

1240 OPEN FILE$ FOR INPUT AS #1

1250 ' Set xmin very large and xmax very small.

1260 XMIN = 1000000!: XMAX = -XMIN: YMIN = XMIN: YMAX = XMAX 1270 ZMIN = XMIN: ZMAX = XMAX: N = 0

1280 ' Read data file: color, x.y.z (atomic coords),r (Angstroms).

1290 WHILE NOT E0F(1)

1300 N = N + 1

1310 INPUT #1.COLPAT(N), X(N),Y(N), Z(N), S(N)

1320 IF COLPAT(N)<= 3 THEN COL(N) = COLPAT(N): TIL$(N) = CHR$(4HAA)

1330 IF COLPAT(N) = 4 THEN COL(N) = 1: TIL$(N) =CHR$(4H66) + CHR$(4H99)

1340 IF COLPAT(N) = 5 THEN COL(N) = 3: TIL$(N) = CHR$(4HAF) +CHR$(&HAF) +

CHR$(4HFA) + CHR$(4HFA)

1350 IF COLPAT(N) = 6 THEN COL(N) = 2: TIL$(N) =CHR$(4H55) + CHR$(4HFF)

1360 IF COLPAT(N) = 7 THEN COL(N) = 3: TIL$(N) = CHR$(4HAA) + CHR$(4H69) +

CHR$(4HFF) + CHR$(4H5A) + CHR$(4HA5) + CHR$(4HFF) + CHR$(4H96) + CHR$(4HAA) 1370 IF COLPAT(N) = 8 THEN COL(N) = 3: TIL$(N) = CHR$(4H5A) + CHR$(4H5A) + CHR$(4HA5) + CHR$(4HA5)

1380 IF COLPAT(N) = 9 THEN COL(N) = 3: TIL$(N) = CHR$(4HAA) + CHR$(4HAA) + CHR$(4H55) + CHR$(4H55)

1390 IF COLPAT(N) = 10 THEN COL(N) = 3: TIL$(N) = CHR$(4HAA) + CHR$(4HFF)

1400 IF COLPAT(N) = 11 THEN COL(N) = 3: TIL$(N) = CHR$(4H5F) + CHR$(4H5F) +

CHR$(4HF5) + CHR$(4HF5)

1410 IF COLPAT(N) = 12 THEN COL(N) = 3: TIL$(N) = CHR$(4H69) + CHR$(4HAA) + CHR$(4HAA) + CHR$(4H96)

1420 IF COLPAT(N) = 13 THEN COL(N) = 3: TIL$(N) = CHR$(4HBB)

1430 IF COLPAT(N) = 14 THEN COL(N) = 3: TIL$(N) = CHR$(4HAB)

1440 IF COLPAT(N) = 15 THEN COL(N) = 3: TIL$(N) = CHR$(4H57)

1450 IF COLPAT(N) = 16 THEN COL(N) = 3: TIL$(N) = CHR$(4HAB) + CHR$(4HAB) +

CHR$(4HFF) + CHR$(4HFF)

1460 IF COLPAT(N) = 17 THEN COL(N) = 3: TIL$(N) = CHR$(4H57) + CHR$(4H57) + CHR$(4HFF) + CHR$(4HFF)

1470 IF COLPAT(N) = 18 THEN COL(N) = 3: TIL$(N) = CHR$(4HFE) + CHR$(4HFA) + CHR$(4HFA) + CHR$(4HEA) + CHR$(4HFA) + CHR$(4HFE)

1480 IF COLPAT(N) = 19 THEN COL(N) = 3: TIL$(N) = CHR$(4HEB) + CHR$(4HAA) + CHR$(4HAA) + CHR$(4HEB)

1490 IF COLPAT(N) = 20 THEN COL(N) = 3: TIL$(N) = CHR$(4H77)

1500 IF COLPAT(N) = 21 THEN COL(N) = 3: TIL$(N) = CHR$(4H69) + CHR$(4HAA) +

CHR$(4HAA) + CHR$(4H69)

1510 IF COLPAT(N) = 22 THEN COL(N) = 3: TIL$(N) = CHR$(4HAA) + CHR$(4HBE) + CHR$(4HBE) + CHR$(4HBE) + CHR$(4HBE) + CHR$(4HAA)

1520 IF COLPAT(N) = 23 THEN COL(N) = 3: TIL$(N) * CHR$(4HE9) + CHR$(4H9E)

1530 IF COLPAT(N) = 24 THEN COL(N) = 3: TIL$(N) = CHR$(4HE9) + CHR$(4HE9)

1540 ’ Find maximum and minimum values for x,y,z.

(continued)

BYTE LISTINGS SUPPLEMENT 131

1550 IF X(N) > XMAX THEN XMAX - X(N)

1560 IF X(N) < XMIN THEN XMIN - X(N)

1570 IF Y(N) > YMAX THEN YMAX - Y(N)

1580 IF Y(N) < YMIN THEN YMIN - Y(N)

1590 IF Z(N) > ZMAX THEN ZMAX - Z(N)

1600 IF Z(N) < ZMIN THEN ZMIN - Z(N)

1610 WEND

1620 PRINT N "otoms"

1630 PRINT "rotating..."

1640 ’ Find center values for x,y,z.

1650 XCEN = .5*(XMAX-fXMIN): YCEN - ,5*(YMIN + YMAX): ZCEN - .5*(ZMIN+ZMAX) 1660 * Rotate molecule around its center.

1670 FOR I = 1 TO N

1680 XA = X(I) - XCEN: YA = Y(I) - YCEN 1690 X(I) - CP*XA+SP*YA: Y(I) » -SP*XA+CP*YA 1700 YA » Y(I): ZA - Z(I) - ZCEN 1710 Y(I) = CT*YA+ST*ZA: Z(I) = -ST*YA+CT*ZA

1715 IF VIEWD < Y(I) THEN CLS: PRINT "Viewing distance is within molecule Rerun with a larger viewing distonce.": GOTO 2100 1720 NEXT I: PRINT "sorting..."

1730 *

1740 ' Sort by depth (shell sort). 1750 IGAP - INT(CSNG(N)/2!)

1760 WHILE IGAP >« 1

1770 FOR I = IGAP +1 TO N

1780 FOR J - I-IGAP TO 1 STEP -IGAP

1790 JG « J + IGAP

1800 IF Y(J) <- Y(JG) THEN GOTO 1850

1810 SWAP 1820 SWAP

8 ):'

INT(CSNG(IGAP)/2!)

Z(I) * YA: S(I) = S(I)»YA

X(JG): SWAP Y(J), Y(JG)

. . Z(JG): SWAP S(J). S(JG)

1830 SWAP COL(J), COL(JG): SWAP COLPAT(J), COLPAT(JG): SWAP TIL$(J),TIL$(JG 1840 NEXT J ' ' v

1850 NEXT I 1860 IGAP 1870 WEND 1880 *

1890 CLS

1900 * Perspective projection and scale coordinates.

1910 SCALE = -1000000!: SMAX = SCALE 1920 FOR I - 1 TO N

1930 YA - 1!/(VIEWD - Y(I)): X(I) - X(I) *YA: Z(I) =

1940 IF SCALE < ABS(X(I)) THEN SCALE = ABS(X(I))

1950 IF SCALE < ABS(Z(I)) THEN SCALE - ABS(Z(I))

1960 IF SMAX <S(I) THEN SMAX = S(I)

1970 NEXT I: SCALE - 75!/(SCALE + .5+SMAX+SMAG)

1980 SCALEX = SCALE*DISTORT 1990 ’

2000 FOR I = 1 TO N

2010 * Find screen x (ix) and screen 2 (iz) and screen radius (ir).

2020 ' Center of screen is x - 160 and 2 «* 100

2030 IX = INTfxm*SCALEX+ 160 !): IZ - INT(Z(I)*SCALE + 100 !)

2040 IR = INT(s(I)*SCALE*SMAG): IRZ - IR/DISTORT 2050 COL = COL(I): COLPAT = COLPAT(I): TIL$ = TIL$(I)

2060 GOSUB 2130 2070 NEXT I 2080 CLOSE#1

2090 IF INKEY$ = "" THEN 2090 2100 END

2110 ’ Draw patterned circles at ix,i 2 with radius ir.

2120 ’ Draw a circle in color.

2130 CIRCLE (IX.IZ),IR+1.C0L

2140 ’ Paint the circle black. Start in center and at four extremities 2150 ’in an attempt to completely blacken the circle.

2160 PAINT (IX.IZ) 0.COL: PAINT (IX-IR+1.IZ).0.COL: PAINT (IX+IR-1,IZ),0.CO. PAINT (IX,IZ-IRZ+1),0,COL: PAINT (IX,IZ+IRZ-1).0.COL 2170 * Paint the circle in color.

2 ]80 PAINT (IX.IZ),COL COL: PAINT (IX-IR+1.IZ).COL,COL: PAINT (IX+IR

-1,IZ),COL,COL: PAINT (IX,IZ-IRZ+1),COL,COL: PAINT (IX,IZ+IRZ-1),COL,COL

2190 ’ Draw circle with a new border color and paint black

2200 IF COL » 1 THEN COLBOR = 3

2210 IF COL = 2 THEN COLBOR - 3

2220 IF COL = 3 THEN COLBOR - 1

2230 CIRCLE (IX,IZ).IR+1.COLBOR

2240 PAINT (IX,IZ),0,COLBOR

2250 ’ Paint circle with final pattern.

2260 IF COLPAT <=3 THEN PAINT (IX, IZ) .COL .COLBOR ELSE PAINT

132 BYTE LISTINGS SUPPLEMENT

(IX,IZ),TIL$,COLBOR

2270 ’ Drow the circle in block ond point it block.

2280 CIRCLE (IX,IZ),IR+1,0

2290 PAINT (IX,IZ),0,0: PAINT (IX-IR+1,IZ),0,0: PAINT (IX+IR-1,IZ),0,0: PAINT (IX,IZ-IRZ+1),0,0: PAINT (IX,IZ+IRZ-1),0,0

2300 ’ Drow the circle in color ond point with finol pattern.

2310 CIRCLE (IX,IZ).IR+1.COLBOR

2320 IF COLPAT <=3 THEN PAINT (IX.IZ),COL,COLBOR ELSE PAINT

(IX,IZ),TIL$,COLBOR

2330 * Draw the circle in black.

2340 CIRCLE (IX,IZ),IR+1.0 2350 RETURN

b5h9.dat

TEXT

Programming Insight: "Molecules in Color," John J

. Far re 11.

February, page 149. This data file must be used with colored.bas

5.0,0,1.08676,.83

3,-2.34848,0,.49496,.37

5,3.58,3.58,3.77676,.83

3,1.23152.3.58,3.18496,.37

3,0,0,2.29726,.37

3,0,2.34848,.49496,.37

3,3.58,3.58,4.98726..37

3.3.58,5.92848.3.18496..37

5,1.253,0,0,.83

3,0,-2.34848,.49496,.37

5,4.833.3.58,2.69,.83

3,3.58.1.23152,3.18496,.37

5,-1.253,0.0,.83

3,.97376,.97376,-.8877001,.37

5.2.327,3.58,2.69,.83

3,4.55376,4.55376.1.8023,.37

5,0,1.253,0,.83

3,.97376,-.97376,-.8877001,.37

5,3.58,4.833.2.69,.83

3.4.55376.2.60624,1.8023,.37

5.0.-1.253,0,.83

3.-.97376,.97376,-.8877001..37

5.3.58,2.327,2.69,.83

3,2.60624,4.55376.1.8023,.37

3,2.34848,0,.49496,.37

3,-.97376,-.97376,-.8877001,.37

3,5.92848,3.58.3.18496,,37

3,2.60624,2.60624,1.8023,.37

b10h14.dat

5,.48858.6.9234,0.-88

3.2.80215,6.12616.-1.2518,.38

5.1.437,5.72754,.95592..88

3,2.48601,3.44072,0,.38

5,1.66692,5.83244.-.74539,.88

3,.44547,3.65052,2.20772,.38

5,1.39389,4.23796.0,.88

3,.70413,6.69262.-1.35991..38

5,.25866,4.42678.1.35991,.88

3,1.22145.4.42678,-1.21766,.38

5,-.48858,3.5666,0,.88

3.-.58917,2.34976.0..38

5,-1.437,4.76246,.95592,.88

3.-2.35668,4.69952,1.8208,.38

5,-1.66692,4.65756,-.74539..88

3.-2.80215.4.36384.-1.2518,.38

5,-1.39389,6.25204,0,.88

3,-2.48601.7.04928,0,.38

5,-.25866,6.06322,1.35991,.88

3,-.44547,6.83948,2.20772,.38

3,.58917,8.14024,0,.38

3,-.70413,3.79738,-1.35991,.38

3.2.35668,5.79048,1.8208,.38

3,-1.22145,6.06322.-1.21766,.38

patterns.dat

TEXT

Programming Insight: "Molecules in Color," John J. Farrell.

February, page 149. This data file must be used with color3d.bas

i.e,0,0,1 2,3,0,0,1 3,6,0,0,1 4.9,0,0,1 5.12.0.0,1 6.15,0,0,1 7.0.0,3.1 8,3,0,3,1

9.6,0,3,1

10,9,0,3,1

11.12.0.3,1

12,15,0,3,1

13,0,0,6.1

14.3,0.6,1

15,6,0,6,1

{continued)

BYTE LISTINGS SUPPLEMENT I3J

16,9.0,6,1

17,12,0,6,1

18,15,0,6,1

19,0,0.9.1

20.3,0,9,1

21,6,0,9,1

22.9.0,9,1

23.12,0,9,1

24,15,0,9,1

c7h702n.dot TEXT

Programming Insight: "Molecules In Color," John J. Farrell. February, page 149. This dota file must be used with color3d.bas

4,6.612408.1.960494,-3.099765..778 1.2.942464,1.054938,-1.322889,.699

1.4.150042.. 732628,-.6921442,.699 1,5.349948,1.056868,-1.255907,.699 1,5.402778,1.690294,-2.49879,.699 1,4.201226,2.029588,-3.136977..699 1,2.998429.1.706892.-2.556469..699

1.1.676018.. 648866,-.7330775,.699

2.1.585782.. 034354..3349085..514

2.. 5988608..9981959,-1.402595..5* 3.-.1059083,.5211,-.9861195.-3J»

3.4.142753.. 2509..2046663..5 78

3.6.172514.. 91868,-.8186653,-37®

3,7.395005,1.86824,-2.5861:: 5*3

3,6.647874,2.61708,-3“

3,4.238428,2.57076,-4.?:': C :

3,2.154166,1.8914,-3.032753 3*5

cr(c6h6).dat

TEXT

Programming Insight: "Molecules in Color," John J. Farrell. February, page 149. This data file must be used with color3d.bas

8,0,0,0.1.5 8,0,4.835,4.835,1.5 8,4.835,0,4.835,1.5 8,4.835,4.835,0,1.5

1.1.413754.1.599418, -.1934,.7

1.-1.413754,-1.599418,.1934,.7

1.6.248754.3.235582.. 1934..7

1.3.421246.6.434418, -.1934,.7

1.4.6416.3.421246, -1.599418,.7 1,5.0284,6.248754,1.599418,.7 1,6.434418,5.0284,-1.413754,.7

1.3.235582.4.6416.1.413754.. 7

1.1.599418, -.1934,1.413754,.7

1,-1.599418,.1934,-1.413754..7

1.3.235582.. 1934.6.248754..7

1.6.434418, -.1934,3.421246,.7

1.3.421246. -1.599418,4.6416..7 1.6.248754,1.599418,5.0284,.7 1,5.0284,-1.413754,6.434418,.7

1.4.6416.1.413754.3.235582.. 7 1.-.1934,1.413754,1.599418,.7

1.. 1934,-1.413754,-1.599418,.7

1.. 1934.6.248754.3.235582..7

1.-.1934,3.421246,6.434418,.7 1,-1.599418,4.6416,3.421246,.7 1,1.599418.5.0284,6.248754,.7 1,-1.413754,6.434418,5.0284..7

1.1.413754.3.235582.4.6416.. 7

1.. 476731..23208.2.065512..7

1,-.476731,-.23208,-2.065512,.7

1.5.311732.4.60292, -2.065512,.7 1,4.358269,5.06708.2.065512..7

1.6.900512.4.358269, -.23208,.7

1.2.769488.5.311732.. 23208..7 1.5.06708,2.769488,-.476731,.7

1.4.60292.6.900512.. 476731..7

1.. 23208.2.065512..476731..7

1.-.23208,-2.065512,-.476731,.7

1.4.60292, -2.065512,5.311732,.7 1,5.06708.2.065512.4.358269,.7

1.4.358269, -.23208,6.900512,.7

1.5.311732.. 23208.2.769488..7

1,2.769488,-.476731,5.05'?: *

1.6.900512.. 476731.4.6:

1.2.065512,.476731,.23205 '

1.-2.065512,-.476731,-.2::?:..' 1,-2.065512,5.311732,4.6?;?: '

1.2.065512,4.358269,5.eS'?: *

1,-.23208,6.900512,4.358:-:? 7

1.. 23208.2.769488.5.3117:: '

1,-.476731,5.06708,2.769*:: '

1.. 476731.4.60292.6.90051:

3.1.63423.2.2241, -1.10235 37

3.-1.63423,-2.2241,1.102:: 3*

3.6.46923,2.6109,1.10233 3*

3.3.20077,7.0591,-1.1023: ,J7

3.3.73262.3.20077, -2.224- 3*

3,5.937381,6.46923,2.224-..I* 3,7.0591.5.937381,-1.634;: 3*

3,2.6109,3.73262.1.63423 3*

3.2.2241, -1.10238,1.63423 .37

3.-2.2241.1.10238,-1.634;: 3*

3,2.6109,1.10238,6.46923 3'

3,7.0591,-1.10238,3.200*' 3*

3.3.20077, -2.2241,3.73262 ..ST

3,6.46923,2.2241,5.93735- .3* 3,5.937381,-1.63423,7.03?' 3*

3,3.73262,1.63423,2.6105. 3* 3,-1.10238,1.63423,2.224- .3'

3,1.10238,-1.63423,-2.22- 1 - r~ 3,1.10238,6.46923,2.6105 3*

3,-1.10238,3.20077,7.05:-- 3'

3.-2.2241,3.73262.3.200'* 3*

3,2.2241,5.937381.6.465:3 3*

3,-1.63423,7.0591,5.9373W.-» 3.1.63423.2.6109.3.7325: J*

3.. 13538,-.36746,2.92034..3* 3,-.13538,.36746,-2.9203 *.S 3,4.97038,5.20246,-2.:-:::3,4.69962,4.467541 ,2.92834.

3.7.75534.4.69962.. 36745 3'

3,1.91466,4.97038,-.36746..3*

3,4.467541,1.91466,-.1353: 3~

134 BYTE LISTINGS SUPPLEMENT

3.5.20246.7.75534.. 13538..37 3,-.36746,2.92034,.13538,.37

3.. 36746,-2.92034,-.13538,.37 3,5.20246,-2.92034,4.97038,.37

3.4.467541.2.92034.4.69962.. 37

3.4.69962.. 36746.7.75534..37 3,4.97038,-.36746,1.91466,.37 3,1.91466,-.13538,4.467541,.37

3.7.75534.. 13538.5.20246..37

3.2.92034.. 13538,-.36746,.37 3,-2.92034,-.13538,.36746,.37 3,-2.92034,4.97038,5.20246,.37

3.2.92034.4.69962.4.467541.. 37

3.. 36746.7.75534.4.69962..37 3,-.36746,1.91466,4.97038,.37 3,-.13538,4.467541,1.91466,.37

3.. 13538.5.20246.7.75534..37

benzene.dot TEXT

Programming Insight: "Molecules in Color," John J. Farrell. February, page 149. This data file must be used with color3d.bas

1,-.424474,1.340674,-.0364068,.699

1.. 424474,-1.340674,.0364068,.699 1,-.99591,.444636,.8521888,.699

1, .99591,-.444636,-.8521888,.699 1,-.577404,-.894105,.873089,.699

1.. 577404..894105,-.873089,.699

3,-.728096,2.36527,-.1193334,.378

3,.728096,-2.36527,.1193334,.378 3,-1.797114,.7674805,1.495376,.378 3,1.797114,-.7674805,-1.495376,.378 3,-1.022766,-1.576525,1.55875,.378 3,1.022766,1.576525,-1.55875,.378

crdibenz.dat TEXT

Programming Insight: "Molecules in Color," John J. Farrell. February, page 149. This data file must be used with color3d.bas

8 , 0 , 0 , 0 . 1.5

1.1.413754.1.599418, -.1934,.7

1,-1.413754,-1.599418,.1934,.7

1.1.599418, -.1934,1.413754,.7

1,-1.599418,.1934,-1.413754,.7 1,-.1934,1.413754,1.599418,.7 1, .1934,-1.413754,-1.599418,.7

1.. 476731..23208.2.065512..7

1,-.476731,-.23208,-2.065512,.7

1.. 23208.2.065512..476731..7

1,-.23208,-2.065512,-.476731,.7 1,2.065512,.476731,.23208,.7 1,-2.065512,-.476731,-.23208,.7

3.1.63423.2.2241, -1.10238,.37 3,-1.63423,-2.2241,1.10238,.37

3.2.2241, -1.10238,1.63423,.37 3,-2.2241, 1.10238,-1.63423,.37 3,-1.10238,1.63423,2.2241,.37 3,1.10238,-1.63423,-2.2241,.37

3.. 13538,-.36746,2.92034,.37 3,-.13538,.36746,-2.92034,.37 3,-.36746,2.92034,.13538,.37

3.. 36746,-2.92034,-.13538,.37

3.2.92034.. 13538,-.36746,.37 3,-2.92034,-.13538,.36746,.37

nacI.dat TEXT

Programming Insight: "Molecules in Color," John J. Farrell. February, page 149. This data file must be used with color3d.bas

7,0,0,0,.95 7,5.628,0,0,.95 7,0,0,5.628,.95 7,5.628,0,5.628,.95

7.5.628.2.814.2.814.. 95

7.2.814.2.814.5.628.. 95 7,2.814,2.814,0,.95 7,2.814,0,2.814,.95 7,0,2.814,2.814,.95 7,0.5.628,0,.95 7,5.628,5.628,0,.95 7,0,5.628,5.628,.95

7.5.628.5.628.5.628.. 95

7.2.814.5.628.2.814.. 95

6.2.814.2.814.2.814.1.81 6,2.814,0,0,1.81 6,0,2.814,0,1.81 6,0,0,2.814,1.81 6,5.628,0,2.814,1.81 6,2.814,0,5.628,1.81 6,0,2.814,5.628,1.81

6.5.628.2.814.5.628.1.81 6,5.628,2.814,0,1.81 6,0,5.628,2.814,1.81 6,2.814,5.628,0.1.81

6.2.814.5.628.5.628.1.81

6.5.628.5.628.2.814.1.81

{continued)

BYTE LISTINGS SUPPLEMENT 135

datagen.bas

TEXT

Programming Insight: February, page 149.

"Molecules in Color." John J. Farrell.

100 * Program to generate a data file for Cr(C6H6)(C0)3.

105 ’ Page 5 of Vol 6 of Crystal Structures by Wyckoff.

107 * Unit cell is monoclinic.

110 INPUT “Output file name:";

FILE$

120 OPEN FILES FOR OUTPUT AS #1 130 SIZ-1.4 : COL * 8 140 A - 6.17 : B = 11.07 : C « 6.57 : BETA - 101.5

150 X = .3319 : Y=.25 : 2 « .0225

160 GOSUB 1000

200 SI2= .7 : COL * 1

'ring carbons

210 X = .1804 220 GOSUB 2000 230 X = .3761 240 GOSUB 2000 250 X = .5738 260 GOSUB 2000 270 SIZ- .64 280 X = .5538 290 GOSUB 1000 300 X - .1827 310 GOSUB 2000 320 SIZ- .49: COL

Y-.3119 : 2 —.2973 Y-.3769 : 2 —.2273

Y-.3142 :

’carbonyl Y-.25 : 2

-.1598

carbons

-+.2557

Y-.3642 : 2 -+.1453

’carbonyl oxygens

*»Z

Z —_22*c

330 X « .6899 : Y=.25 :

340 GOSUB 1000 350 X = .0894 : Y-.4341 360 GOSUB 2000 400 SI2= .38: COL = 3 410 X * .028 : Y-.361 : Z —

420 GOSUB 2000

430 X = .376 : Y-.474 : Z —

440 GOSUB 2000

450 X = .728 : Y-.363 : Z — -*7

460 GOSUB 2000

999 GOTO 5000

1000 WRITE #1, COL.

(X - Z*SIN

((BETA - 90)*3.14159/1M)} *A,Y*B,(2*C0S((BE”A 90)*3.14159/186) )«C .SIZ 1020 RETURN

2000 WRITE #1, COL. (X - Z-S>

((BETA - 90)*3.1415S/:»>) *A.Y*B.(2*C0S((BET* 90)*3.14159/180))«C„SIZ 2020 WRITE #1, COL. (X - 2.=:% ((BETA - 90)*3.1415S X" *A,(.5-Y)*B,(Z*CC$;.'3E^a 90)*3.14159/’ ■«; ,< 52

2040 RETURN 5000 CLOSE #1: END

TEXT

"Keyboard Efficiency.” See dvorak.bos for details.

R™wV ntere - lin ®- b y- |in «- A line is entered by the RETURN key or is automatically accepted if the cursor reaches column 39; warning beeps are sounded past column 31 After a line is entered, it is retyped by the computer as it uo wlth y +h?'i S? ,tinfl is Possible within a line by backing it eiiSJ L H-7 a 7r ?u d r * t yp in 9- 0nc « o line is analysed of uonftr nnH ? d,ted further. We suggest typing with full use of upper and lower case. However, the program wiI I run correctly if the CAPS LOCK is locked down for the entire

Ih fted\o ha - ? aSe 'J! W, i‘ Infer use of the shift key for shifted special symbols, but not for capital letters.

TO UNDERSTAND THE LISTING:

}«f+ f +« 9e ^ S h+ e *?u Ud ! n ? the thumbs) are numbered 1 to 8 from left to right. The label K refers to Qwerty (K = 11 or Dvorak (K = 2). The variables CX(F.K) and CY(F,K) are the current column and row locations of finger F in keyboard K

' r lncr ? mented by an amount from a

DSfl ncf?'^ anCeS ’ ' n actual inches - called

kovhonrH Th DS t I,d ) ar e computed by approximating the keyboard as a grouping of parallelograms with sides 0.75" (honzonta! key spacing) and 0.81" (measured along a diagonal from the upper left to the lower right, tilted approximately 23 degrees from the vertical). Like the Qwertv arZ ^ <? Qr ?' I* 1 P°ttern dates fr^tX*^

to f T ech ?"' cal typewriters when it was necessary

somniA nA^ 7- f0r r th ® connect ing levers beneath the keysA sample DATA line (e.g.. 1066 DATA 66.B.4.1,-1.8.5,-1 -1 1) is interpreted as follows. ASCII code 66 is a capital B. In Qwerty, it Is typed by finger 4, moved one column to the

136 BYTE LISTINGS SUPPLEMENT

right and one row down relative to the home position; also, if CAPS LOCK is off, finger 8 (the little finger on the right hand) must reach down for the SHIFT key. In the Dvorak layout, B is typed by finger 5, one column to the left and one row down from the home position; if CAPS LOCK is off, finger 1 must strike the SHIFT key. Characters with ASCII codes above 122 or below 32 (mainly control characters) are ignored, except for left-arrow (ASCII 8), RETURN (ASCII 13), and ESCAPE (ASCII 27).

simpl3.bix

TEXT

Programming Project: "A Simpl Compiler Part 3: Extensions," by Jonathan Amsterdam. February, page 102. Also download readsim3.me.

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

Note 8

Note 9

Note 10

Note 11

Note 12

Note 13

Note 14

Note 15

Note 16

Note 17

Note 18

Note 19

Note 20

Note 21

Note 22

Note 23

Note 24

Note 25

Note 26

Note 27

Note 28

Note 29

Note 30

Note 31

Note 32

IMPORT Symbol; FROM Symbol Table FROM StrIngStuff FROM TypeChecker

IMPORT tStrlng, lowFunc, IMPORT stringLen;

IMPORT baseType;

highFunc,

t Integer,

tChar,

tBoo I e:*»

(*** label generation ***)

(* The code generator needs o supply of unique label names. *)

MODULE Labe I Generator;

EXPORT newLabeI, label;

TYPE label = CARDINAL;

VAR labelCount:CARDINAL;

PROCEDURE newLabeI():Iabe I •

BEGIN

INC(IabeICount);

RETURN IabeI(IabeI Count);

END newLabeI;

BEGIN

labelCount :* 0;

END LabeIGenerator;

PROCEDURE genBlock(nrnode);

(* This Is the Interface to generating statements. We doing generation If there has been an error. Also prr^K, Utlne t0 96t ° n empty node Orally); In that case

don ’ t waste our t we 11 * s possIbIe for * * : , we do nothing.

IF (NOT errorFlag) AND (NOT nodeEmpty(n)) THEN IF nodeCIass(n) <> nLlst THEN

ELSE MyTerminal - fata l(’genBlock: node class must be nLlst*);

genStmts(n) freeNode(n)

END;

END;

END genBlock;

PROCEDURE genGIobaI(s:symboI);

( * ?n t FA. t <;F h ? K 9 !°K b °! Sy T b0 ' ° S °s lQbel - Initial ize integers to 0. boolec-s to FALSE (which is also zero), chars to NUL (which is again zero)

VAR nameistringType; ^ ° rr ° yS ' j ° St WMte ° • BL0CI< - N ° ^itia Iizatio-.

sIze:CARDINAL;

BEGIN

IF NOT errorFlag THEN

IF Symbol.class(s) = Global THEN Symbol.string(s, name); size := SymboI.size(SymboI.type(s)) ; wr I teStrIngLabeI(name);

IF size = 1 THEN

WriteSt ring(" 0");

ELSE ^ '

WriteString( M .BLOCK "); WrIteCard(size, 0);

END;

Wr i teLn;

ELSE

MyTerm i na I . Wr i teSt r i ng("genG I oba I : not a global* "V fatal(name); ^

END;

END;

END genGIobaI;

PROCEDURE genLocaIs(routine:symboI); (* save space for locals on stack *) VAR n:CARDINAL;

BEGIN

n := sizeLocaIs(routine);

IF n <> 0 THEN

writeSetSP(INTEGER(n));

138 BYTE LISTINGS SUPPLEMENT

END genLocals;

PROCEDURE sizeLocaIs(routine:symboI):CARDINAL;

VAR I oca Is:symboIList;

sum:CARDINAL;

BEGIN

locals := SymboI.locaIs(routine); sum := 0;

WHILE NOT slEmpty(locals) DO

INC(sum, SymboI.size(SymboI.type(sISymboI(I oca Is)))); locals :* sINext(locals);

END;

RETURN sum;

END si zeLocaIs;

PROCEDURE genStmts(n:node);

(* Generate a list of statements, If the node isn't empty. *) BEGIN

IF NOT nodeEmpty(n) THEN genStmt(nodeFirst(n)); genStmts(nodeRest(n));

END;

END genStmts;

(*** Statements ***)

PROCEDURE genStmt(mnode);

BEGIN

CASE nodeClass(n) OF nlf: genlfStmt(n); nWhile: genWhiIeStmt(n); nAssignment: genAssignStmt(n); nCall: genCaI I Stmt(n); nWrite: genWriteStmt(n); nRead: genReadStmt(n); nReturn: genReturnStmt(n);

ELSE

MyTermlnaI.fata I("genStmt: unknown statement type");

END;

END genStmt;

PROCEDURE genIfStmt(ninode);

VAR labell, IabeI 2:IabeI;

BEGIN

labell :■ newLabelQ; genExpr(nodeTest(n)) ; writeCondBranch(EquaI, labell); genBlock(nodeThen(n));

IF nodeEmpty(nodeEIse(n)) THEN writeLabeI(IabeII);

ELSE

I abe12 :* newLabeI(); wr i teBranch(Iabe12); wr i teLabeI(IabeII); genBlock(nodeEIse(n)); writeLabeI(IabeI 2);

END;

END genlfStmt;

PROCEDURE genWhiIeStmt(ninode);

VAR testLabel, endLabeI;IabeI;

BEGIN

testLabel :« newLabel(); endLabel :« newLabel(); wr IteLabeI(testLabe I); genExpr(nodeTest(n)); writeCondBranch(EquaI, endLabeI); genBlock(nodeStmts(n)); wr1teBranch(testLabe I); wr iteLabeI(endLabeI);

END genWhiIeStmt;

PROCEDURE genAssignStmt(ninode);

BEGIN

(continued]

(* generate test *)

(* branch to else part if test false *) (* generate then part *)

(* no else part *)

* branch around els part *)

* label for else part *)

* generate else part *)

* final label *)

(* label for top of loop *)

(* generate test *)

(* if false, branch to end of loop *) (* generate loop body *)

(* branch back to test *)

(* end label *)

BYTE LISTINGS SUPPLEMENT 139

IF Symbol.class(baseType(nodeType(nodeLHS(n)))) ■ ArrayType THEN (* RHS had better be an array type too, or a string const *) genlndexf nodeRHSTn^; gen Index(nodeLHS(n)); computes Ize(nodeRHS(n), nodeLHS(n)); wr IteCopy;

ELSE

genExpr(nodeRHS(n)); (* generate the expression *)

genScaIarAssign(nodeLHS(n));

END;

END genAssignStmt;

PROCEDURE genScaIarAssign(n:node);

(* generate code to assign top of stack to n *)

BEGIN

IF nodeClass(n) * nlndex THEN genlndex(n); writePop;

ELSIF SymboI.cI ass(baseType(nodeType(n))) = ArrayType THEN (* error * fata I(’genScaIarAssign: array type given*);

ELSE (* a scalar variable *)

writeSymPop(nodeSymboI(n)); (* pop result into the variable *

END;

END genScaIarAssign;

PROCEDURE computesize(source, dest:node);

(* Size for an array copy is tricky. The rules are:

1. If the size of source and dest are known (i.e. they are not open arrays), then take the min.

2. If the size of one or both isn't known, compute the min at runtime. VAR stype, dtype:symboI;

BEGIN

stype :* baseTypefnodeTypefsource)); dtype :*■ baseType(nodeType(dest));

IF SymboI.open(stype) OR SymboI.open(dtype) THEN gen3ize(source, stype); genSize(dest, dtype);

writeMin; (* MIN instruction added for this purpose *)

ELSIF nodeClass(source) - nString THEN

IF nstringLen(source) + 1 < SymboI.size(dtype) THEN genSize(source, stype);

ELSE

genSize(dest, dtype);

END;

ELSIF NOT Symbol.equal(stype, dtype) THEN fatal('computeSize: not same type’);

ELSE

genSize(source, stype);

END;

END computeSize;

PROCEDURE genSize(n:node; ntype:symboI);

(* generate code to put size of n on stack; n must be of type array. *) BEGIN

IF SymboI.open(ntype) THEN (* size = highBound - lowBound + 1 *) genHighBound(n); genLowBound(n); wr i teOp(Minus); wr i telnt(1); wr IteOp(PI us);

ELSIF nodeClass(n) » nString THEN (* string const *) writelnt(INTEGER(nstringLen(n) + 1));

(* Important: +1 for null at end *)

ELSE (* a non-open array variable *)

writelnt(INTEGER(SymboI.size(ntype)));

END;

END genSize;

PROCEDURE genCalI Stmt(n:node);

BEGIN

(* Here we do the special checks for the pseudofunctions LOW and HIGIF SymboI.equaI(nodeRoutine(n), lowFunc) THEN genLowBound(nodeFirst(nodeArgs(n)));

ELSIF SymboI.equaI(nodeRoutine(n), highFunc) THEN genHighBound(nodeFirst(nodeArgs(n)));

ELSE (* a "real" function *)

140 BYTE LISTINGS SUPPLEMENT

genArgs(nodeRoutine(n), nodeArgs(n)); (* generate the arguments *) writeCalI(nodeRoutine(n)); (* generate a call instruction *)

END;

END genCalIStmt;

PROCEDURE genArgs(routine:symboI; argIist:node);

(* Iterate down the arglist and the list of the routine’s formals, and generate code for each argument *)

VAR formlist:symbolList;

BEGIN

formlist := SymboI.forma Is(routine);

(* assume number of formals = number of args *)

WHILE NOT nodeEmpty(argIist) DO

genArg(nodeFirst(arglist), siSymboI(formlist)); arglist := nodeRest(argIist); formlist := sI Next(form Iist);

END;

END genArgs;

PROCEDURE genArg(arg:node; forma I:symboI);

(* Generate code to push the argument on the stack, as follows:

1. Argument is an array:

la. If formal is open array, push high bound, low bound;

lb. Push starting address, regardless

2. Argument is a scalar:

2a. If formal has mode IN, do the usual thing: genExpr.

2b. Otherwise, push the address of the scalar.

*)

VAR argType:symboI;

BEGIN

argType :* baseType(nodeType(arg));

IF SymboI.cIass(argType) * ArrayType THEN IF SymboI.open(SymboI.type(formaI)) THEN genHighBound(ara); genLowBound(arg);

END;

genlndex(arg);

ELSIF SymboI.cIassfargType) « ScalarType THEN IF SymboI.mode(forma I) ■ min THEN genExpr(arg);

ELSE

genlndex(arg);

END;

ELSE

fatal(’genArg: argtype not a type object’);

END;

END genArg;

PROCEDURE genWr1teStmt(n:node);

(* Generate code to write the arguments to the screen. WRITE can take any number of arguments. *)

VAR arglist:node;

argType:symbol;

BEGIN

arglist :- nodeArgs(n);

WHILE NOT nodeEmpty(argI 1st) DO genExpr(nodeFirst(argIist));

argType :« baseType(nodeType(nodeFirst(argIist)));

IF Symbol.equal(argType, tlnteger) THEN wr iteWritelnt;

ELSE (* it’s a char *) wr iteWriteChar;

END;

arglist :■ nodeRest(argIist);

END;

END genWr1teStmt;

PROCEDURE genReadStmt(n:node);

(* Generate code to read from the terminal. READ can take any number of arguments. *)

VAR argI 1st:node;

argType:symbol;

BEGIN

arglist :« nodeArgs(n);

WHILE NOT nodeEmpty(argIist) DO

[continued)

BYTE LISTINGS SUPPLEMENT 141

argType baseType(nodeType(nodeFIrst(argl ist)));

IF Symbol.equal(argType, tlnteger) THEN wr IteReadlnt;

genScaIarAssign(nodeF!rst(arglist));

ELSE (* a char *) wr IteReadChar;

genScalarAssign(nodeFir$t(argllst));

END;

argllst ;■ nodeRest(argI Ist);

END;

END genReadStmt;

PROCEDURE genReturnStmt(n:node);

BEGIN

IF nodeEmpty(nodeExpr(n)) THEN (* a procedure return *) wr IteReturn(nodeNumFormaI s(n));

ELSE: (* a function return *)

genExpr(nodeExpr(n)); wrIteFReturn(nodeNumFormaIs(n));

END;

END genReturnStmt;

(*** expressions ***)

PROCEDURE genExpr(n;node); BEGIN

CASE nodeClass(n) OF

nUnop; genExpr(nodeArg(n)); writeOp(nodeOp(n));

| nOp: IF (nodeOp(n) - And) OR (nodeOp(n) « Or) THEN

genLogicalOp(n);

ELSE

genExprfnodeLeftArg(n)}; genExpr(nodeRightArg(n)); writeOp(nodeOp(n));

END;

nlnt: writelnt(nodelnt(n));

nBool: writeBooI(nodeBooI(n)); nChar: writeChar(nodeChar(n)); nSymboI:writeSymboI(nodeSymboI(n)); nCalI; genCalIStmt(n); nlndex: genlndex(n);

writeContents;

ELSE MyTerminaI.fata I("genExpr: unknown expression type");

END;

END genExpr;

PROCEDURE genLogicaIOp(nmode);

(* AND * s and OR’s end up here. We generate code to evaluate only the firs' if possible. *)

VAR I obeli, label 2:label;

BEGIN

IabeII := newLabeI();

Iabel2 := newLabel(); genExpr(nodeLeftArg(n));

IF nodeOp(n) = And THEN (* we branch to FALSE if the first was FALSE writeCondBranch(Equal, label 1);

ELSE (* it's OR; we branch to TRUE if the first was TRUE *) writeCondBranch(Greater, label 1);

END;

genExpr(nodeRightArg(n)); (* if the first one failed to decide, the vc

. v of the 2nd is the value of the whole thi-:

writeBranch(Iabe12); writeLabeI(IabeII);

writeBooI(nodeOp(n) = Or); (* write TRUE if OR, FALSE if AND *) writeLabeI(Iabe12);

END genLogicalOp;

PROCEDURE genlndex(n:node);

(* Generates an array index. Ends up with element address on top of stacWorks fine for whole arrays, too—puts the starting address on the stc:* In fact, works fine for scalar symbols tool And for strings. *)

VAR arrayVarmode;

BEGIN

IF nodeClass(n) * nSymboI THEN writeAddr(nodeSymboI(n));

142 BYTE LISTINGS SUPPLEMENT

ELSIF nodeClass(n) =* nString THEN genString(n);

ELSIF nodeClass(n) = nlndex THEN arrayVar := nodeArray(n); genlndex(arrayVar); genLowBound(arrayVar); genHighBound(arrayVar); genExpr(nodeIndex(n));

writeAref(SymboI.size(baseType(nodeType(n))));

ELSE

fatal('genlndex: node not symbol, string or Index*);

END;

END genlndex;

PROCEDURE genLowBound(arrayVar:node);

VAR arrayType:symbol;

BEGIN

arrayType := baseType(nodeType(arrayVar));

IF nodeCIass(arrayVar) = nSymboI THEN IF SymboI.open(arrayType) THEN

wrIteLow(nodeSymboI(arrayVar));

ELSE

wrItelnt(SymboI.IowBound(arrayType));

END;

ELSIF nodeCIass(arrayVar) = nString THEN wr I telnt(0);

ELSIF nodeCIass(arrayVar) = nlndex THEN wrItelnt(SymboI.IowBound(arrayType));

ELSE

fatal('genLowBound: not symbol, string or index*);

END;

END genLowBound;

PROCEDURE genHighBound(arrayVarinode);

VAR arrayTypeisymboI;

BEGIN

arrayType := baseType(nodeType(arrayVar));

IF nodeCIass(arrayVar) = nSymbol THEN IF SymboI,open(arrayType) THEN

writeHigh(nodeSymboI(arrayVar));

ELSE

writelnt(SymboI.highBound(arrayType));

END;

ELSIF nodeCIass(arrayVar) « nString THEN

writelnt(nstringLen(arrayVar)-l); (* does not include 0 at end *) ELSIF nodeCIass(arrayVar) = nlndex THEN writelnt(SymboI.highBound(arrayType));

ELSE

fata I('genHighBound: not symbol or index*);

END;

END genHighBound;

PROCEDURE genString(nmode);

VAR lab:label;

s:stringType;

BEGIN

lab :« newLabeI(); nodeString(n, s); recordString(lab, s);

END genString;

PROCEDURE nstringLen(n:node):CARDINAL;

VAR s:stringType;

BEGIN

nodeString(n, s);

RETURN stringLen(s);

END nstringLen;

BEGIN

END CodeGen.

Start CodeWrite.DEF

(continued)

BYTE LISTINGS SUPPLEMENT 143

DEFINITION MODULE CodeWrlte;

(* This module outputs the code for the SIMPL compiler. *) \

FROM Symbol IMPORT symbol;

FROM Token IMPORT tokenCloss, stringType;

EXPORT QUALIFIED writeLabel, writeStringLabeI, writeRoutineLabeI, writeHalt.

writeStringBranch, writeBronch, writeCondBranch, writePop, writeCall writeWritelnt, wrlteReadlnt, wrlteReturn, writeFReturn, writeOp, wrltelnt, writeBool, writeSymbol, writeChar, writeSymPop, writeWriteChar, writeReadChar, writeLow, writeHigh, writeAddr, writeCopy, writeMin, writeContents, writeSetSP, writeAref, recordstring, writeStrings;

PROCEDURE writeLabeI(c:CARDINAL);

(* Writes an “L" followed by the number, then a colon. *)

PROCEDURE writeStringLabeI(s:ARRAY OF CHAR);

(* Just writes the string followed by a colon. *)

PROCEDURE writeRoutineLabeI(routine:symboI);

(* Writes the name of the routine followed by a colon, and writes (on the screen) the procedure name so the user knows it’s being compiled. *)

PROCEDURE wrIteStringBranch(s: ARRAY OF CHAR);

(* Write a branch followed by the string *)

PROCEDURE writeCondBranch(tc:tokenCI ass; crCARDINAL);

(* Write a conditional branch (Equal, Greater or Less) followed by "L“, thethe number. *)

PROCEDURE writeBranch(c:CARDINAL);

(* Write an unconditional branch to the label. *)

PROCEDURE writeCalI(s:symboI);

(* Generate a call instruction with the symbol *)

PROCEDURE writeWritelnt;

PROCEDURE writeReadlnt;

PROCEDURE writeWriteChar;

PROCEDURE writeReadChar;

(* instructions for I/O *)

PROCEDURE writeReturn(numFormaIs:CARDINAL);

PROCEDURE writeFReturn(numFormaIs:CARDINAL);

(* Two types of return instructions; both take the number of formals as arg. PROCEDURE writeOp(tc:tokenCI ass);

(* Write the instruction corresponding to the operator *)

PROCEDURE writelnt(i;INTEGER);

PROCEDURE writeBool(b:BOOLEAN);

PROCEDURE writeChar(c:CHAR);

(* Write pushes for these constants. *)

PROCEDURE writeSymboI(s:symboI);

(* Generate the appropriate push instruction for the symbol *)

PROCEDURE writeSymPop(s:symboI);

(* Generate the appropriate pop instruction for the symbol *)

PROCEDURE writeHalt;

PROCEDURE writeAddr(s:symbol);

(* Put the address of the symbol on the stack *)

PROCEDURE writeLow(s:symboI);

PROCEDURE writeHigh(s:symboI);

(* For low and high bounds of open arrays. *)

PROCEDURE writeCopy;

PROCEDURE writeMin;

PROCEDURE writeContents;

PROCEDURE writePop;

PROCEDURE writeSetSP(i;INTEGER);

PROCEDURE writeAref(size:CARDINAL);

144 BYTE LISTINGS SUPPLEMENT

PROCEDURE recordStrIng(IabrCARDINAL; VAR s:stringType);

(* remembers a string, to be output later *)

PROCEDURE writeStrings;

(* Writes out remembered strings, preceded by their labels. *) END CodeWrite.

Start CodeWrite.MOD

MPLEMENTATION MODULE CodeWrite;

FROM InOut IMPORT WriteString, WriteLn, Writelnt, WriteCard;

(* We can * t use Write because of a conflict inside tokenClass *)

IMPORT InOut; '

FROM Symbol IMPORT symbol, Class, modeType;

IMPORT Symbol;

FROM SymbolTable IMPORT currentLexLeveI;

FROM Token IMPORT tokenClass, stringType;

IMPORT MyTerminal;

PROCEDURE writeStringLabeI(s:ARRAY OF CHAR);

BEGIN

Wr i teString(s);

Wr i teString(’: *);

END writeStringLabeI;

PROCEDURE writeRoutineLabel(routine:symboI);

VAR name:stringType;

BEGIN

wr iteRoutineName(rout1ne);

WriteString(*: ’);

Wr i teLn;

SymboI.string(routine, name);

MyTerminal.WriteString(name);

MyTerminal .Wr i teLnStr ing(" .. . •');

END writeRoutineLabeI;

PROCEDURE writeRoutineName(routine:symboI);

VAR name:stringType;

BEGIN

SymboI.string(routine, name);

Wr i teString(name);

IF Symbol.lexLevel(routine) <> 0 THEN WriteInt(Symbol.offset(routine), 0);

END;

END writeRoutineName;

PROCEDURE writelabeI(c:CARDINAL);

BEGIN

InOut.Write(’L’);

WriteCard(c, 0);

InOut.Wr f te(•:•);

Wr iteLn;

END writeLabeI;

PROCEDURE writeStringBranch(s:ARRAY OF CHAR);

BEGIN '

writeOpCode(’BRANCH *);

WriteLnString(s);

END writeStringBranch;

PROCEDURE writeBranch(c:CARDINAL);

BEGIN

wr i t eOpCode(’BRANCH L');

WriteCard(c, 0);

WriteLn;

END writeBranch;

PROCEDURE writeCondBranch(tc:tokenClass; c:CARDINAL);

BEGIN '

CASE tc OF

Equal; writeOpCode(’BREQL L');

| Less: writeOpCode(’BRLSS L');

( continued )

BYTE LISTINGS SUPPLEMENT 145

| Greater:writeOpCode(’BRGTR L');

ELSE

MyTerminal.fatal(*wrIteCondBranch: unknown branch type’);

END;

WrIteCard(c, 0);

WriteLn;

END writeCondBranch;

PROCEDURE wrIteWritelnt;

BEGIN

writeOpCode('WRINT’);

Wr i teLn;

END writeWrftelnt;

PROCEDURE writeReadlnt;

BEGIN

writeOpCode(’RDINT’);

Wr l teLn;

END writeReadlnt;

PROCEDURE wr I teWriteChar;

BEGIN

wr 11 eOpCode(* WRCHAR *);

Wr l teLn;

END writeWriteChar;

PROCEDURE writeReadChar;

BEGIN

writ eOpCode(*RDCHAR *);

WrIteLn;

END writeReadChar;

PROCEDURE writeHalt;

BEGIN

writeOpCode('HALT*);

WriteLn;

END writeHalt;

PROCEDURE writeReturn(numFormaIs:CARDINAL);

BEGIN

writeOpCode(’RETURN ’);

WriteCard(numFormaIs, 0);

Wr1teLn;

END writeReturn;

PROCEDURE writeFReturn(numFormaIs:CARDINAL);

BEGIN

wr iteOpCode(’FRETURN ’);

WriteCard(numFormaIs, 0);

Wr ? teLn;

END writeFReturn;

PROCEDURE writelnt(i;INTEGER);

BEGIN

writeOpCode(* PUSHC ’);

Wr i telnt(i, 0);

Wr i teLn;

END writelnt;

PROCEDURE writeChar(c:CHAR);

BEGIN

writeOpCode(’PUSHC ’);

InOut.Write(.);

InOut.Write(c);

WriteLn;

END writeChar;

PROCEDURE writeBooI(b:BOOLEAN);

BEGIN

IF b THEN

writelnt(1) ;

ELSE

wr i telnt(0);

END;

END writeBooI;

146 BYTE LISTINGS SUPPLEMENT

PROCEDURE writeSymPop(s:symboI);

(* Not defined on array symbols. *)

BEGIN

wrIteSymAddr(s, "POPC ", "POPL ", "PUSHL ");

IF SymboI,cIass(s) = Formal THEN wrItePop;

END;

END writeSymPop;

PROCEDURE wrIteSymboI(s:symboI);

(* Put the contents of the symbol on the stack. Not defined for array symbols. *)

BEGIN

writeSymAddr(s, "PUSH ", "PUSHL ", "PUSHL ");

IF (Symbol.class(s) = Formal) AND (SymboI.mode(s) = mlnOut) THEN wrIteContents;

END;

END writeSymboI;

PROCEDURE writeAddr(s:symboI);

(* Put the address of the symbol on the stack. Rules: array:

gIobaI: pushc; locaI: addrI; forma I: push I; sea Iar:

gIobaI: pushc; locaI: addrI;

formal: IN: addrl; OUT, IN OUT; pushl

*)

BEGIN

IF (Symbol.cI ass(SymboI.type(s)) * ScalarType) AND (Symbol.class(s) * Formal) AND (SymboI.mode(s) * min) THEN

writeSymAddr(s, "dummy", "dummy", "ADDRL ");

ELSE J

writeSymAddr(s, "PUSHC ", "ADDRL ", "PUSHL "):

END; '

END wrfteAddr;

PROCEDURE writeSymAddr(s:symboI; global, local, formal:ARRAY OF CHAR);

VAR name:strIngType;

BEGIN

Symbol.string(s, name);

IF SymboI.cIass(s) ■ Global THEN writeOpCode(gIobaI);

Wr I teLnStrIng(name);

ELSE

IF Symbol.class(s) « Local THEN wr IteOpCode(I oca I);

ELSIF Symbol.class(s) = Formal THEN wr IteOpCode(forma I);

ELSE

MyTerminaI.fata I(’writeSymAddr: not variable*):

END;

Wr i telnt(cur rentLexLeveI() - SymboI.IexLeveI(s), 0);

Wr i teString(*, *);

Wr i telnt(SymboI.offset(s), 0); wr iteComment(name);

END;

END writeSymAddr;

PROCEDURE writeCaI I(s:symboI);

BEGIN

wr iteOpCode("CALL "); wr i teRoutIneName(s);

Wr i teStrIng(", ");

Wr Itelnt(cur rentLexLeveI() - SymboI.IexLeveI(s), 0);

WriteLn;

END writeCalI;

PROCEDURE writeOp(tc:tokenCIoss);

BEGIN

CASE tc OF

Plus: writeOpCodef *ADD*);

I Minus: writeOpCode(*SUB*);

( continued )

BYTE LISTINGS SUPPLEMENT 147

UMinus: Times: Divide:

Not:

Equal: Greater: Less: NotEqual: LessEquaI: GreaterEqua ELSE MyTerminal END;

Wr1teLn;

END writeOp;

writeOpCodef ’NEG*); wr i teOpCode ( 'MUL') ; wr iteOpCode(’DIV*); wr i teOpCode ( ’NOT*) ; wr i teOpCode ( ’EQUAL * ) ; wr IteOpCode(‘GREATER’); wr 1teOpCode(’LESS *); wr 1teOpCode(’NOTEQL ’); wr 1 teOpCode (’ LSSEQL ');

: wr 1teOpCode(’GTREQL'); fataI("wrIteOp: unknown operator");

PROCEDURE WriteLnString(s:ARRAY OF CHAR); BEGIN

WriteString(s);

WriteLn;

END WriteLnString;

PROCEDURE writeOpCode(s:ARRAY OF CHAR); BEGIN

Wr iteStr I ng('* ");

WriteString(s);

END writeOpCode;

PROCEDURE wr i teComment(s‘.ARRAY OF CHAR); BEGIN

Wr iteStrlng(" ; "):

Wr iteStrlng(s);

Wr1teLn;

END wr1teComment;

PROCEDURE writeCopy; BEGIN

wr iteOpCode("COPY"); WriteLn;

END writeCopy;

PROCEDURE writeMin;

BEGIN

wr1teOpCode("MIN"); WriteLn;

END writeMin;

PROCEDURE writePop;

BEGIN

writeOpCode("POP"); WriteLn;

END writePop;

PROCEDURE writeContents; BEGIN

writeOpCode("CONTENTS"); WrIteLn;

END writeContents;

PROCEDURE writeLow(s:symbol);

(* stack looks like this: highBound IowBound

startaddr <— offset

*)

BEGIN

wrIteOpCode("PUSHL ");

Writelnt(currentLexLeveI() Wr iteStringC , *);

Writelnt(Symbol.offset(s)+1, writeComment("LOW");

END writeLow;

SymboI.IexLeveI(s), 0);

0 );

PROCEDURE writeHigh(s:symbol); (* stack looks like this:

| highBound |

148

BYTE LISTINGS SUPPLEMENT

Chapter Notes

Break the following modules out into their own files Start CodeGen.DEF

DEFINITION MODULE CodeGen;

(* * This module generates code from parse trees. *)

FROM Node IMPORT node;

FROM Symbol IMPORT symbol;

EXPORT QUALIFIED genBlock, genGlobal, genLocals;

PROCEDURE genBlock(nrnode);

(* Generate code for a block of statements. *)

PROCEDURE genGIobaI(s:symboI);

(* Generate code for a global variable. *)

PROCEDURE genLocaIs(routine:symboI);

(* Generate code to set up the stack for local variables. *) END CodeGen.

Start CodeGen.MOD

IMPLEMENTATION MODULE CodeGen;

(* Code Generator for the SIMPL compiler.

Changes for part 3:

1. Arrays handled. No arrays are initialized. Now, also, locals of any type are not initialized.

2. IN/OUT handled.

3. Array and string const assignment handled.

4. String constant assignment handled.

*)

FROM MyTerminal IMPORT fatal;

IMPORT MyTerminal;

FROM InOut IMPORT WriteString, WriteLn, WriteCard;

FROM Node IMPORT node, nodeClass, NodeClass, nodeEmpty, nodeFirst, nodeRest, nodejest, nodeThen, nodeElse, nodeStmts, nodeRHS, nodeLHS, nodeArgs, nodeRoutine, nodeExpr, nodeArg, nodeLeftArg, nodeRightArg, nodeOp, nodeSymbol, nodelnt, nodeBool, nodeNumFormaIs, nodeChar, nodeType, freeNode, nodeArray, nodeindex, nodeString;

FROM CodeWrite IMPORT writeLabel, writeStringLabeI, writeStringBranch,

writeCondBranch, writeBranch, writeSymPop, writeCall, writeChar, writeWritelnt, writelnt, writeReadlnt, writeReturn, writeFReturn, writeOp, writeBool, writeSymbol, writeWriteChar, writeReadChar, writeSetSP, writePop, writeLow, writeHigh, writeCopy, writeAddr, writeMin, writeContents, writeAref, recordstring;

FROM Token IMPORT tokenClass, isRelation, stringType;

FROM LexAn IMPORT err orFlag;

FROM Symbol IMPORT symbol, numLocals, Class, modeType, symbolList, sISymbol, sINext, slEmpty;

( continued )

BYTE LISTINGS SUPPLEMENT 137

February

lowBound |

j startaddr j <— offset

*)

BEGIN

wr IteOpCode("PUSHL

Writelnt(currentLexLeveI() - SymboI.IexLeveI(s), 0);

WriteString(’, *);

Wr i telnt(SymboI.offset(s)+2, 0); wr iteComment("HIGH");

END writeHigh;

PROCEDURE writeSetSP(i:INTEGER);

BEGIN

writeOpCode("SETSP ");

Writelnt(i, 0);

WriteLn;

END writeSetSP;

PROCEDURE writeAref(size:CARDINAL);

BEGIN

writ eOpCode("AREF ");

WriteCard(size, 0);

Wr i teLn;

END writeAref;

MODULE Strings; (* for handling string constants *)

FROM MyTerminal IMPORT fatal;

FROM InOut IMPORT Write, EOL;

IMPORT writeLabel, WriteString, WriteLn, WriteCard, stringType, writeOpCode, writeComment;

EXPORT writeStrings, recordstring;

CONST maxStrings ■ 20; (* max string consts per routine *)

TYPE stringRec * RECORD

string:stringType; label -.CARDINAL;

END;

VAR strings: ARRAY[1..maxStrings] OF stringRec; nStrings:[0..maxStrings];

PROCEDURE recordString(Iab:CARDINAL; VAR s:stringType);

(* record the string in the array and write code to push its address *) BEGIN

IF nStrlngs ■ maxStrings THEN

fatal(*too many strings in routine');

ELSE

INC(nStrlngs);

WITH strings[n$trings] DO label :■ lab; string := s;

END;

writeOpCode(’PUSHC L');

Wr1teCard(Iab, 0);

WriteLn;

END;

END recordstring;

PROCEDURE writeStrings;

VAR 1:CARDINAL;

BEGIN

FOR i :* 1 TO nStrings DO

writeLabel(strings[i].label);

WriteString(* "’);

formatString(strings[i].string);

WriteStrlng(’" ’);

WrIteCard(0, 0);

WrIteLn;

END;

nStrings :« 0;

END wrIteStrings;

PROCEDURE formatstring(VAR s:ARRAY OF CHAR);

(* puts slashes back in *)

CONST Tab - 11C;

VAR i:CARDINAL;

(continued)

BYTE LISTINGS SUPPLEMENT 149

BEGIN

i 0;

WHILE (i <- HIGH(s)) AND (s[i] <> 0C) DO IF s [ I ] - THEN

WriteStrIng(*\"');

ELSIF s[i] - EOL THEN WriteString("\n");

ELSIF s[i] * Tab THEN Wr I teString("\t");

ELSIF s[I] - "\" THEN WrlteStrlng("\\");

ELSE

WrIte(s[i ]);

END;

INC(I);

END;

END formatstring;

BEGIN (* module Strings *) nStrings :* 0;

END Strings;

BEGIN

END CodeWrite.

Start Compiler.MOD

MODULE CompiIer;

(* A compiler for the SIMPL programming language.

Copyright 1985 by Jonathan Amsterdam. All Rights Reserved.

See the BYTE article "A SIMPL Compiler" for more information.

Module map, roughly in order of low to high level:

CharStuff StringStuff MyTermina1 LexAnStuf f

Low-level character utilities \

Low-level string utilities

Low-level terminal I/O utilities

Toolkit for building lexical analyzers /

used in prev :-s projects

Token

Symbo1

Node

Token, tokenList and typeType data types Symbol, symbolList and related data types Node and related data types

Ini t

TypeChecker

LexAn

Symbo1 Tab 1e CodeWrite CodeGen

Initialization of compiler

Procedures to do type-checking

Lexical analyzer for compiler

Compiler symbol table

Actual output of code

Code generation

ExprParser Routines Parser

Parses expressions

Parses procedure and function declarations Main parser

The module Debug, also supplied, is not used by the compiler, but contc -s routines useful in debugging the compiler.

I would appreciate hearing about any bugs in the code. My BIX name is jba. —Jonathan Amsterdam

*)

FROM InOut IMPORT Openlnput, OpenOutput, Closelnput, CloseOutput;

FROM MyTerminal IMPORT ClearScreen, pause, WriteLnString;

FROM Parser IMPORT program;

IMPORT Init;

BEGIN

CIearScreen;

WriteLnString("SIMPL Compiler V2.0 n );

Openlnput(’SMP*);

OpenOutput(’ASM’);

Init.enterKeywords; program;

Closelnput;

150 BYTE LISTINGS SUPPLEMENT

CloseOutput; pause(‘Done—'); END CompiIer.

Start ExprParser.DEF

DEFINITION MODULE ExprParser;

(* The part of the parser that handles expressions.

Syntax:

<expr>::= <expr>|<reIexpr> | <relexpr> OR <expr> | <relexpr> AND <expr> <relexpr> ::= <intexpr> | <intexpr> <relation> <intexpr>

<intexpr> <term> | <term> + <intexpr> | <term> - <intexpr>

<term> :;= <factor> | <factor> * <term> | <factor> / <term>

<factor> <idOrIndex> | <number> | <call> | <char>

- <factor> j NOT <factor> | ( <expr> ) | <string> <id0rlndex> <id> | <idOrIndex> [ <expr> ] | <id> [ <exprlist> ]

*)

FROM Node IMPORT node;

FROM Symbol IMPORT symbol;

EXPORT QUALIFIED expr, idOrlndex;

PROCEDURE expr()inode;

PROCEDURE id0rlndex(sisymboI)inode;

END ExprParser.

Start ExprParser.MOD

IMPLEMENTATION MODULE ExprParser;

(* Handles parsing of expressions, which are tricky because we have to

make the operators left-associative, whereas the normal recursive descent grammar would have them be right-associative.

The problem Is that the trees are build from the right. To make them get built from the left, we pass to expr, relexpr, intexpr and term the partial tree constructed from the left, and each of these procedures hooks that tree on to the one it parses in the appropriate way.

Changes for part 3:

1. Type coercion functions are handled.

2. Strings handled.

3. Array indexing handled.

*)

FROM Token IMPORT token, tokenClass, IsRelation;

FROM LexAn IMPORT getToken, ungetToken, tokenErrorCheck, compError, getTokenCI ass, peekTokenCI ass;

FROM Symbol IMPORT symbol, Class, modeType;

IMPORT Symbol;

FROM SymbolTable IMPORT findSymbol, tlnteger;

FROM Node IMPORT node, emptyNode, makeOpNode, makeUnopNode, makelntegerNode, makeBooIeanNode, makeSymboI Node, makeCaI I Node, makeStringNode, nodeEmpty, makeCharNode, nodeFirst, nodeRest, makelndexNode, setNodeType, nodeType;

FROM Parser IMPORT actuals;

FROM TypeChecker IMPORT indexCheck;

CONST dummy ■ Period;

(* <expr>::■ <expr>|<reIexpr> | <relexpr> OR <expr> | <relexpr> AND <expr> *)

PROCEDURE expr()inode;

BEGIN

RETURN expr1(emptyNode, dummy);

END expr;

PROCEDURE expr1(I eft inode; op:tokenClass):node;

VAR ninode; t:token;

[continued)

BYTE LISTINGS SUPPLEMENT 151

BEGIN

n :■= relexprQ; getToken(t);

IF (t.class » And) OR (t.closs - Or) THEN

RETURN expr1(buildTree(op, left, n), t.class);

ELSE

ungetToken;

IF nodeEmpty(left) THEN RETURN n;

ELSE

RETURN makeOpNode(op, left, n);

END;

END;

END expr1;

(* <relexpr> ;<lntexpr> | <lntexpr> <relation> <intexpr> *)

PROCEDURE re Iexpr();node;

(* Here we don't have to worry about associativity since relations aren't associative! *)

VAR n:node;

t: token;

BEGIN

n :« intexpr(emptyNode, dummy); getToken(t);

IF isReI ation(t.cI ass) THEN

RETURN makeOpNode(t.cI ass, n, intexpr(emptyNode, dummy));

ELSE

ungetToken;

RETURN n;

END;

END re Iexpr;

(* <intexpr> :<term> | <term> + <intexpr> | <term> - <intexpr> *)

PROCEDURE intexpr(I eft:node; op;tokenCI ass);node;

VAR n:node;

t;token;

BEGIN

n :» term(emptyNode, dummy); getToken(t);

IF (t.class = Plus) OR (t.class = Minus) THEN

RETURN Intexpr(buildTree(op, left, n), t.class);

ELSE

ungetToken;

IF nodeEmpty(Ieft) THEN RETURN n;

ELSE

RETURN makeOpNode(op, left, n);

END;

END;

END intexpr;

(* <term> <factor> | <factor> * <term> | <factor> / <term> *)

PROCEDURE term(Ieft;node; op;tokenCIass):node;

VAR ninode;

t: token;

BEGIN

n :*= factorQ; getToken(t);

IF (t.class = Times) OR (t.class = Divide) THEN RETURN term(buiIdTree(op, left, n), t.class);

ELSE

ungetToken;

IF nodeEmpty(Ieft) THEN RETURN n;

ELSE

RETURN makeOpNode(op, left, n);

END;

END;

END term;

(* <factor> ::= <id> | <number> | <caI I> j <char> | - <factor> | NOT <factcr> ;

( <expr> ) | <string> | <index> *)

PROCEDURE factor():node;

VAR ninode;

t;token;

BEGIN

getToken(t);

152 BYTE LISTINGS SUPPLEMENT

CASE t.cl ass OF

Int: RETURN makeIntegerNode(t.integer);

Character: RETURN makeCharNode(t.ch);

String: RETURN makeStringNode(t.string);

Minus: RETURN makeUnopNode(UMi nus , factorQ);

Not: RETURN makeUnopNode(Not, factorQ);

True: RETURN makeBooIeanNode(TRUE);

False: RETURN makeBooIeanNode(FALSE);

Lparen:

n := expr();

tokenErrorCheck(Rparen, ’Right paren expeced');

RETURN n;

| Identifier: RETURN Id(t);

ELSE

compError('bad factor');

RETURN emptyNode;

END;

END factor;

PROCEDURE Id(t:token):node;

VAR s:symboI;

BEGIN

s := findSymboI(t.string);

CASE SymboI.cIass(s) OF

Func: RETURN makeCaI INode(s, actuals());

| Proc: compError('procedures cannot be used in an expression');

RETURN emptyNode;

1 ArrayType, ScalarType: RETURN typeCoerce(s, actuals());

Global, Local, Formal: (* it's a variable or index*)

IF (Symbol.class(s) « Formal) AND (SymboI.mode(s) = mOut) THEN compError("can't use an OUT formal in an expression");

END;

RETURN idOrIndex(s);

ELSE (* ignore *)

RETURN emptyNode;

END;

END Id;

(* <id0rlndex> <id> | <id0rlndex> [ <expr> ]

That’s the "official" syntax. It's easier to treat it as:

<id0rlndex> ::» <id> <indices>

<indices> <empty> | [ <exprOrExprIist> ] <indices>

The beginning <id> has already been read and looked up. *)

PROCEDURE idOrIndex(s:symboI):node;

BEGIN

IF (peekTokenCIass() ** Lbracket) AND

(Symbol.cIass(SymboI.type(s)) <> ArrayType) THEN compError("array variable expected");

END;

RETURN indices(makeSymboI Node(s));

END idOrlndex;

PROCEDURE indices(n:node):node;

BEGIN

IF getTokenClass() = Lbracket THEN (* array index *)

RETURN indicesl(n);

ELSE (* no Index *) ungetToken;

RETURN n;

END;

END indices;

PROCEDURE indices1(n:node):node;

(* Like indices, except it starts with expression instead of Lbracket *)

VAR exp:node;

tc:tokenClass;

BEGIN

IF Symbol.class(nodeType(n)) <> ArrayType THEN compError("too many indices for array");

END;

exp :«= expr();

IndexCheck(exp); tc :* getTokenClass();

IF tc - Rbracket THEN

RETURN indices(makeIndexNode(n, exp));

ELSIF tc ■ Comma THEN

( continued )

BYTE LISTINGS SUPPLEMENT 153

RETURN indices1(makeIndexNode(n, exp));

ELSE

e >^T..S? n,pError ( Uri9ht bracket or comma expected"): RETURN emptyNode;

END;

END Indices'!;

PROCEDURE bulIdTree(op:tokenCI ass; nl, n2:node):node;

BEGIn' S * th * k#y h0Cl< th0t bullds trees up from the left If necessary. *)

IF nodeEmpty(nl) THEN RETURN n2;

ELSE

RETURN makeOpNode(op, nl, n2);

END;

END buildTree;

PROCEDURE typeCoerce(typeObject:symboI; actuaI inode)mode;

(* Changes the type of the actual to typeObject. actual should be a list

tv D eOb ieet n ^KIot«%h C + Ua ' ' S tyP ! * h ° Uld h ° Ve the SOme size 08 the nhii?+i ! th ? t y ? u can do S0 T* Pre^y evil things with this

arrayf^' 2 [1 sf ^ m,n 9 an orray[1..10][1..2] into an

BEGIN " " J ' *

IF nodeEmpty(actuaI) THEN

RETURN*” actual* coercion functions must take an argument’);

ELSE

IF NOT nodeEmpty(nodeRest(actuaI)) THEN

compError(* type coercion functions take only one argument 8 ):

(* ...but we’ll set the first argument anyway *)

IF HucZ 1 * slz ®( typ ® 0b j ect ) <> SymboI.size(nodeType(nodeFirst(actuc THEN compEr ror( types not of same size’):

END; '

setNodeType(nodeFirst(actual), typeOb iect)•

RETURN nodeFIrst(actuaI); '

END;

END typeCoerce;

BEGIN

END ExprParser.

Start Init.DEF ======

DEFINITION MODULE Init;

EXPORT QUALIFIED enterKeywords; PROCEDURE enterKeywords;

END Init.

Start Init.MOD

IMPLEMENTATION MODULE Init;

FROM SymboI Table IMPORT enterKeyword; FROM Token IMPORT tokenCI ass;

PROCEDURE enterKeywords;

BEGIN

enterKeyword(’AND’, And); enterKeyword(’ARRAY’, Array); enterKeyword(’BEGIN’, Begin); enterKeywordf’DO’, Do); enterKeyword(’ELSE’, Else); enterKeywordf’ELSIF’, Elsif); enterKeyword(’END’, End);

154 BYTE LISTINGS SUPPLEMENT

enterKeywordf'FALSE', False); enterKeyword(’FUNCTION*, Function); enterKeyword(* IF *, If); enterKeyword(* IN*, In); enterKeywordf*NOT*, Not); enterKeyword(*0F*, Of); enterKeyword(’OR*, Or); enterKeyword(’OUT*, Out); enterKeywordf’PROCEDURE*, Procedure); enterKeyword(’PROGRAM’, Program); enterKeywordf’READ*, Read); enterKeyword(’RETURN*, Return); enterKeywordf’THEN’, Then); enterKeyword(’TRUE *, True); enterKeywordf’TYPE *, Type); enterKeyword(*VAR*, Var); enterKeyword(’WHILE’, While); enterKeyword(’WRITE’, Write);

END enterKeywords;

BEGIN

END Init.

Start LexAn.DEF

DEFINITION MODULE LexAn;

(* The lexical analyzer for the SIMPL compiler. It uses the InOut module do input, so you can get input from a file by redirecting it with InOut.Openlnput.

This module also handles errors. *)

FROM Token IMPORT token, tokenClass;

EXPORT QUALIFIED getToken, ungetToken, getTokenCI ass, tokenErrorCheck, getTokenErrorCheck, errorFlag, compError, peekTokenCI ass;

VAR errorFIag:BOOLEAN; (* Set to TRUE when an error occurs. *)

PROCEDURE getToken(VAR t:token);

(* Get a token from the input stream. *)

PROCEDURE ungetToken;

(* Push a token back on the input stream. Can only unget one at a time. *) PROCEDURE getTokenCI ass():tokenClass;

(* Get a token from the input stream, but just return its class. *)

PROCEDURE peekTokenCIass();tokenClass;

(* Get a token from the input stream, unget it, and return its class. *)

PROCEDURE tokenErrorCheck(tc:tokenCI ass; msg: ARRAY OF CHAR);

(* Read a token from the input stream and compare its class to tc. If they are the same, do nothing. If they are different, write the current line to the screen, print the message and unget the token. *)

PROCEDURE getTokenErrorCheck(VAR t:token; tc:tokenCI ass; msg: ARRAY OF CHAR); (* Like tokenErrorCheck, but returns the token as well. *)

PROCEDURE compError(msg:ARRAY OF CHAR);

(* Writes the current line and displays msg. Sets errorFlag to TRUE. *)

END LexAn.

Start LexAn.MOD

IMPLEMENTATION MODULE LexAn;

(* Lexical analyzer for the SIMPL compiler. Uses the routines in LexAnStuff.*)

{continued)

BYTE LISTINGS SUPPLEMENT 155

FROM InOut IMPORT EOL;

FROM Token IMPORT token, tokenCloss;

FROM MyTerminol IMPORT fatal, WrIteLnStrIng;

FROM StrlngStuff IMPORT strlngLen;

FROM Symbol Table IMPORT findKeyword;

FROM LexAnStuff IMPORT dispatch, enterAII, enterChar, enterEndOfFI Ie, ignore enterAlphas, enterDiglts, skipToChar, a IphaNumString, poslnteger, string enterWhite, wrlteLlne, getChar, ungetChar;

VAR tok: token;

ungotten: BOOLEAN;

PROCEDURE getToken(VAR t:token);

BEGIN

getTok; t := tok;

END getToken;

PROCEDURE getTok;

VAR c:CHAR;

BEGIN

IF ungotten THEN

ungotten :■ FALSE;

ELSE

dispatch;

END;

END getTok;

PROCEDURE ungetToken;

BEGIN

IF ungotten THEN

fatal("ungetToken: can only unget one token at a time");

ELSE

ungotten :« TRUE;

END;

END ungetToken;

PROCEDURE getTokenCIass():tokenCIass;

BEGIN

getTok;

RETURN tok.cl ass;

END getTokenCIass;

PROCEDURE peekTokenCI ass():tokenClass;

BEGIN

getTok; ungetToken;

RETURN tok.class;

END peekTokenCI ass;

PROCEDURE tokenErrorCheck(tc:tokenCI ass; msg: ARRAY OF CHAR);

BEGIN

getTok;

IF tok.class <> tc THEN compError(msg);

IF tok.class * EndOflnput THEN

fatal("unexpected end of Input");

END;

ungetToken;

END;

END tokenErrorCheck;

PROCEDURE getTokenErrorCheck(VAR t:token; tc:tokenCI ass; msg: ARRAY OF CKi = BEGIN

tokenErrorCheck(tc, msg); t :* tok;

END getTokenErrorCheck;

(*** reading procedures ***)

PROCEDURE I IlegalChar(c:CHAR);

VAR charstring:ARRAY[0..1] OF CHAR;

BEGIN

charstring[0l :« c; (* fake a 1-char string *)

charstring[1J :■ 0C;

compError('iI Iegal character*);

getTok;

156 BYTE LISTINGS SUPPLEMENT

END iI IegaIChar;

PROCEDURE comment(c:CHAR); (* Comments are ignored. They are delimited

by { and \ *)

BEGIN

skipToChar('\'); getTok;

END comment;

PROCEDURE idOrKeyword(c:CHAR);

(* Get an alphanumeric string from the input. If we find it in the symbol

table marked as a keyword, then it's a keyword; findKeyword will have taken care of setting tok.class to the right value. Else, it’s an identifier. *) BEGIN

IF NOT a IphaNumString(c, tok.string} THEN compError(*identifier too long*);

END;

IF NOT findKeyword(tok.string, tok.class) THEN tok.class :* Identifier;

END;

END idOrKeyword;

PROCEDURE poslnt(c:CHAR);

BEGIN

tok.class :* Int;

tok.Integer :■ poslnteger(c);

END poslnt;

PROCEDURE charProc(c:CHAR);

(* Read a character, delimited by delim, from the input. Can use backslash: \n - newline, \t - tab, anything else literal. *)

BEGIN

tok.class :■ Character;

IF (NOT string(c, tok.string)) OR (stringLen(tok.string) > 1) THEN compError(*iI IegaI character constant');

END;

tok.ch :« tok.string[0];

END charProc;

PROCEDURE stringProc(delim:CHAR);

(* Read a string from the input. If too long, skip to the next delim. *) VAR i;CARDINAL;

c: CHAR;

BEGIN

tok.class :■ String;

IF NOT string(deIim, tok.string) THEN compError('string too long’); skipToChar(delIm);

delim :« getChar(); (* get the delimiter *)

END;

END stringProc;

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

PROCEDURE

(*** Reading special characters ***)

semicolon(c:CHAR);BEGIN tok.class := Semicolon;

END

semicolon

equa1(c:CHAR);

BEGIN

tok.c1 ass

: =

Equa1;

END

equa1;

comma(c;CHAR);

BEGIN

tok.c1 ass

; s

Comma;

END

comma;

p1 us(c;CHAR);

BEGIN

tok.c1 ass

; m

Plus;

END

plus;

minus(c:CHAR);

BEGIN

tok.cl ass

l s

Minus;

END

minus;

times(c:CHAR);

BEGIN

tok.cl ass

; s

Times;

END

times;

dividefc:CHARh

BEGIN

tok.cl ass

: =

Divide;

END

divide;

lparen(c:CHAR);

BEGIN

tok.cl ass

:*

Lparen;

END

1paren;

rparen(c:CHAR);

BEGIN

tok.c1 ass

: m

Rparen;

END

rparen;

lbracket(c:CHAR);

BEGIN

tok.class

: rn

Lbracket;

END

lbracket;

rbracket(c:CHAR);

BEGIN

tok.c1 ass

Rbracket;

END

rbracket;

PROCEDURE greater(c:CHAR);

BEGIN

IF getChar() - *«' THEN

tok.class GreaterEquaI;

ELSE

ungetChar;

tok.class :* Greater;

[continued)

BYTE LISTINGS SUPPLEMENT 157

END;

END greater;

PROCEDURE I ess(c:CHAR);

BEGIN

c :* getChar();

IF c - THEN

tok.class :■ LessEqual; ELSIF c - THEN

tok.class :■ NotEqual;

ELSE

ungetChar;

tok.class :« Less;

END;

END less;

PROCEDURE coI on(c:CHAR);

BEGIN

IF getChar() = THEN

tok.class :* Assignment;

ELSE

ungetChar;

tok.class :« Colon;

END;

END colon;

PROCEDURE p e rIodO r Do t do t(c:CHAR); BEGIN

IF getCharQ = THEN tok.class :« DotDot;

ELSE

ungetChar;

tok.class :■ Period;

END;

END perlodOrDotdot;

PROCEDURE endOfInput(c:CHAR); BEGIN

tok.class := EndOflnput;

END endOfInput;

(*** Initialization of charTable ***)

PROCEDURE InitCharTabIe;

BEGIN

enterAI 1(1 I IegaI Char); enterWhIte(Ignore); enterAIphasfidOrKeyword); enterDigits(poslnt);

enterChar(*. enterChar(*; enterChar(' ; enterChar(*( enterChar(*) enterChar(*, enterChar(’ = enterChar(*> enterChar(*< enterChar(’+ enterChar( enterChar(* * enterChar(’/ enterChar(* { enterCharf*" enterChar("* enterChar(* [ enterChar(* j

END

perlodOrDotdot); colon); semicoIon);

Iparen); rparen); comma); equaI); greater);

I ess); plus); minus); times); divide); comment); strIngProc); charProc);

I bracket); rbracket);

enterEndOfFiIe(endOfInput); initCharTabIe;

(*** errors ***)

PROCEDURE compError(msg:ARRAY OF CHAR); BEGIN

wr i teLine;

Wr iteLnString(msg); errorFlag :* TRUE;

158 BYTE LISTINGS SUPPLEMENT

m

END compError;

BEGIN

ungotten := FALSE; errorFlag := FALSE; initCharTabIe;

END LexAn.

Start Node.DEF

DEFINITION MODULE Node;

(* Nodes are what make up the parse tree produced by the SIMPL parser. They consist of all data relevant to generating code.

Changes for part 3:

1. setNodeType added so ExprParser.typeCoerce could change it.

*)

FROM Token IMPORT tokenClass;

FROM Symbol IMPORT symbol;

EXPORT QUALIFIED node, nodeClass, NodeClass, emptyNode, nodeEmpty, freeNode, makeStmtsNode, makelfNode, makeWhiIeNode, makeReturnNode, makeAssignmentNode, makeExprListNode, makeOpNode, makeUnopNode, makelntegerNode, makeBooIeanNode, makeSymboI Node, makeCaI I Node, makeWriteNode, makeReadNode, makeStringNode, makeCharNode, nodeFirst, nodeRest, nodeTest, nodeThen, nodeElse, nodeStmts, nodeRHS, nodeLHS, nodeArgs, nodeRoutine, nodeExpr, nodeArg, nodeLeftArg, nodeRightArg, nodeOp, nodeSymbol, nodeType, nodelnt, nodeBool, nodeNumFormaIs, nodeStrlng, nodeChar, setNodeType, nodeArray, nodeindex, makelndexNode;

TYPE

NodeClass * (* the different kinds of nodes *)

(nOp, nUnop, nBooI, nlnt, nChar, nString, nSymboI, nlf , nWhiIe, nReturn, nCaI I,

nAssignment, nWrite, nRead, nLlst, nlndex);

i* WRITE and READ statements *) (* a list of statements or expr (★ an array index *)

node;

VAR emptyNode: node;

PROCEDURE nodeClass(n:node):NodeCIass;

(* Returns the class of node *)

PROCEDURE nodeEmpty(n:node):B00LEAN;

(* Returns true if node is the emptyNode *)

PROCEDURE freeNode(n:node);

(* Frees the storage associated with n *)

(*** Node creation ***)

PROCEDURE makeStmtsNode(first, rest:node):node;

(* Make a node representing a list of statements *)

PROCEDURE makeReturnNode(routine:symboI; returnExpr:node):node;

(* Make a return node. Routine is the routine we are returning from.

returnExpr is an expression to be returned, for functions; for procedures,

(continued)

BYTE LISTINGS SUPPLEMENT 159

It should be the empty node, *)

PROCEDURE makeCoIINode(name:symboI; actuaIs:node):node;

PROCEDURE makeWrlteNode(actuaIsinode):node;

PROCEDURE makeReadNode(actuaIs:node):node;

(* In all of these, actuals should have been made with makeExprListNode. *)

PROCEDURE makeIfNode(test, then, e I se mode) mode;

PROCEDURE makeWhI IeNode(test, stmts:node):node;

PROCEDURE makeAssIgnmentNode(Ihs, expr:node):node;

PROCEDURE makeExprLIstNode(fIrst, rest:node):node;

PROCEDURE makeOpNode(op:tokenClass; leftarg, rIghtarg:node):node; PROCEDURE makeUnopNode(op:tokenCI ass; arg:node):node;

PROCEDURE makeIntegerNode(l:INTEGER):node;

PROCEDURE makeBooIeanNode(b:BOOLEAN):node;

PROCEDURE makeSymboINode(Id:symboI)inode;

PROCEDURE makeStringNode(s:ARRAY OF CHAR):node;

PROCEDURE makeCharNode(c:CHAR)inode;

PROCEDURE makeIndexNode(array, Indexinode)inode;

(*** Accessing parts of nodes **)

(* many nodes have a type associated with them *) PROCEDURE nodeType(ninode):symboI;

PROCEDURE setNodeType(n:node; typeObject:symbo1);

(* for constants *)

PROCEDURE nodelnt(n:node):INTEGER;

PROCEDURE nodeBool(n:node)iBOOLEAN;

PROCEDURE nodeChar(ninode)iCHAR;

PROCEDURE nodeStrIng(n:node; VAR s:ARRAY OF CHAR); (* Just truncates is s is too short. *)

(* for 1 Ists *)

PROCEDURE nodeFirst(n:node):node;

PROCEDURE nodeRest(ninode)inode;

(* for IF statements *)

PROCEDURE nodeTest(n:node):node;

PROCEDURE nodeThen(n:node):node;

PROCEDURE nodeEIse(n:node)inode;

(* for WHILE statements *)

PROCEDURE nodeStmts(nmode)inode;

(* for assignment statements *)

PROCEDURE nodeRHSfn:node):node;

PROCEDURE nodeLHS(n:node):node;

(* for calls *)

PROCEDURE nodeArgs(nmode) inode;

PROCEDURE nodeRoutine(n:node):symboI;

(* for RETURN statements *)

PROCEDURE nodeExpr(mnode) inode;

PROCEDURE nodeNumFormaIs(n:node):CARDINAL;

(* for ops and unops *)

PROCEDURE nodeArg(n:node):node;

PROCEDURE nodeLeftArg(n:node):node;

PROCEDURE nodeRightArg(n:node):node;

PROCEDURE nodeOp(n:node):tokenClass;

(* also for WHILE statements *)

(* right-hand side *) (* left-hand side *)

(* for symbols *)

PROCEDURE nodeSymboI(n:node):symboI;

(* for array indexing *)

PROCEDURE nodeArray(n mode) mode; PROCEDURE nodeIndex(nmode) mode;

END Node.

Start Node.MOD IMPLEMENTATION MODULE Node;

160 BYTE LISTINGS SUPPLEMENT

(* Procedures for constructing and manipulating the nodes of the parse tree.

Most type-checking is done here. *)

FROM Token IMPORT tokenClass, stringType, isRelation;

FROM Symbol IMPORT symbol, Class, emptySymbol, numFormals, symbolList, sISymbol, slEmpty, sINext;

IMPORT Symbol;

FROM SymboI Tab Ie IMPORT tUnknown, tString, tlnteger, tChar, tBoolean;

FROM Storage IMPORT ALLOCATE, DEALLOCATE;

FROM TypeChecker IMPORT typeCompatibIe, opAppropriate, callCheck, unopCheck, readCheck, writeCheck, binopCheck, returnCheck, assignCheck, baseType;

FROM MyTerminal IMPORT WriteString, fatal;

FROM StringStuff IMPORT stringCopy;

TYPE

node = POINTER TO nodeRec; nodeRec = RECORD

type: symbol;

CASE cI ass:NodeCIass OF

nOp: op; tokenClass; leftArg, rightArg: node;

nUnop: unop: tokenClass; arg: node;

nBool: bool: BOOLEAN;

nlnt; int: INTEGER;

nChar: ch: CHAR;

nString: string:stringType;

nSymbol: sym: symbol;

nlf: test, then, else: node;

nWhile: wtest, stmts: node;

nAssignment: LHS, RHS:node;

nCall, nWrite, nRead: routine:symboI; args:node; nReturn: nFormaIs:CARDINAL; expr:node; nList: first, rest:node; nlndex: array, index:node;

END;

END;

PROCEDURE nodeCI ass(n:node):NodeClass;

BEGIN

RETURN n^.class;

END nodeCI ass;

PROCEDURE nodeEmpty(n:node):BOOLEAN;

BEGIN

RETURN n *= emptyNode;

END nodeEmpty;

PROCEDURE freeNode(n:node);

BEGIN

IF n <> emptyNode THEN

WITH n~ DO CASE class OF

nlnt, nBool, nSymbol, nString, nChar: (* do nothing *); | nOp: freeNode(IeftArg);

freeNodefrightArg); nUnop: freeNode(arg);

| nlf: freeNodeftest);

freeNode(then); freeNode(eIse);

| nWhile: freeNode(wtest);

freeNode(stmts);

| nAssignment: freeNode(LHS);

freeNode(RHS);

nCall, nRead, nWrite: freeNode(args); nReturn:freeNodefexpr); nList: freeNode(f1rst);

freeNodefrest);

| nlndex: freeNode(array);

f reeNode(index);

ELSE

WriteString("freeNode: unknown node type");

END; END;

DISPOSE(n); (* , n A .class); *)

END;

END freeNode;

(continued)

BYTE LISTINGS SUPPLEMENT 161

(*** node creation ***)

PROCEDURE makeStmtsNode(fIrst, restinode);node;

VAR n:node;

BEGIN

n :■ newNode(nLIst); n*.first :« first; n^.rest :■ rest;

RETURN n;

END makeStmtsNode;

PROCEDURE makeExprLIstNode(f1 rst, rest:node);node;

VAR ninode;

BEGIN

n := newNode(nList); n*.first :* first; n^.rest :■* rest;

RETURN n;

END makeExprListNode;

PROCEDURE makelfNode(test, then, eIse:node):node;

VAR ninode;

BEGIN

n := newNode(nIf); n^.test ;= test; n^.then i* then; n^.else i» else;

RETURN n;

END makelfNode;

PROCEDURE makeWhlIeNode(test, stmtsinode)inode;

VAR ninode;

BEGIN

n := newNode(nWhI Ie); n^.wtest :* test; n*.stmts i■ stmts;

RETURN n;

END makeWhI IeNode;

PROCEDURE makeReturnNode(routIneisymbol; returnExprinode)inode;

VAR ninode;

BEGIN

n i« newNode(nReturn); n^.expr i« returnExpr;

IF returnCheck(routIne, returnExpr) THEN n^.nFormals := sIzeFormaIs(routlne);

END;

RETURN n;

END makeReturnNode;

PROCEDURE sizeFormaIs(routine:symboI)iCARDINAL;

(* Returns the number of words occupied by formals. Before this was just the number of formals, but now each open array pnram adds 2 to the count (For its bounds.) *)

VAR form I Ist:symboIList; sum:CARDINAL; tisymboI;

BEGIN

formlist i« SymboI.forma Is(routine); sum ;« 0;

WHILE NOT slEmpty(formlist) DO

t i= SymboI.type(sISymboI(formIist));

IF (Symbol.class(t) * ArrayType) AND Symbol.open(t) THEN INC(sum, 3);

ELSE

INC(sum);

END;

formlist i= sI Next(form Iist);

END;

RETURN sum;

END sizeFormals;

PROCEDURE makeAssignmentNode(Ihs, exprinode)inode:

VAR ninode;

BEGIN

n i* newNode(nAssignment);

162 BYTE LISTINGS SUPPLEMENT

n^.LHS := Ihs;

n^.RHS := expr;

assignCheck(Ihs, expr);

RETURN n;

END makeAssignmentNode;

PROCEDURE makeOpNode(op:tokenCIass; leftarg, rightarg:node):node; VAR ninode;

typeOK:BOOLEAN;

BEGIN

n := newNode(nOp); n^.op := op; n^.leftArg := leftarg; n^.rightArg :« rightarg;

typeOK := binopCheck(op, leftarg, rightarg);

IF isReI ation(op) THEN n^.type :* tBoolean;

ELSIF typeOK THEN

n^.type Ieftarg*.type;

ELSE

n^.type := tUnknown;

END;

RETURN n;

END makeOpNode;

PROCEDURE makeUnopNode(op:tokenClass; arg:node)inode;

VAR ninode;

BEGIN

n i= newNode(nUnop); n^.unop i* op; n^.arg ;= arg;

IF unopCheck(op, arg) THEN n^.type ;■ arg*.type;

ELSE

n*.type :* tUnknown;

END;

RETURN n;

END makeUnopNode;

PROCEDURE makeIntegerNode(i;INTEGER)inode;

VAR n;node;

BEGIN

n !« newNode(nInt); n*.type := tlnteger; n*.int := I;

RETURN n;

END makelntegerNode;

PROCEDURE makeBooIeanNode(biBOOLEAN)inode;

VAR n;node;

BEGIN

n i* newNode(nBooI); n*.type i= tBoolean; n*.bool i*= b;

RETURN n;

END makeBooIeanNode;

PROCEDURE makeCharNode(ciCHAR)inode;

VAR n;node;

BEGIN

n ;« newNode(nChar); n*.type tChar; n*.ch i* c;

RETURN n;

END makeCharNode;

PROCEDURE makeSymboINode(s:symboI)inode;

VAR ninode;

BEGIN

n i* newNode(nSymboI); n*.type :« SymboI.type(s); n*.sym :■ s;

RETURN n;

END makeSymboINode;

( continued )

BYTE LISTINGS SUPPLEMENT 163

PROCEDURE makeCalINode(name:symboI; actuaI 8mode)inode; VAR ninode;

BEGIN

n newNode(nCaI I);

WITH n* DO

routine :■ name;

args actuals;

type :■ SymboI.type(name);

caIICheck(routine, args);

END;

RETURN n;

END makeCalINode;

PROCEDURE makeWrIt©Node(actuals:node):node;

VAR ninode;

BEGIN

wr I teCheck(actuaIs); n ;» newNode(nWrIte); n~.routine :* emptySymbol; n^.args actuals;

RETURN n;

END makeWrIteNode;

PROCEDURE makeReadNode(actuaIs:node):node;

VAR ninode;

BEGIN

readCheck(actuaIs); n :■ newNode(nRead); n*.routine :« emptySymbol; n^.args :■ actuals;

RETURN n;

END makeReadNode;

PROCEDURE makeStringNode(s:ARRAY OF CHAR):node;

VAR ninode;

BEGIN

n ;■ newNode(nStrIng); strIngCopy(n*.strIng, s); n^.type i* tStrlng;

RETURN n;

END makeStrIngNode;

PROCEDURE makeIndexNode(array, Indexmode) inode;

VAR ninode;

BEGIN

n !■ newNode(nlndex);

IF SymboI.empty(nodeType(array)) THEN n^.type i« emptySymbol;

ELSE

n^.type i* baseType(SymboI.type(nodeType(array)));

END;

n^.array i- array; n^.index i* index;

RETURN n;

END makelndexNode;

PROCEDURE newNode(nciNodeCI ass)inode;

VAR ninode;

BEGIN

NEW(n); (* nc); *) n^.class ;■ nc; n^.type i* tUnknown;

RETURN n;

END newNode;

(*** node access ***)

PROCEDURE nodelnt(ninode)iINTEGER;

BEGIN

nodeCIassCheck('nodeInt•, n, nlnt);

RETURN n^.int;

END nodelnt;

PROCEDURE nodeBool(ninode)iBOOLEAN;

BEGIN

nodeClassCheck('nodeBool*, n, nBool);

164 BYTE LISTINGS SUPPLEMENT

RETURN n^.bool;

END nodeBooI;

PROCEDURE nodeChar(n:node):CHAR;

BEGIN

nodeCIassCheck('nodeChar', n, nChar);

RETURN n^.ch;

END nodeChar;

PROCEDURE nodeStrlng(ninode; VAR s:ARRAY OF CHAR);

BEGIN

nodeCIassCheck('nodeString', n, nString); stringCopy(s, n~.string);

END nodeStrlng;

PROCEDURE nodeFirst(ninode)inode;

BEGIN

nodeCIassCheck('nodeFirst', n, nList);

RETURN n".first;

END nodeFirst;

PROCEDURE nodeRest(ninode)inode;

BEGIN

nodeCIassCheck('nodeRest*, n, nList);

RETURN n~.rest;

END nodeRest;

PROCEDURE nodeTest(n:node):node;

BEGIN

IF n^.class = nlf THEN RETURN n*.test;

ELSIF n".class « nWhile THEN RETURN n^.wtest;

ELSE

nodeCIassError('nodeTest');

RETURN emptyNode;

END;

END nodeTest;

PROCEDURE nodeThen(n:node):node;

BEGIN

nodeCIassCheck('nodeThen', n, nlf);

RETURN n*.then;

END nodeThen;

PROCEDURE nodeEIse(n:node);node;

BEGIN

nodeCIassCheck('nodeEIse', n, nlf);

RETURN n^.else;

END nodeEIse;

PROCEDURE nodeStmts(n:node)inode;

BEGIN

nodeClassCheck('nodeStmts*, n, nWhile);

RETURN n".stmts;

END nodeStmts;

PROCEDURE nodeRHS(ninode)inode;

BEGIN

nodeCIassCheck('nodeRHS', n, nAssignment);

RETURN n^.RHS;

END nodeRHS;

PROCEDURE nodeLHS(ninode)inode;

BEGIN

nodeClassCheck('nodeLHS', n, nAssignment);

RETURN n^.LHS;

END nodeLHS;

PROCEDURE nodeArgs(nmode) inode;

BEGIN

WITH n* DO

IF (class ■ nCall) OR (class » nRead) OR (class = nWrite) THEN RETURN args;

ELSE

(continued)

BYTE LISTINGS SUPPLEMENT 165

nodeClassError('nodeArgs’);

END;

END;

END nodeArgs;

PROCEDURE nodeRoutIne(nmode)isymbol;

BEGIN

nodeCIassCheck(*nodeRoutine' , n, nCaII); RETURN n*.routine;

END nodeRoutIne;

PROCEDURE nodeExpr(n:node):node;

BEGIN

nodeClassCheck(*nodeExpr', n, nReturn); RETURN n^.expr;

END nodeExpr;

PROCEDURE nodeArg(n:node)mode;

BEGIN

nodeCIassCheck(*nodeArg', n, nUnop); RETURN n^.arg;

END nodeArg;

PROCEDURE nodeLeftArg(n:node)inode;

BEGIN

nodeCIassCheck('nodeLeftArg*, n, nOp); RETURN n".leftArg;

END nodeLeftArg;

PROCEDURE nodeRightArg(n:node):node;

BEGIN

nodeClassCheck('nodeRightArg’, n, nOp); RETURN n*.rIghtArg;

END nodeRightArg;

PROCEDURE nodeOp(n;node):tokenCIass;

BEGIN

IF n".class - nOp THEN RETURN n^.op;

ELSIF n^.class * nUnop THEN RETURN n^.unop;

ELSE

nodeCIassError('nodeOp');

RETURN Plus;

END;

END nodeOp;

PROCEDURE nodeSymboI(n:node):symboI;

BEGIN

nodeCIassCheck('nodeSymboI', n, nSymbol); RETURN n^.sym;

END nodeSymbol;

PROCEDURE nodeArray(nmode):node;

BEGIN

nodeCIassCheck("nodeArray", n, nlndex); RETURN n".array;

END nodeArray;

PROCEDURE nodeIndex(n:node):node;

BEGIN

nodeClassCheck("nodeIndex", n, nlndex); RETURN n".Index;

END nodeindex;

PROCEDURE nodeNumFormaIs(n mode):CARDINAL;

BEGIN

nodeClassCheck('nodeNumFormals*, n, nReturn); RETURN n^.nFormals;

END nodeNumFormaIs;

PROCEDURE nodeType(n:node)rsymbol;

BEGIN

RETURN n*.type;

END nodeType;

166 BYTE LISTINGS SUPPLEMENT

PROCEDURE setNodeType(ninode; typeObjectisymboI);

BEGIN

n^.type :* typeObject;

END setNodeType;

(*** other ***)

PROCEDURE nodeCIassCheck(s:ARRAY OF CHAR; ninode; nciNodeCIass); BEGIN

IF n^.class <> no THEN nodeCIassError(s);

END;

END nodeCIassCheck;

PROCEDURE nodeCIassError(s:ARRAY OF CHAR);

BEGIN

Wr i teStrIng(s);

fatal(": node of wrong type");

END nodeCIassError;

BEGIN

emptyNode :* NIL; END Node.

Start Parser.DEF

DEFINITION MODULE Parser;

(* This Is the bulk of the SIMPL parser. It covers most of the language. For routines (procedures and functions) see Routines.

For expressions, see ExprParser.

Syntax handled by this module:

/

<program> PROGRAM <id>; <vars> <routines> <block> .

<types> <empty> | TYPE <typelist>

<typelist> <tvpedecl> | <typedecl> <typelist>

<typedecl> <id> * <type> ;

<type> <id> | ARRAY [ <int> .. <int>] OF <type>

<vars> ::= <empty> | VAR <varlist>

<varlist> <decl> | <decl> <varlist>

<decl> <IdI Ist> : <type> ;

<idlist> <id> | <id> . <1dI Ist>

<block> BEGIN <stmts> END

<stmts> ::* <empty> | <stmt> ; <stmts>

<stmt> <whlle> | <if> | <return> | <assign> | <caI I>

<while> WHILE <expr> DO <stmts> END

<if> ::«= IF <e I s I f> END

<eIsif> <expr> THEN <stmts> <else>

<else> <empty> | ELSIF <eIsIf> | ELSE <stmts>

<return> RETURN | RETURN <expr>

<assign> <idOrindex> <expr>

<caI I> <id> <actuals>

<actuals> <empty> | ( <exprlist> )

<exprlist> <expr> | <expr> , <exprllst>

*)

FROM Symbol IMPORT symbol;

FROM Node IMPORT node;

FROM Token IMPORT tokenList;

EXPORT QUALIFIED program, types, vars, Idlist, block, actuals;

PROCEDURE program;

(* Parse the entire program *)

{continued)

BYTE LISTINGS SUPPLEMENT 167

PROCEDURE types(routineName:symbol);

(* Parse type declarations. See below for explanation of routineName. *) PROCEDURE vars(routineName:symboI);

(* Parse variable declarations. RoutineName is the name of the routine currently being compiled; if these are global variables, it should be the name of the program. *)

PROCEDURE Idlist():tokenLIst;

(* Parse a list of identifiers *)

PROCEDURE block(routine:symboI)inode;

(* Parse a block of code. Routine is the routine currently being compiled. *) PROCEDURE actuaIs()mode;

(* Parse a list of actual parameters, l.e. a list of expressions. *)

END Parser.

Start Parser.MOD

IMPLEMENTATION MODULE Parser;

(* Most of the parser for the SIMPL compiler. It is a top-down, recursive descent parser.

Changes for part 3:

1. Type declarations and arrays are parsed.

2. Type objects used instead of the old typeType.

*)

FROM Token IMPORT token, tokenClass, emptyTokenList, stringType,

tIToken, tINext, tIEmpty, addToTokenList, tokenList, freeTokenList;

FROM LexAn IMPORT getToken, getTokenCI ass, peekTokenCI ass, compError, ungetToken, tokenErrorCheck, getTokenErrorCheck;

FROM Symbol IMPORT symbol, emptySymbol, isType, Class;

IMPORT Symbol;

FROM SymbolTable IMPORT enterSymbol, enterLocal, enterFormal, findSymbol, currentLexLeveI, tUnknown, enterArrayType;

FROM Node IMPORT node, emptyNode, makeStmtsNode, makelfNode, makeWhiIeNode, makeReturnNode, makeAssignmentNode, makeExprListNode, makeCaI I Node, makcReadNode, makeWriteNode, nodeType, makeSymboI Node;

FROM CodeGon IMPORT genBleck, genGlobal;

FROM CodeWrite IMPORT writeStringBranch, writeHalt, writeRoutIneLabeI, wr iteStrings;

FROM TypeChecker IMPORT boolCheck, assignable;

FROM ExprParser IMPORT expr, idOrlndex;

FROM Routines IMPORT routines;

FROM MyTerminal IMPORT fatal;

VAR programName:symboI;

(* <program> :PROGRAM <id>; <types> <vars> <routines> <block> . *) PROCEDURE program;

VAR t:token;

ninode;

BEGIN

tokenErrorCheck(Program, ’keyword "PROGRAM" expected*); getTokenErrorCheck(t, Identifier, ’name of program expected');

IF t.class <> Identifier THEN

t.string := "???"; (* if the program name isn't given, make one up *

END;

programName := enterSymboI(t.string, Proc, tUnknown); wr iteStringBranch(t.string);

tokenErrorCheck(SemicoI on, 'semicolon expected’); types(emptySymboI); vars(emptySymboI); routines;

writeRoutineLabeI(programName); genBlock(block(programName));

168 BYTE LISTINGS SUPPLEMENT

tokenErrorCheck(Period, 'period expected*); tokenErrorCheck(EndOfInput, ’end of input expected*); writeHaIt; wr iteStrings;

END program;

(*** type declarations ***)

(* <types> <empty> | TYPE <typelist> *)

PROCEDURE types(routineName:symboI);

BEGIN

IF getTokenCIass() = Type THEN typelist(routineName);

ELSE

ungetToken;

END;

END types;

(* <typelist> <typedecl> | <typedecl> <typelist> *)

PROCEDURE type Iist(rout 1neName:symboI);

BEGIN

typedecI(routineName);

IF peekTokenCIass() = Identifier THEN typelist(routineName);

END;

END typelist;

(* <typedecl> :<id> = <type> ; *)

PROCEDURE typedecI(routineName:symboI);

VAR typeToken:token;

typeObject;symboI;

BEGIN

getToken(typeToken);

IF typeToken.cI ass <> Identifier THEN compError(* identifier expected’); ungetToken;

typeToken.string :* *???*; (* make up a type name *)

END;

tokenErrorCheck(EquaI, ’equal sign expected’); typeObject :« type();

IF NOT Symbol.empty(typeObject) THEN

IF Symbol.class(typeObject) * ArrayType THEN

hand IeArray Type(typeToken.string, typeObject);

ELSIF SymboI.cIass(typeObject) = ScalarType THEN

typeObject := enterSymboI(typeToken.string, Sea IarType,typeObject);

ELSE

(* do nothing—error caught in type() *)

END;

END;

tokenErrorCheck(SemicoIon, "semicolon expected");

END typedecI;

PROCEDURE hand IeArrayType(VAR s:stringType; typeObject:symboI);

(* If the array type hasn't been named, name it and insert it; else, copy it and give the copy the new name. *)

VAR typeName:stringType;

BEGIN

IF SymboI.anonymous(typeObject) THEN enterArrayType(s, typeObject);

ELSE

enterArrayType(s, SymboI.copyArrayType(typeObject));

END;

END hand IeArrayType;

(* <type> <id> | ARRAY [ Int .. Int ] OF <type> *)

PROCEDURE type():symboI;

VAR t:token;

typeSymbol;symboI;

BEGIN

getToken(t);

IF t.class = Identifier THEN

typeSymbol :■ fIndSymboI(t.string);

IF isType(typeSymbol) THEN RETURN typeSymbol;

ELSE

(continued)

BYTE LISTINGS SUPPLEMENT 169

compError('not a type*);

RETURN tUnknown;

END;

ELSIF t.class ■ Array THEN

tokenErrorCheck(Lbracket, "left bracket expected"); RETURN type1();

ELSE

compError("Identifler or ARRAY expected"); ungetToken;

RETURN tUnknown;

END;

END type;

PROCEDURE typel():symboI;

VAR t:token;

IowBound, highBound, temp;INTEGER; BEGIN

lowBound :■ getBound();

tokenEr rorCheck(DotDot, *two dots expected*); highBound :« getBound();

IF lowBound > highBound THEN

compError("lowBound > highBound"); temp :■ lowBound; lowBound :« highBound; highBound :■ temp;

END;

getToken(t);

IF t.cl ass « Comma THEN

RETURN Symbol.newArrayType(type1(), lowBound, highBound, FALSE,

currentLexLeveI ());

ELSIF t.class « Rbracket THEN

tokenErrorCheck(Of, *0F expected*);

RETURN Symbol.newArrayType(type(), lowBound, highBound, FALSE, currentLexLeveI());

ELSE '

compError("Comma or right bracket expected");

ungetToken;

RETURN tUnknown;

END;

END typel;

PROCEDURE getBound():INTEGER;

(* Reads In an integer, possibly negative. *)

VAR t;token;

BEGIN

getToken(t);

IF t.class * Int THEN RETURN t. integer;

ELSIF t.class » Minus THEN

getTokenErrorCheck(t, Int, "integer expected"); RETURN -t.integer;

ELSE

ungetToken;

compError("integer expected");

RETURN 0;

END;

END getBound;

(*** variable declarations ***)

(* <vars> <empty> | VAR <varlist> *)

PROCEDURE vars(routineName:symboI);

3EGIN

IF getTokenCIass() = Var THEN varIist(routineName);

ELSE

ungetToken;

END;

iND vars;

(* <varIist> ;<decl> | <decl> <varlist>

We can recognize the end of a varlist by seeing if the next token is an identifier. An Id indicates the varlist continues. If it didn’t we’d see a keyword: either Begin, Procedure or Function. *)

5 R0CEDURE varIist(routineName:symboI);

3EGIN

70 BYTE LISTINGS SUPPLEMENT

dec I(routineName);

IF peekTokenCIass() = Identifier THEN varIist(routineName);

END;

END varIist;

(* <decl> ::= <IdIist> : <type> ;

Declarations. All the work of putting information about the variables into the symbol table is done here. *)

PROCEDURE dec I(routineName:symboI);

VAR tl, tokenp:tokenList; t, id:token;

typeSymbol:symboI;

BEGIN

tl := idl1st();

tokenErrorCheck(CoIon, ’colon expected*); typeSymbol := type();

tokenErrorCheck(SemicoIon, ’semicolon expected’); tokenp := tI;

(* Enter the variables into the symbol table. For globals, also generate the variables. *)

WHILE NOT tlEmpty(tokenp) DO tIToken(tokenp, id);

IF currentLexLeveI() » 0 THEN

genGlobal(enterSymbol(id.string, Global, typeSymbol));

ELSE

enterLocaI(id.string, typeSymbol, routineName);

END;

tokenp :*= 11 Next (tokenp) ;

END;

freeTokenList(tI);

END dec I;

(* <idlist> <id> | <id> , <idIist> *)

PROCEDURE idlist():tokenList;

VAR t: token;

BEGIN

getTokenErrorCheck(t, Identifier, ’identifier expected’);

IF getTokenClass() <> Comma THEN (* this is the end of the Idli31 *) ungetToken;

IF t.class = Identifier THEN

RETURN addToTokenList(t, emptyTokenList);

ELSE

RETURN emptyTokenList;

END;

(* we saw a comma, so there’s more *)

ELSIF t.class = Identifier THEN

RETURN addToTokenLIst(t, idlist());

ELSE

RETURN idlist();

END;

END idlist;

(*** blocks and statements ***)

(* <block> ;BEGIN <stmts> END *)

PROCEDURE bIock(routine:symboI);node;

VAR ninode;

BEGIN

tokenErrorCheck(Begin, ’BEGIN expected’); n :* stmts(routine);

tokenErrorCheck(End, ’"END" expected*);

RETURN n;

END block;

(* <stmts> <empty> | <stmt> ; <stmts>

We can recognize an empty <stmts> by seeing if the next token is ELSE, ELSIF or END. *)

PROCEDURE stmts(routineisymbol):node;

VAR ninode;

tcitokenCI ass;

BEGIN

tc peekTokenClass();

IF (tc - Else) OR (tc - Elsif) OR (tc - End) THEN RETURN emptyNode;

{continued)

BYTE LISTINGS SUPPLEMENT 171

ELSE

n :■ stmt(routIne);

tokenErrorCheck(Semlcolon, 'a semicolon must end a statement*); RETURN makeStmtsNode(n, stmts(routIne));

END;

END stmts;

(* <stmt> <whfle> I <!f> | <return> | <assign> | <caI I> |

<wrlte> I <read> *)

PROCEDURE stmt(routine:symbol):node;

VAR t:token;

BEGIN

getToken(t);

CASE t.cl ass OF

If: RETURN IfStmt(rout Ine);

While: RETURN whlleStmt(routIne) ;

Return: RETURN returnStmt(routine);

IF SymboI.equaI(routine, programName) THEN

compError("can*t return from main program");

ELSE

RETURN makeReturnNode(routIne, expr());

END;

Write: RETURN makeWrlteNode(actuaIs());

Read: RETURN makeReadNode(readActuaIs());

Identifier: RETURN assignOrCaI I Stmt(t);

ELSE

compError(*iI IegaI statement type*);

RETURN emptyNode;

END;

END stmt;

(* <if> IF <eIsif> END *)

PROCEDURE IfStmt(routine:symboI):node;

VAR n:node;

BEGIN

n :** elsif (rout ine);

tokenErrorCheck(End, *END expected*);

RETURN n;

END ifStmt;

(* <elsif> <expr> THEN <stmts> <else> *)

PROCEDURE eIsif(rout Ine:symboI):node;

VAR nl, n2:node;

BEGIN

nl :* expr(); boolCheck(nl);

tokenErrorCheck(Then, *THEN expected*); n2 :- stmts(routine) ;

RETURN makeIfNode(n1, n2, eIse(routine));

END elsif;

(* <else> ::=* <empty> | ELSIF <e I s i f > | ELSE <stmts>

We can tell an <else> is empty by seeing if the next token is END. *) PROCEDURE eIse(routine:symboI):node;

BEGIN

CASE getTokenCIass() OF End: ungetToken;

RETURN emptyNode;

Elsif: RETURN makeStmtsNode(eIsif(routine), emptyNode);

Else: RETURN stmts(routine);

ELSE

compError(’END, ELSIF or ELSE expected’); ungetToken;

RETURN emptyNode;

END;

END else;

(* <while> WHILE <expr> DO <stmts> END *)

PROCEDURE whI IeStmt(routine:symboI):node;

VAR n:node;

BEGIN

n :« expr() ; booICheck(n);

tokenErrorCheck(Do, *D0 expected*); n :«= makeWhiIeNode(n, stmts (rout i ne) ) ;

172 BYTE LISTINGS SUPPLEMENT

tokenErrorCheck(End, ’END expected’);

RETURN n;

END whileStmt;

(* <return> RETURN | RETURN <expr> *)

PROCEDURE returnStmt(routinersymboI)mode;

BEGIN

IF Symbol.equal(routine, programName) THEN

compError("can*t return from main program");

END;

IF peekTokenCIass() * Semicolon THEN

RETURN makeReturnNode(routine, emptyNode);

ELSE

RETURN makeReturnNode(routine, expr());

END;

END returnStmt;

(* We can’t distinguish an assignment from a call based on the first token of the statement, since in both cases it’s an identifier. The next token, though, will distinguish: it’s an assignment sign or a left bracket for an assignment. *)

PROCEDURE assignOrCalIStmt(t:token)mode;

VAR tc:tokenCIass;

BEGIN

c := peekTokenClass();

IF (tc = Assignment) OR (tc - Lbracket) THEN RETURN assignStmt(t);

ELSE

RETURN calIStmt(t);

END;

END assignOrCaIIStmt;

(* <asslgn> <id0rlndex> :■ <expr> *)

PROCEDURE assignStmt(varName:token)mode;

VAR nmode;

BEGIN

n :« id0rlndex(findSymbol(varName.string));

IF NOT assignable(n) THEN

compError(’cannot assign to this*); tokenErrorCheck(Assignment, expected");

RETURN expr(); (* consume the expression anyway *)

ELSE

tokenErrorCheck(Assignment, expected");

RETURN makeAss1gnmentNode(n, expr());

END;

END assignStmt;

(* <caI I> <id> <actuals> *)

PROCEDURE cal I Stmt(rout 1neName:token)mode;

VAR procrsymboI;

BEGIN

proc :« findSymbol(routIneName.string);

IF NOT Symbol.classEqual(proc, Proc) THEN

compError('on Iy procedures can be used in a call statement’);

RETURN actualsQ; (* consume the actuals anyway *)

ELSE

RETURN makeCaIINode(proc, actuals());

END;

END calIStmt;

(* <actuals> <empty> | ( <exprlist> )

We can recognize an empty <actuals> by seeing if the next character is a left parenthesis. *)

PROCEDURE actuals():node;

VAR nmode;

BEGIN

IF getTokenClass() - Lparen THEN n :■ exprIIst();

tokenErrorCheck(Rparen, ’right paren expected*);

RETURN n;

ELSE

ungetToken;

RETURN emptyNode;

END;

END actuals;

( continued)

BYTE LISTINGS SUPPLEMENT 173

(* <expr11st> <expr> | <expr> , <exprlist>

Exprlist always returns an nUst node, even if there's only one expr. *) PROCEDURE exprI 1st():node;

VAR n:node;

BEGIN

n :* expr() ;

IF getTokenCIass() - Comma THEN

RETURN makeExprListNode(n, exprllst());

ELSE

ungetToken;

RETURN makeExprListNode(n, emptyNode);

END;

END exprIist;

(* These two procedures are for the args to READ *)

PROCEDURE readActuaIs():node;

VAR n:node;

BEGIN

IF getTokenCIass() - Lparen THEN n :■ readExprI Ist();

tokenErrorCheck(Rparen, 'right paren expected*);

RETURN n;

ELSE

ungetToken;

RETURN emptyNode;

END;

END readActuals;

PROCEDURE readExprI Ist():node;

VAR t;token;

n:node;

BEGIN

getTokenErrorCheck(t, Identifier, "identifier expected"); n :* id0rlndex(findSymbol(t.string));

IF getTokenClass() = Comma THEN

RETURN makeExprListNode(n, readExprIist());

ELSE

ungetToken;

RETURN makeExprListNode(n, emptyNode);

END;

END readExprlist;

BEGIN

END Parser.

Start Routines.DEF

DEFINITION MODULE Routines;

(* The part of the parser that deals with procedures and functions. Syntax:

<routines> ::= <empty> | <proc> <routines> | <func> <routines> <proc> procedure <id> <formals> ; <vars> <block> ;

<func> ::= function <id> <formals> : <id> ; <vars> <block> ;

<formaIs> <empty> | ( <formlist> )

<formlist> :<formdecl> | <formdecl> ; <formlist>

<formdecI> :<idIist> : <mode> <typeld>

<mode> ::= <empty> | IN | OUT | IN OUT <typeld> <id> | ARRAY OF <id>

Changes for part 3:

1. Modes handled.

2. Open array parameters handled.

*)

EXPORT QUALIFIED routines;

174 BYTE LISTINGS SUPPLEMENT

PROCEDURE routines; END Routines.

Start Routines.MOD

IMPLEMENTATION MODULE Routines;

(* The part of the parser that handles procedures and functions.

There are basically two things that have to be done: the routine declarations have to be processed to yield symbol table entries, and the code for the routine bodies has to be generated. The lists of formal parameters (arguments) and locals variables are placed in the appropriate slots in the symbol table entry for the routine. For functions, the return type of the function is put in the type slot of the symbol; for procedures, this slot is left undefined. An offset from the stack pointer is given to each local and formal. The initial offsets assume the following stack conventions:

FP->

arg 1 arg 2

oidFP

SP

return loc 1 loc 2

stack grows down towards low memory

The list of formals must be backwards to match the argument conventions.

The order of the locals doesn’t matter, but it’s also backwards.

We generate code as if for a block, with two exceptions: at the beginning, we have to push enough words to move the stack pointer past the local storage area; while we are at it, we initialize the words to 0. At the end, we generate a return, in case the user didn’t. For procedures, it is okay to return by falling off the end. For functions, something has to be returned explicitly; it is an error to fall through.

Changes for part 3:

1. Formal parameter modes handled.

2. Arrays handled. Always passed by reference; starting address passed.

3. Open array params handled. The bounds get offsets just below the starting address.

*)

FROM Token IMPORT token, tokenClass,

tokenList, tIEmpty, 11 Next, tIToken, freeTokenList;

FROM LexAn IMPORT getToken, getTokenCI ass, ungetToken, tokenErrorCheck, getTokenErrorCheck, compError, peekTokenCI ass;

FROM Symbol IMPORT symbol, isType, symbol List, si Next, si Symbol, si Empty, Class, numLocals, modeType, newArrayType;

IMPORT Symbol;

FROM SymbolTable IMPORT enterSymbol, enterFormal, beginRoutine, endRoutine, tUnknown, findSymbol, currentLexLeveI;

FROM CodeGen IMPORT genBlock, genLocals;

FROM CodeWrite IMPORT writelnt, writeFReturn, writeReturn, writeRoutIneLabeI, writeStrings;

FROM Parser IMPORT vars, types, idlist, block;

FROM Node IMPORT node;

CONST

In 11la ILocalOffset - -1; (* offsets, In words, from the FP *)

inltlalFormalOffset ■ 3;

(* <routlnes> :<empty> | <proc> <routines> | <func> <routines> *)

PROCEDURE routines;

BEGIN

[continued)

BYTE LISTINGS SUPPLEMENT 175

February

LOOP

CASE getTokenCIass() OF Procedure: proc;

| Function: func;

ELSE ungetToken; EXIT;

END;

END;

END routines;

(* <proc> procedure <id> <formals> ; <types> <vars> <routlnes> <block> PROCEDURE proc;

VAR t:token; s:symboI; i:CARDINAL;

BEGIN

getTokenErrorCheck(t, Identifier, 'procedure name expected*); s :*= enterSymbol (t.string, Proc, tUnknown); beginRoutine(s); forma Is(s);

tokenErrorCheck(SemicoI on, 'semicolon expected*);

types(s);

locaIs(s);

routines;

writeRoutineLabeI(s); genLocaIs(s); genBlock(block(s)); writeReturn(sizeFormals(s)); wr iteStrings;

tokenErrorCheck(Semicolon, 'semicolon expected*); endRoutlne(s);

END proc;

(* <func> ::=• function <id> <formaIs>:<id>; <vars> <routines> <block>; *) PROCEDURE func;

VAR fname, ftype:token; s, typeSymboI:symboI; i:CARDINAL;

BEGIN

getTokenErrorCheck(fname, Identifier, ’function name expected'); s := enterSymboI(fname.string, Func, tUnknown); beginRoutine(s); forma Is(s);

tokenErrorCheck(Colon, ’colon expected'); typeSymboI :■ typeName();

IF SymboI.cI ass(typeSymboI) <> ScalarType THEN

compError("functions can only return scalar types");

END;

tokenErrorCheck(SemicoIon, 'semicolon expected');

SymboI.setType(s, typeSymbol);

types(s);

locals(s);

rout 1nes;

writeRoutineLabel(s);

genLocaIs(s);

genBIock(block(s));

(* Here we should generate an error message in the code: value not returned from function. But since we have no string manipulation, we can’t. Instead we'll return either 0 (for an Integer function) or false (which is also 0) for a boolean function. *) wr itelnt(0);

writeFReturn(sizeFormaIs(s)); wr i teStrings;

tokenErrorCheck(SemicoIon, 'semicolon expected'); endRoutine(s);

END func;

(* <formals> ::= <empty> | ( <formlist> ) *)

PROCEDURE forma Is(routine:symboI);

VAR formList:symboIList;

offset:INTEGER;

BEGIN

IF getTokenCIass() <> Lparen THEN ungetToken;

ELSE

form Iist(routine);

tokenErrorCheck(Rparen, 'right paren expected');

176 BYTE LISTINGS SUPPLEMENT

(* Set the offsets of the formals *) formList := SymboI.forma Is(routine); offset := In111 a I FormalOffset;

WHILE NOT sI Empty(formL1st) DO

Symbol.setOffset(sISymboI(formList), offset);

IF openArrayFormaI(sISymbol(formList)) THEN

INC(offset, 3); (* 2 extra: one for each bound *)

ELSE

INC(offset);

END;

formList := sI Next(formList);

END;

END;

END formals;

PROCEDURE openArrayFormaI(s rsymboI):BOOLEAN;

BEGIN

RETURN (Symbol.cI ass(SymboI.type(s)) * ArrayType) AND Symbol.open(Symbol.type(s));

END openArrayFormaI;

(* <formlist> ::= <formdecl> | <formdecl> ; <formlist> *) PROCEDURE formlist(routine:symboI);

BEGIN

formdecI(routine);

IF getTokenCI ass() = Semicolon THEN formlist(routine);

ELSE

ungetToken;

END;

END formlist;

(* <formdecl> ::= <idIist> : <mode> <typeld> *)

PROCEDURE formdecI(routine:symboI);

VAR tl, tokenp:tokenList; t:token;

typeSymbol;symboI; mrmodeType;

BEGIN

tl idlist();

tokenErrorCheckfCoIon, "colon expected") ; m formaIMode(); getToken(t);

IF t.class ** Identifier THEN ungetToken;

typeSymbol :« typeName();

ELSIF t.class * Array THEN

tokenErrorCheck(Of, "OF expected");

typeSymbol :« newArrayType(typeName(), 0, 0, TRUE,

currentLexLevel());

(* bounds are irrelevant; TRUE indicates open array *)

ELSE

compError("type name or open array parameter expected"); ungetToken;

typeSymbol ;■ tUnknown;

END;

(* create and enter the symbols *) tokenp := tI;

WHILE NOT tlEmpty(tokenp) DO tIToken(tokenp, t);

enterFormaI(t.string, m, typeSymbol, routine); tokenp :* 11 Next(tokenp);

END;

freeTokenList(tI);

END formdecI;

(* <mode> <empty> | IN | OUT | IN OUT.

Note: OUT IN is not acceptable. *)

PROCEDURE formaIMode():modeType;

VAR t:token;

BEGIN

getToken(t);

IF t.class = In THEN

IF getTokenCI ass() « Out THEN RETURN mlnOut;

ELSE

February

ungetToken; RETURN min;

END;

ELSIF t.class = Out THEN RETURN mOut;

ELSE

ungetToken;

RETURN min;

END;

END formalMode;

PROCEDURE I oca Is(rout Ine:symboI);

(* Syntactically, locals look just like globals; but into the locals list of the routine and give them pointer. Note that since the array handling stuff address to be the lowest in the array, we have to t arrays 80 tha * the starting address is lowest. VAR locListisymbolList; offset;INTEGER; size:CARDINAL;

BEGIN

we have to put them offsets from the frame expects the starting assign the offset *)

END

vars(routine);

locList Symbol.locals(routine); offset :« initialLocalOffset;

(* set the offsets of the locals *)

WHILE NOT slEmpty(locList) DO

size :« Symbol.size(Symbol.type(sISymboI(locList)));

locList :« sINext(locList);

END; J

locaIs;

PROCEDURE typeName():symboI;

VAR t:token;

s:symboI;

BEGIN

getTokenErrorCheck(t, Identifier, "type name expected"); s :« findSymbol(t.string);

IF NOT isTypefs) THEN

compError(* type name expected*); s :* tUnknown;

END;

RETURN s;

END typeName;

PROCEDURE sizeFormaIs(routine:symboI):CARDINAL•

( * thI U nuLlrV? U ? b6r ? f T? 8 0ccupied *>y forma I s. Before this was just

(For its boCJdl o'"*) 8 ’ tUt " 0W 6aCh 0pe " ° rray P<lr<,m ° ddS 2 t0 the count

VAR formIist:symboIList;

sum:CARDINAL; t:symboI; BEGIN

formlist :« SymboI.forma Is(routine); sum :« 0; J

WHILE NOT sIEmpty(formlist) DO

t := Symbol.type(sISymboI(formlist));

IF tS/ 01 - c, a8s(t) = ArrayType) AND Symbo I .open(t) THEN XNU(sum, 3)»

ELSE

INC(sum);

END;

formlist := sI Next(form Iist); END; J

RETURN sum;

END sizeFormals;

BEGIN

END Routines.

Start SymboI.DEF

178 BYTE LISTINGS SUPPLEMENT

DEFINITION MODULE Symbol;

February

(* The symbol data structure contains all the information about symbols (like variables and routine names). Symbol lists are used for lists of formals and locals.

Changes made for part 3:

1. The word "symbol" has been removed from all routine names. Instead, the module will be imported whole (IMPORT Symbol) and the module name will serve to identify the routines (e.g. SymboI.empty).

Also, SymbolClass —> Class.

2. symboITokCI ass —> tokClass; setSymboITokCI ass —> setTokenCI ass.

3. The number of symbol classes has been expanded.

4. The function tokenCIassToType has been moved here from Token to avoid circular references between Token.DEF and Symbol.DEF.

5. The type mode and the function tokenCIassToMode have been added.

FROM Token IMPORT stringType, tokenClass;

EXPORT QUALIFIED symbol, emptySymbol, Class, class, string, type, lexLevel, offset, formals, locals, next, prev, tokClass,

setFormaIs, setLocals, setType, setNext, setPrev, setOffset, setTokenCI ass,

classEqual, empty, equal, new, free, numFormals, numLocals,

symboI List, emptySymboIList, si Empty, siSymboI, si Next, addToSymboIList,

freeSymboIList, modeType, isType, mode, setMode, size, setSize,

highBound, lowBound, setBounds, open, setOpen, newArrayType,

anonymous, copyArrayType, setstring;

TYPE

symboI; symboI List;

Class = (* the different kinds of symbols *)

(Proc, Func, ScalarType, ArrayType, Global, Local, Formal, Keyword, UndecIared);

modeType = (min, mOut, mlnOut);

VAR emptySymboI:symboI;

emptySymboIList:symboILIs t;

(*** Symbols ***)

PROCEDURE cI ass(s:symboI):CI ass;

(* Return the class of the symbol *)

PROCEDURE string(s:symboI; VAR str:strIngType);

PROCEDURE setString(s:symboI; str:ARRAY OF CHAR);

(* Return or set the name of the symbol, as a string *)

(* Symbols are declared to be of a certain type (except procedures) *)

PROCEDURE type(s:symboI):symboI;

PROCEDURE setType(s, t:symbol);

PROCEDURE IexLeveI(s:symboI):CARDINAL;

(* Return the lexical level at which the symbol was declared *)

(* Each formal and local has an offset from the frame pointer. *) PROCEDURE offset(s:symboI):INTEGER;

PROCEDURE setOffset(s:symboI; o:INTEGER);

(* Formals also have a mode. *)

PROCEDURE mode(s:symboI):modeType;

PROCEDURE setMode(s:symboI; m:modeType);

(* Type objects have an associate size. *)

PROCEDURE size(s:symboI):CARDINAL;

PROCEDURE setsize(s:symboI; c:CARDINAL);

(* Array types have bounds, and a Boolean for open array paroms. *) PROCEDURE IowBound(s:symboI):INTEGER;

PROCEDURE highBound ( s:symboI):INTEGER;

PROCEDURE setBounds(s:symboI; low, high:INTEGER);

[continued)

BYTE LISTINGS SUPPLEMENT 179

PROCEDURE open(s:symbol):BOOLEAN;

PROCEDURE setOpen(s:symboI; b:BOOLEAN);

(* These ore for routines. They get and set the lists of formals and locals. *) PROCEDURE forma Is(s:symboI):symboILIst;

PROCEDURE I oca Is(s:symboI):symboILIst;

PROCEDURE setFormaIs(s:symboI; sI:symboIL1st);

PROCEDURE setLocaIs(s:symboI; sI:symboILlst);

(* Return the number of formals or locals in the routine. *)

PROCEDURE numFormals(s:symbol ) -.CARDINAL;

PROCEDURE numLocaIs(e:eymboI):CARDINAL;

(* These next two are for implementing a doubly linked list. See SymboI Tab Ie.*) PROCEDURE next(s:symbol):symboI ;

PROCEDURE prev(s:symbol):symboI;

PROCEDURE setNext(s1, s2:symbol);

PROCEDURE setPrev(s1, s2:symbol);

(* Keyword symbols have a corresponding token class. *)

PROCEDURE tokCI ass(s:symboI):tokenClass;

PROCEDURE setTokenCIass(s:symboI; tc;tokenCIass);

PROCEDURE classEqual(srsymbol; sc:CI ass):BOOLEAN;

(* Returns TRUE if the class of s equals sc. *)

PROCEDURE equal(si, s2:symboI):BOOLEAN;

(* Returns TRUE If the two symbols are the same. *)

PROCEDURE empty(s:symboI):BOOLEAN;

(* Returns TRUE if the symbol is the emptySymbol. *)

PROCEDURE anonymous(s:symboI):BOOLEAN;

(* TRUE iff the array type is anonymous, i.e. unnamed. *)

PROCEDURE new(str:strIngType; sc;CIass; scop:CARDINAL;

typ:symboI ): symboI;

(* Creates a new symbol. *)

PROCEDURE newArrayType(baseType:symboI; lowBound, highBound:INTEGER;

open:BOOLEAN; IexLevtCARDINAL);symboI;

(* Creates a new array type object. *)

PROCEDURE copyArrayType(s:symbol):symbol;

(* Copies an array type object *)

PROCEDURE free(s:symbol);

(* Frees the storage associated with s. *)

PROCEDURE isType(s:symboI):BOOLEAN;

(* TRUE if the class of s is ArrayType or ScalarType. *)

(*** Symbol Lists ***)

PROCEDURE si Empty(si:symboIList);BOOLEAN;

(* Returns TRUE if si is the empty symbol list. *)

PROCEDURE sI Next(sI:symboIList):symboIList;

(* Gets the rest of the symbol list. *)

PROCEDURE sISymboI(sI:symboI List):symboI;

(* Gets the first symbol in the list *)

PROCEDURE addToSymbolList(s:symbol; si:symboI List):symboI List;

(* Adds s to si at the front. Return the new symbol list. *)

PROCEDURE freeSymboIList(sI:symboIList);

(* Frees the storage associate with si (but NOT the storage of the symbols in si! *)

END Symbol.

Start Symbol.MOD

180 BYTE LISTINGS SUPPLEMENT

IMPLEMENTATION MODULE Symbol;

(* Symbol and symbol list data structures.

Changes made for part 3:

1. The symbolRec data structure has been reorganized.

2. Procedures have been added to access the new fields in a symbol, and to create array type objects.

3. roffset for routines: used only for the hack (in

SymboI Tab Ie.beginRoutine) that assigns a unique number to non-global routines.

*)

FROM Token IMPORT stringType, tokenClass;

FROM Storage IMPORT ALLOCATE, DEALLOCATE;

FROM MyTerminaI IMPORT fatal;

FROM SymboI Table IMPORT tUnknown;

FROM StringStuff IMPORT stringCopy;

TYPE

symbol » POINTER TO symbolRec; symboI List = POINTER TO sIRec;

symbolRec * RECORD

string: stringType;

IexLeveI: CARDINAL; type: symbol; next, prev: symbol;

CASE class: Class OF

Proc, Func; formals, locals: symbolList;

roffset:INTEGER;

Local: loffset:INTEGER;

Formal: foffset:INTEGER; mode: modeType;

Sea IarType: size: CARDINAL;

ArrayType: asizeCARDINAL; lowBound, highBound:INTEGER; open:BOOLEAN;

| Keyword: tokClass: tokenClass;

END;

END;

sIRec « RECORD

sym: symbol; next: symbolList;

END;

Cset * SET OF Class;

(*** getting fields ***)

PROCEDURE cI ass(s:symboI):CI ass;

BEGIN

RETURN s^.class;

END class;

PROCEDURE string(s:symbol; VAR str:stringType);

BEGIN

str :» s^.string;

END string;

PROCEDURE type(s:symbol):symboI;

BEGIN

RETURN s*.type;

END type;

PROCEDURE isType(s:symboI):BOOLEAN;

BEGIN

RETURN (s*.class IN Cset{ArrayType, ScalarType}) OR (s ■ tUnknown);

END isType;

PROCEDURE IexLeveI(s:symboI):CARDINAL;

BEGIN

RETURN s A .IexLeveI;

END I exLeveI;

PROCEDURE offset(s:symboI):INTEGER;

{continued)

BYTE LISTINGS SUPPLEMENT 181

BEGIN

IF s*.class =* Formal THEN RETURN s^.foffset;

ELSIF s^.class « Local THEN RETURN s~.loffset;

ELSIF s~.class IN CsetjProc. Func} THEN RETURN s*.roffset;

ELSE

fata I(’SymboI.offset: not a Formal, Local or routine’)

END;

END offset;

PROCEDURE mode(s:symboI)rmodeType;

BEGIN

IF s^.class » Formal THEN RETURN s^.mode;

ELSE

fata I(*SymboI.mode: not a formal*);

END;

END mode;

PROCEDURE size(s:symboI):CARDINAL;

BEGIN

IF s*.class * ArrayType THEN RETURN s^.asize;

ELSIF s^.class « ScalarType THEN RETURN s^.size;

ELSE

fataI(*SymboI.sIze: not a type object*);

END;

END size;

PROCEDURE highBound(s:symboI):INTEGER;

BEGIN

IF s^.class » ArrayType THEN RETURN s^.highBound;

ELSE

fataI(*SymboI.highBound: not an array type*);

END;

END hi ghBound;

PROCEDURE IowBound(s:symboI):INTEGER;

BEGIN

IF s*.class = ArrayType THEN RETURN s A .IowBound;

ELSE

fataI(*SymboI.IowBound; not an array type’);

END;

END IowBound;

PROCEDURE open(s:symboI):BOOLEAN;

BEGIN

IF s*.class = ArrayType THEN RETURN s^.open;

ELSE

fataI(*S>mboI.open; not an array type*);

END;

END open;

PROCEDURE forma Is(s:symboI):symboIList;

BEGIN

IF s^.class IN CsetjProc, Func} THEN RETURN s^.forma Is;

ELSE

fataI(*SymboI.forma Is; not a proc or func*);

END;

END formals;

PROCEDURE I oca Is(s:symboI);symboIList;

BEGIN

IF s^.class IN CsetjProc, Func} THEN RETURN s*.locals;

ELSE

fataI(* I oca Is : not a proc or func*);

END;

END locals;

182 BYTE LISTINGS SUPPLEMENT

PROCEDURE next(s:symboI):symbol;

BEGIN

IF s = emptySymbol THEN

fatal('Symbol.next: empty symbol given');

ELSE

RETURN s*.next;

END;

END next;

PROCEDURE prev(s:symboI):symboI;

BEGIN

RETURN s*.prev;

END prev;

PROCEDURE tokCI ass(s:symbol):tokenCI ass;

BEGIN

IF s*.class = Keyword THEN RETURN s*.tokCI ass;

ELSE

fataI(*SymboI.tokCI ass: not a keyword');

END;

END tokClass;

(*** setting fields ***)

PROCEDURE setString(s:symboI; str:ARRAY OF CHAR);

VAR i;CARDINAL;

BEGIN

str ingCopy(s*.str ing, str );

END setstring;

PROCEDURE setFormaIs(s:symboI; sI:symboIList);

BEGIN

IF s*.class IN CsetjProc, Func} THEN s*.forma Is sI;

ELSE

fatal('setFormals: not a proc or func');

END;

END setFormals;

PROCEDURE setLocaIs(s:symboI; sI:symboIList);

BEGIN

IF s*.class IN CsetjProc, Func} THEN s*.locaIs :* si;

ELSE

fatal('setLocals: not a proc or func');

END;

END setLocals;

PROCEDURE setType(s1, trsymbol);

BEGIN

si*.type :■ t;

END setType;

PROCEDURE setNext(s1, s2:symbol);

BEGIN

si*.next :■ s2;

END setNext;

PROCEDURE setPrev(s1, s2:symbol);

BEGIN

si*.prev :« s2;

END setPrev;

PROCEDURE setOffset(s:symboI; o:INTEGER);

BEGIN

IF s*.class - Formal THEN s*.foffset o;

ELSIF s*.class - Local THEN s*.loffset o;

ELSIF s*.class IN CsetjProc, Func} THEN s*.roffset :■ o;

ELSE

fatal('Symbol.setOffset: not a formal, local, or routine’);

END;

END setOffset;

(continued^

BYTE LISTINGS SUPPLEMENT 183

PROCEDURE setMode(s:symboI; mimodeType);

BEGIN

IF s*.class » Formal THEN s^.mode :■ m;

ELSE

fataI(’SymboI.setMode: not a Formal');

END;

END setMode;

PROCEDURE sets Ize(s:symboI; c:CARDINAL);

BEGIN

IF s^.class * ScalarType THEN s~.size :« c;

ELSIF s^.class = ArrayType THEN s~.asize :® c;

ELSE

fatal(’Symbol.setSize: not a type object');

END;

END setSize;

PROCEDURE setBounds($:symboI; low, high:INTEGER); BEGIN

IF s A .class = ArrayType THEN s^.lowBound :« low; s^.hlghBound :» high;

ELSE

fata I(’SymboI.setBounds: not an array type’);

END;

END setBounds;

PROCEDURE setOpen(s:symboI; b:BOOLEAN);

BEGIN

IF s^.class » ArrayType THEN s^.open :« b;

ELSE

fata I('SymboI.setOpen; not an array type’);

END;

END setOpen;

PROCEDURE setTokenCIass(s:symboI; tc:tokenCI ass); BEGIN

IF s^.class * Keyword THEN s^.tokClass := tc;

ELSE

fataI('setTokenCI ass: not a keyword');

END;

END setTokenCI ass;

(*** other symbol procedures ***)

PROCEDURE anonymous(s:symboI):BOOLEAN;

(* TRUE Iff the array Is anonymous *)

BEGIN

RETURN s~.string[0] = 0C;

END anonymous;

PROCEDURE c I assEquaI(s:symboI; sc:CIass):BOOLEAN; BEGIN

RETURN (s^.class =* Undeclared) OR (s^.class = sc) END cIassEquaI;

PROCEDURE equal(si, s2:symboI):BOOLEAN;

BEGIN

RETURN si = s2;

END equaI;

PROCEDURE empty(s:symboI):BOOLEAN;

BEGIN

RETURN s = emptySymbol;

END empty;

PROCEDURE new(str;strIngType; sc:Class; ll:CARDINAL; typ:symboI):symboI;

VAR s:symboI;

BEGIN

184 BYTE LISTINGS SUPPLEMENT

NEW(s); (* should be: NEW(s, sc); *)

WITH s" DO

string := str;

IexLeveI :* II; type :« typ; next :* emptySymbol; prev :* emptySymbol; class :* sc;

CASE class OF Proc, Func:

formals :» emptySymboILIst; locals := emptySymboI List;

Formal: foffset :« 0; mode := min;

LocaI: I of fset := 0;

ArrayType: open :* FALSE;

ScalarType: size := 1;

ELSE (* do nothing *)

END;

END;

RETURN s;

END new;

PROCEDURE newArrayType(baseType:symboI; lowBound, highBound:INTEGER;

open:BOOLEAN; IexLev:CARDINAL):symboI;

VAR ato:symboI;

BEGIN

ato :« new( ,,M , ArrayType, lexLev, baseType); setBounds(ato, lowBound, highBound); setOpen(ato, open);

setsize(ato, size(baseType) * CARDINAL(highBound-IowBound+1));

RETURN ato;

END newArrayType;

PROCEDURE copyArrayType(s:symboI):symboI;

BEGIN

RETURN newArrayType(type(s), lowBound(s), highBound(s), open(s),

I exLeveI(s));

END copyArrayType;

PROCEDURE free(s:symbol);

BEGIN

DISPOSE(s); (* should be: DISPOSER, s*. class); *)

END free;

PROCEDURE numFormaIs(s:symboI):CARDINAL;

VAR formList:symbolList;

count CARDINAL;

BEGIN

count :■ 0;

formList :» formals(s);

WHILE NOT sI Empty(formList) DO INC(count);

formList := sINext(formList);

END;

RETURN count;

END numFormaIs;

PROCEDURE numLocals(s:symbol):CARDINAL;

VAR locList:symboIList;

count CARDINAL;

BEGIN

count :■ 0;

locList :* locals(s);

WHILE NOT sI Empty(IocL1st) DO INC(count);

locList :■ sINext(locList);

END;

RETURN count;

END numLocals;

(*** symbolList ***)

PROCEDURE sIEmpty(sI:symboILis t):BOOLEAN;

BEGIN

RETURN sl * emptySymboI List;

END slEmpty;

(continued)

BYTE LISTINGS SUPPLEMENT 185

PROCEDURE 6 I Next(si:symboIList):symboILlst;

BEGIN

RETURN s I next;

END si Next;

PROCEDURE sISymboI(sI:symbo Hist):symboI;

BEGIN

RETURN sl^.sym;

END sISymboI;

PROCEDURE addToSymbolList(s:symbol; si:symboIList):symboIList; VAR news I: symboI List;

BEGIN

NEW(newsl); newsl^.sym :* s; news Inext :* sI;

RETURN news I;

END addToSymboILIs t;

PROCEDURE freeSymbolList(sI:symboIList);

BEGIN

IF NOT si Empty(si) THEN

f reeSymboIList(sI Next(sI));

DISPOSER I );

END;

END freeSymboIList;

BEGIN

emptySymbol :* NIL; emptySymbolList : = NIL; END Symbol.

Start SymbolTable.DEF

DEFINITION MODULE SymboI Table;

(* The symbol table associates symbol records with names of symbols. *)

FROM Symbol IMPORT symbol, Class, modeType;

FROM Token IMPORT stringType, tokenClass;

EXPORT QUALIFIED enterSymbol, enterLocal, enterFormal, findSymbol, findKeyword, enterKeyword, beginRoutine, endRoutine, currentLexLeveI,

enterArrayType, tUnknown, tBoolean, tChar. tlnteger. tString, lowFunc, highFunc;

(* These are the type objects of the built-in types. *)

VAR tUnknown, tBoolean, tChar, tlnteger, tString:symbol;

lowFunc, highFuncisymbol; (* symbols for pseudo-functions LOW k HIGH *)

PROCEDURE cur rentLexLeve I ( ) -.CARDINAL;

(* Returns the current lexical level *)

(* Enter global, local, formal, keyword symbols into the table.

enterSymbol is the general routine and returns the entered symbol. If the symbol Is already present, or if it is a built-in, an error is signalled. EnterLocal and enterFormal are used for local variables and formal parameters only; they take care of inserting the symbol into the list of locals or formals, respectively, which is associated with the routine. enterArrayType is for giving a name to array type objects. ★)

PROCEDURE enterSymboI(VAR s:stringType; symcrClass; type:symboI):symboI;

PROCEDURE enterLocaI(VAR s:stringType; type, routine:symboI);

PROCEDURE enterFormaI(VAR s:stringType; modermodeType; type, routine:symboI)

PROCEDURE enterKeyword(s:stringType; tc:tokenCI ass);

PROCEDURE enterArrayType(VAR s:stringType; typeObject:symboI);

PROCEDURE findSymbol(VAR s:stringType)rsymbol;

(* Look up the symbol in the table and return it. Return the empty symbo! if not found. *)

PROCEDURE findKeyword(VAR s:stringType; VAR tc:tokenCIass):BOOLEAN;

(* Look up the keyword in the table and put its corresponding token class in tc. Return FALSE if the symbol wasn't found. *)

186 BYTE LISTINGS SUPPLEMENT

PROCEDURE beginRoutine(rname:symbol);

(* To be called just after the routine name has been entered. Increments lexical level. Also assigns a unique number to the routine if it isn't globaI. *)

PROCEDURE endRoutine(rname:symboI);

(* Clean up the symbol table after a routine has been compiled. This includes deleting the locals and formals from the table. *)

END SymboI Table.

Start SymboI Tab Ie.MOD

IMPLEMENTATION MODULE Symbol Table;

(* The symbol table for the SIMPL compiler. It is a hash table; each entry is a symboI,possibly linked through the NEXT field to other symbols. The list of symbols is doubly linked, to make it easy to delete from the middle. We still have to rehash to delete from the beginning, though. This could be gotten around by hanging a dummy record off of every hashtable entry.

*)

FROM Symbol IMPORT symbol, emptySymbol, symboI List, addToSymboIList, modeType, sISymbol, sINext, slEmpty, Class, freeSymboIList, emptySymboIList;

IMPORT Symbol;

FROM Token IMPORT stringType, tokenClass;

FROM LexAn IMPORT compError;

FROM MyTerminaI IMPORT fatal;

FROM StringStuff IMPORT stringEqual;

CONST symTabSize = 20;

(* This is NOT an upper limit on the number of symbols,

since we have linked lists coming off of the hashtable entries. Still, the compiler may run faster (because the lists it searches are shorter)

If this number is increased. *)

VAR symbolTable: ARRAY[0..symTabSize-1] OF symbol; lexica I Level; CARDINAL;

PROCEDURE cur rentLexLeveI():CARDINAL;

BEGIN

RETURN lexica I Level;

END currentLexLevel;

PROCEDURE enterLocaI(VAR s:stringType; type, routine:symboI);

VAR sym:symboI;

BEGIN

sym := enterSymboI(s, Local, type);

IF NOT Symbol.empty(sym) THEN Symbol.setLocaIs(routine,

Symbol.addToSymboI List(sym, Symbol.I oca Is(routine)));

END;

END enterLocaI ;

PROCEDURE enterFormaI(VAR s:stringType; mode;modeType; type, routine:symboI);

VAR sym:symbol;

BEGIN

sym := enterSymboI(s, Formal, type);

IF NOT SymboI.empty(sym) THEN SymboI.setMode(sym, mode);

Symbol.setFormaIs(routine,

Symbol.addToSymboI List(sym, Symbol.forma Is(routine)));

END;

END enterFormaI;

PROCEDURE enterKeyword(s:stringType; tc:tokenClass);

VAR sym:symboI;

BEGIN

sym :« enterSymboI(s, Keyword, tUnknown);

SymboI.setTokenCIass(sym, tc);

END enterKeyword;

(continued)

BYTE LISTINGS SUPPLEMENT 187

PROCEDURE enterArrayType(VAR s:stringType; typeObject:symboI);

(* Enter the array type object into the symbol table with the given name.

Does NOT create a new symbol. *)

BEGIN

IF NOT isBuiitln(s) THEN

Symbol. setString(typeObject, s);

EL SE type0b ^ ect (* dumm y *) Insert(typeObject, hash(s));

compError("cannot redefine a built-in name");

END;

END enterArrayType;

(*** symbol insertion ***)

PROCEDURE enterSymbol(VAR s:stringType; symc:SymboI.CI ass; type;symboI):symboI (* This does the real work of entering a symbol. It signals an error If a symbol is redefined, or a built-in. *)

BEGIN

IF NOT isBuiI tin(s) THEN

RETURN enterSym(s, symc, type);

ELSE

compError("can*t redefine a built-in symbol");

RETURN emptySymbol;

END;

END enterSymboI;

PROCEDURE enterSym(VAR s:stringType; symc;SymboI.CI ass; type:symboI):symboI;

(* enters a symbol without doing built-in checking *)

VAR sym:symbol;

h:CARDINAL;

BEGIN

sym :* lookup(s, FALSE, h);

IF SymboI.empty(sym) THEN

RETURN insert(SymboI.new(s, symc, I ex IcaILeveI, type), h);

ELSE

compError(*redefined symbol*);

RETURN sym;

END;

END enterSym;

(*** symbol lookup ***)

PROCEDURE findSymboI(VAR s:stringType):symboI;

VAR sym: symbol;

h: CARDINAL;

BEGIN

sym :« lookup(s, TRUE, h);

IF SymboI.empty(sym) THEN

compError(*undefined symbol*);

RETURN insert(Symbol.new(s, Undeclared, 0, tUnknown), h);

ELSE

RETURN sym;

END;

END findSymboI;

PROCEDURE findKeyword(VAR s:stringType; VAR tcitokenClass);BOOLEAN;

(* This is used by the lexical analyzer to return the keyword’s token class. Returns true if the keyword is found; tc will then contain the token class of the keyword. *)

VAR sym:symbol;

h:CARDINAL;

BEGIN

sym := lookup(s, TRUE, h);

IF Symbol.empty(sym) OR (SymboI.cIass(sym) <> Keyword) THEN RETURN FALSE;

ELSE

tc := SymboI.tokCIass(sym);

RETURN TRUE;

END;

END flndKeyword;

PROCEDURE lookup(VAR s:strIngType; anything:BOOLEAN; VAR h:CARDINAL):symboI; (* Looks up the string in the symbol table. Returns the empty symbol if the string isn’t found; if it is, returns the symbol and, in h, the hash value, anything TRUE means: "match anything".

188 BYTE LISTINGS SUPPLEMENT

This is what findSymbol uses. We match lexical level on insertion, to check for redefined symbols.

*)

VAR sym: symbol;

syms: stringType;

BEGIN

h :* hash(s);

sym := symboITabIe[h];

WHILE NOT Symbol.empty(sym) DO SymboI.string(sym, syms);

IF stringEquaI(syms, s) AND

(anything OR (I exicaILeveI = SymboI.IexLeveI(sym))) THEN RETURN sym;

END;

sym :*= Symbo I . next (sym);

END;

RETURN SymboI.emptySymboI;

END lookup;

PROCEDURE insert(s:symboI; h:CARDINAL):symboI;

(* Link the symbol into the h’th symbol table entry. The symbol is put at the front of the list. *)

BEGIN

Symbol.setNext(s, symboI Tab Ie[h]);

SymboI.setPrev(s, SymboI.emptySymboI); symboITabIe[h] :« s;

RETURN s;

END insert;

MODULE begRout; (* This needs to be a module because a variable needs to be remembered across invocations. *)

IMPORT symboI, lexicalLeveI;

IMPORT Symbol;

EXPORT beginRoutine;

VAR num:INTEGER;

PROCEDURE beginRoutine(rname:symboI);

BEGIN

IF Symbol.IexLeveI(rname) <> 0 THEN (* assign a unique number to *) Symbol.setOffset(rname, num); (* non-global procedures *) INC(num);

END;

INC(lexicalLevel);

END beginRoutine;

BEGIN

num :« 0;

END begRout;

PROCEDURE endRoutine(rname:symboI);

(* This is the stuff we do at the end of compiling a procedure or function.

The free’s are just to reclaim storage. The remove’s remove the symbols from the symbol table, which is important if some local symbol is shadowing a global symbol. We remove both locals and formals, but we don’t free the formals because we need them for type checking.

We also remove the routines declared at this lexical level, and free their formals. We find these routines by searching the entire symbol table—it would probably be better to keep a list of them.

We also remove the types declared at this level, again by exhaustive search.

*)

BEGIN

removeSymbolList(Symbol.locals(rname)); freeSymboIs(SymboI.locaIs(rname));

Symbol.freeSymbolList(Symbol.I oca Is(rname));

Symbol.setLocaIs(rname, Symbol.emptySymboIList); removeSymboIList(SymboI.forma Is(rname)); removeRout1nesAtThIsLeveI;

DEC(lexicalLeveI);

END endRoutine;

PROCEDURE removeSymboIList(symboIp:symboIList);

( continued)

BYTE LISTINGS SUPPLEMENT 189

BEGIN

WHILE NOT Symbol.slEmpty(symbolp) DO

removeSymboI(Symbol.sISymboI(symboIp)); symbolp :■ SymboI.sI Next(symboIp);

END;

END removeSymboILIst;

PROCEDURE removeRoutInesAtThIsLeveI;

(* Remove oil routines defined at this lexical level. Free their formals.

All the symbols at this lexical level will be at the beginning of their respective buckets in the symbol table, and they all will be routines.

Now removes types too. *)

VAR i:CARDINAL;

s, next:symboI;

BEGIN

FOR i :■ 0 TO symTabSize-1 DO s :« symboITabIe[i];

WHILE (NOT Symbol.empty(s)) AND (SymboI.IexLeveI(s) * I exicaILeveI) DO IF NOT SymboI.IsType(s) THEN (* it’s a routine *) freeSymboIs(SymboI.forma Is(s));

Symbol.freeSymboIList(SymboI.formals(s));

END;

(* remove this symbol from the table *) next :« Symbol.next(s); symboI Tab Ie[i] :« next;

IF NOT SymboI.empty(next) THEN

SymboI.setPrev(next, SymboI.emptySymboI);

END;

SymboI.free(s); s :» next;

END;

END;

END removeRoutInesAtThIsLeveI;

PROCEDURE removeSymboI(s:symboI);

(* Splice the symbol out of the symbol table. If the symbol is at the beginning of the list, we have to rehash to find the right entry.

Otherwise, just remove it from the list. *)

VAR bucket:CARDINAL;

syms: stringType;

BEGIN

IF SymboI.empty(SymboI.prev(s)) THEN Symbol .str ir,g(s, syms); bucket :* hash(syms);

IF NOT Symbol.equal(symboI Tab Ie[bucket], s) THEN fata I(*removeSymboI: error*);

ELSE

symboI Tab Ie[bucket ] :* Symbol.next(s);

IF NOT Symbol.empty(SymboI.next(s)) THEN

Symbol.setPrev(SymboI.next(s), Symbol.emptySymboI);

END;

END;

ELSE

Symbol.setNext(SymboI.prev(s), Symbol.next(s));

IF NOT Symbol.empty(SymboI.next(s)) THEN

Symbol.setPrev(SymboI.next(s), Symbol.prev(s));

END;

END;

END removeSymboI;

PROCEDURE freeSymboIs(symboIp:SymboI.symboIList);

VAR nextSymboI:SymboI.symboIList;

BEGIN

WHILE NOT SymboI.sIEmpty(symboIp) DO

nextSymbol := Symbol.sINextfsymboIp);

SymboI.free(SymboI.sISymboI(symboIp)); symbolp := nextSymbol;

END;

END freeSymboIs;

(*** low-level stuff ***)

PROCEDURE hash(VAR s:stringType)rCARDINAL;

(* A simple hash function: just add up the ASCII values of the characters. *)

190 BYTE LISTINGS SUPPLEMENT

VAR i. sum:CARDINAL;

BEGIN

i 0; sum := 0;

WHILE s[i] <> 0C DO

sum :«= sum + ORD(s[i]);

INC(i);

END;

RETURN sum MOD symTabSize;

END hash;

MODULE Bui I tins;

IMPORT stringType, stringEqual, enterSym, fatal, symbol, emptySymbol;

IMPORT Symbol;

EXPORT isBuiltln, enterBuiItIn, enterBuiItInType;

CONST maxBuI I tins = 10;

VAR builtlns: ARRAY[1..maxBuiI tins] OF stringType; nBuiI tins: [0..maxBuiI tins];

PROCEDURE isBuiltIn(VAR s:stringType):BOOLEAN;

VAR i-.CARDINAL;

BEGIN

FOR i :« 1 TO nBuiI tins DO

IF stringEquaI(s, builtlns[i]) THEN RETURN TRUE;

END;

END;

RETURN FALSE;

END isBuiItln;

PROCEDURE enterBuiI tin(s:stringType; symc:Symbol.CI ass):symboI;

BEGIN

IF nBuiltlns ■ maxBuiltlns THEN fatal('too many built-ins’);

ELSE

INC(nBuI I tins);

bu1 11Ins[nBuiI tins] :» s;

RETURN enterSym(s, symc, emptySymbol);

END;

END enterBuIItln;

PROCEDURE ontorBui 11InType(s:stringType):symboI;

(* Assumes size scalar types *)

VAR sym:symbol;

BEGIN

sym := enterBuI Itln(s, SymboI.SeaIarType);

SymboI.setsize(sym, 1);

RETURN sym;

END enterBuiItlnType;

BEGIN (* module Builtlns *) nBuiI tins :■ 0;

END Bui I tins;

PROCEDURE InitSymbolTable;

VAR I:CARDINAL;

BEGIN

FOR i :■ 0 TO symTabSize-1 DO

symbolTable[i] := emptySymbol;

END;

END InitSymbolTable;

PROCEDURE enterBuiI tins;

VAR oneArgrsymbolList;

BEGIN

tlnteger :■ enterBuI ItInType("INTEGER"); tChar :* enterBuiItInType("CHAR"); tBoolean :* enterBuiItInType("BOOLEAN");

(* tString isn’t really a built-in type, nor Is STRING a reserved word.

So Just create a symbol for tString. Do be careful about the symbol class and the basetype: some might use that info in type-checking (e.g. writeCheck). Strings are arrays of CHAR. *) tString :» SymboI.new("_tString", ArrayType, I exicaILeveI, tChar);

[continued)

BYTE LISTINGS SUPPLEMENT 191

(* tUnknown Is a total dummy, but It shouldn't be equal to the empty symbol nonetheless. *)

tUnknown Symbol.new( H _tUnknown", ScalarType, lexicalLevel, emptySymboI);

(* LOW and HIGH built-in functions can be treated as ordinary

functions by everything except the code generator. Give them a dummy formal for type-checking purposes. The formal will correctly default to mode IN. *)

oneArg :* addToSymboILIst(SymboI.new("^dummy", Formal, lexicalLevel,

tUnknown), emptySymboIList);

lowFunc :* enterBuiItIn("LOW", Func);

Symbol.setFormals(lowFunc, oneArg);

SymboI.setType(lowFunc, tInteger);

highFunc :■ enterBuiItIn("HIGH", Func);

Symbol.setFormaIs(highFunc, oneAra);

Symbol.setType(highFunc, tlnteger);

END enterBuiI tins;

BEGIN

lexicalLevel := 0; inltSymbolTable; enterBuI I tins;

END SymboI Table.

Start Token.DEF

DEFINITION MODULE Token;

(* Tokens are what the lexical analyzer returns to the parser. Keywords are distinct tokens, as are the special characters like parens, colon, etc. TokenLists are lists of tokens; they are used in the "varlist" procedure of the parser.

Changes made for part 3;

1. New tokens have been added for the new constructs.

2. The function tokenCIassToType has been moved to Symbol to avoid circular references between Token.DEF and Symbol.DEF.

3. The function isType has been renamed isBuiItinType.

*)

EXPORT QUALIFIED token, tokenClass, stringType, stringlen, isRelation, tokenList, emptyTokenList, tIToken, tINext, addToTokenList, tIEmpty, freeTokenList;

CONST stringlen = 80;

TYPE

tokenClass = (And, Array, Assignment, Begin, Character,

Colon, Comma, Divide, Do, DotDot, Else, Elsif, End, EndOflnput, Equal, False, Function, Greater, GreaterEquaI, Identifier, If,

In, Int, Lbracket, Less, LessEqual, Lparen, Minus, Not,

NotEquaI, Of, Or, Out, Period, Plus, Procedure,

Program, Rbracket, Read, Return, Rparen, Semicolon, String, Then, Times, True, Type, UMinus, Var, While, Write);

stringType - ARRAY[0..stringIen] OF CHAR;

token - RECORD

CASE cI ass:tokenCIass OF

Identifier, String: string: stringType; Int: integer: INTEGER;

Character: ch: CHAR;

END;

END;

tokenList;

VAR emptyTokenList: tokenList;

PROCEDURE isReI ation(tc:tokenClass):BOOLEAN;

(* Returns TRUE if tc is a relational operator (Equal, Greater, etc.) *)

192 BYTE LISTINGS SUPPLEMENT

PROCEDURE tIToken(tI:tokenList; VAR t:token);

(* Gets the first token in the token list. *)

PROCEDURE 11 Next(tI:tokenList):tokenList;

(* Gets the rest of the token list. *)

PROCEDURE addToTokenList(VAR t:token; tI:tokenList):tokenList; (* Add a token to the beginning of the token list. *)

PROCEDURE freeTokenList(tI:tokenList);

(* Free the storage used by the token list. *)

PROCEDURE 11 Empty(tI:tokenList);BOOLEAN;

(* Return TRUE if the token list is empty. *)

END Token.

Start Token.MOD

IMPLEMENTATION MODULE Token;

(* Tokens and token lists for the SIMPL compiler. *)

FROM Storage IMPORT ALLOCATE, DEALLOCATE;

FROM Terminal IMPORT WriteString;

TYPE tokenList = POINTER TO tokenListRec; (* token lists are linked lists *)

tokenLIstRec = RECORD

tok: token; next: tokenList;

END;

PROCEDURE isReI ation(tc:tokenCI ass):BOOLEAN;

BEGIN

RETURN (tc = Equal) OR (tc » NotEqual) OR (tc = Greater) OR (tc = GreaterEquaI) OR (tc ■ Less) OR (tc = LessEqual);

END isRelation;

PROCEDURE tIToken(tI:tokenList; VAR t:token);

BEGIN

IF tlEmpty(tl) THEN

WriteString("tIToken: empty tokenList");

ELSE

t :« tr.tok;

END;

END tIToken;

PROCEDURE 11 Next(11:tokenLis t):tokenList;

BEGIN

RETURN tr.next;

END 11 Next;

PROCEDURE addToTokenList(VAR t:token; tI:tokenList):tokenList;

(* Create a token list record for the new token and splice it on to the front of the token list. Return ( a pointer to) the new record. *)

VAR newt I: tokenList;

BEGIN

NEW(newtl); newt I*.tok :* t; newt Inext :« 11;

RETURN newt I;

END addToTokenList;

PROCEDURE freeTokenList(tI:tokenList);

BEGIN

IF NOT tlEmpty(tl) THEN

freeTokenList(tI Next(tI));

DISPOSER I);

END;

END freeTokenL1st;

PROCEDURE tIEmpty(tl:tokenList):B00LEAN;

BEGIN

(continued)

BYTE LISTINGS SUPPLEMENT 193

RETURN tl ■ emptyTokenList; END tIEmpty;

BEGIN

emptyTokenList NIL; END Token.

Start TypeChecker.DEF

DEFINITION MODULE TypeChecker;

(* Handles the actual type-checking of SIMPL expressions and statements. *)

FROM Token IMPORT tokenClass;

FROM Node IMPORT node;

FROM Symbol IMPORT symbol, modeType;

EXPORT QUALIFIED typeCompatibIe, opAppropriate, callCheck, readCheck, writeCheck, boolCheck, assignCheck, binopCheck, unopCheck, returnCheck. assignable, hasMode, typeldentleal,

IndexCheck, baseType;

PROCEDURE typeCompatible(t1, t2:symboI):BOOLEAN;

(* Returns TRUE If tl and t2 are compatible types. In order to avoid cascades of error messages, if one or both of the types is tUnknown, it still returns TRUE. *)

PROCEDURE typeldentleal(tl, t2:symboI):BOOLEAN;

(* Returns TRUE iff tl and t2 are the SAME type. Again, tUnknown is allowed to be the same as anything. *)

PROCEDURE opApproprIate(op:tokenClass; arg:node):BOOLEAN;

(* Returns TRUE If the type of the argument can be handled by the operator *) PROCEDURE calICheck(routine:symbol; argsinode);

(* Checks the procedure or function call for right number and types of args. * PROCEDURE readCheck(actuaIs:node);

(* Checks the call to the READ built-in procedure. *)

PROCEDURE wrIteCheck(actuaIsinode);

(* Checks the call to the WRITE built-in procedure. •)

PROCEDURE booICheck(ninode);

PROCEDURE ass IgnCheck(var, exprinode);

PROCEDURE returnCheck(routIneisymboI; exprinode)iBOOLEAN;

PROCEDURE binopCheck(opitokenClass; leftarg, rightarg:node)iBOOLEAN;

PROCEDURE unopCheck(opitokenCI ass; arginode)iBOOLEAN;

PROCEDURE assignabIe(ninode)iBOOLEAN;

(* True if s can be assigned to. *)

PROCEDURE hasMode(nmode; mimodeType)iBOOLEAN;

(* A node has a particular mode iffi

1. The node is an index, the array being indexed is a formal and the formal has mode m; OR

2. The node is a symbol, the symbol is a formal and it has mode m.

*)

PROCEDURE indexCheck(indexinode);

(* Checks for compatibility with INTEGER, not of mode OUT *)

PROCEDURE baseType(typeObjectisymboI)isymboI;

(* Follows the type field of a symbol until It hits an array type or a built-in scalar type. *)

END TypeChecker.

194 BYTE LISTINGS SUPPLEMENT

Start TypeChecker.MOD

IMPLEMENTATION MODULE TypeChecker;

(* Handles type-checking of SIMPL expressions. *)

FROM Node IMPORT node, nodeType, nodeFirst, nodeRest, nodeEmpty, nodeClass, NodeClass, nodeSymbol, nodeString, nodeArray, nodeindex;

FROM Token IMPORT tokenClass, stringType;

FROM Symbol IMPORT symbol, symbolList, sINext, sISymbol, slEmpty, Class, numFormals, emptySymbol, modeType;

IMPORT Symbol;

FROM SymboI Tab Ie IMPORT tUnknown, tlnteger, tChar, tBoolean, tString, lowFunc, highFunc;

FROM MyTerminaI IMPORT fatal;

FROM LexAn IMPORT compError;

FROM StringStuff IMPORT stringLen;

TYPE Cset - SET OF Class;

Nset = SET OF NodeClass;

PROCEDURE opAppropriate(op:tokenCIass; arg:node):BOOLEAN;

BEGIN

CASE op OF

Plus, Minus, UMinus, Times, Divide:

RETURN typeCompatible(nodeType(arg), tlnteger);

| Greater, GreaterEquaI, Less, LessEqual:

RETURN typeCompatibIe(nodeTypefarg), tlnteger) OR typeCompatibIe(nodeType(arg), tChar);

| And, Or, Not:

RETURN typeCompatible(nodeType(arg), tBoolean);

| EquaI, NotEquaI:

RETURN typeCompatibIe(nodeType(arg), tlnteger) OR typeCompatibIefnodeType(arg), tChar) OR typeCompatibIe(nodeType(arg), tBooIean);

ELSE

fata I("opAppropriate: unknown op type");

END;

END opAppropriate;

PROCEDURE typeCompat1bIe(t1, t2:symboI):B00LEAN;

(* Two types are compatible if they have the same base type. *)

BEGIN

RETURN typeldentical(baseType(tl), baseType(t2));

END typeCompatibIe;

PROCEDURE typeldent1caI(t1, t2:symboI):BOOLEAN;

(* Two types are identical iff they are the SAME type object, or if one is tUnknown. *)

BEGIN

RETURN Symbol.equal(tl, tUnknown) OR SymboI.equaI(t2, tUnknown) OR SymboI.equaI(t1, t2);

END typeldentical;

PROCEDURE baseType(typeObject:symboI):symboI;

(* Compute the base type of typeObject. *)

BEGIN

IF Symbol.empty(typeObject) THEN RETURN typeObject;

END;

WHILE NOT (SymboI.empty(SymboI.type(typeObiect)) OR (Symbol.class(typeObject) = ArrayType)) DO typeObject :- SymboI.type(typeObject);

END;

RETURN typeObject;

END baseTypo;

PROCEDURE calICheck(routine:symbol; args:node);

(* Tricky because formals are stored backwards in symbol, but forwards

in the call to the routine. We do nothing if the symbol is not a procedure or function; that check is handled in the parser.

For part 3: special check for lowFunc and highFunc. *)

( continued)

BYTE LISTINGS SUPPLEMENT 195

VAR nFormals, nActuaIs:CARDINAL;

dummy mode;

BEGIN

IF Symbol.cI ass(rout Ine) IN CsetfProc, Funcf THEN nFormals :« numFormaI sproutIne); nActuals :■ lumActuaIs(args);

IF nActuals < nFormals THEN

compError(* too few arguments to routine’);

ELSIF nActuals > nFormals THEN

compError(* too many arguments to routine'):

END;

dummy :■ argsMatch(SymboI.forma Is(routine), args,

Symbol.equal(routine, lowFunc) OR SymboI.equaI(routine, highFunc))

END caIICheck;

PROCEDURE argsMatch(f list: symbo IL i st; alistinode; I owOrHi gh .-BOOLEAN) inode;

(* This procedure matches two lists, one of which is backwards. It does It by recursing down one list all the way, then iterating down the other list while unrecurslng. *)

BEGIN

IF sIEmpty(flist) THEN RETURN a Iist;

ELSE

alist :« argsMatch(slNext(fIist), alist, lowOrHigh);

IF nodeEmpty(alist) THEN RETURN alist;

ELSE

argCheck(sISymboI(fIIst), nodeFirst(alist), lowOrHigh);

RETURN nodeRest(aIist);

END;

END;

END argsMatch;

PROCEDURE argCheck(formalisymbol; actual inode; IowOrHIgh:BOOLEAN);

(* An argument matches a formal If:

The modes are compatible (see modeCompatIbIe, below) AND

1. The types are IDENTICAL (not compatible) OR

2. The formal has an open array param as a type, and the

actual is an array of the identical base type (incl. string) OR

3. The formal is an array of CHAR and the actual is a string constant of size <* the array.

For LOW and HIGH, all that is required is that the arg be an array.

*)

VAR ftype, atype:symboI;

BEGIN

IF NOT nodeEmpty(actuaI) THEN IF lowOrHigh THEN

IF NOT Symbol.classEqual(baseType(nodeType(actuaI)), ArrayType) THEN compError("LOW and HIGH take only arrays");

END;

ELSIF modeCompatlb Ie(formaI, actual) THEN ftype SymboI.type(formaI); atype :* nodeType(actuaI);

IF NOT (typeldenticaI(ftype, atype) OR openArray(ftype, atype) OR stringConst(ftype, actual)) THEN compError('type of formal does not match type of actual*);

END;

ELSE

compError("mode incompatibiIity");

END;

END;

END argCheck;

PROCEDURE modeCompatible(formalisymbol; actuaI inode)iBOOLEAN(* TRUE iff:

1. formal has mode IN and actual does not have mode OUT; OR

2. formal has mode OUT and actual

2a. is a variable or index; and 2b. does not have mode IN; OR

3. formal has mode IN OUT and actual

3a. is a variable or index; and 3b. does not have modes IN or OUT *)

BEGIN

IF Symbol.mode(formal) = min THEN

RETURN NOT hasMode(actuaI, mOut);

196 BYTE LISTINGS SUPPLEMENT

ELSIF NOT (nodeCI ass(actual) IN Nset{nSymboI, nlndexj) THEN RETURN FALSE;

ELSIF SymboI.mode(formaI) = mOut THEN RETURN NOT hasMode(actuaI, min);

ELSIF SymboI.mode(formaI) = mlnOut THEN

RETURN (NOT hasMode(actuaI, min)) AND (NOT hasMode(actuaI, mOut));

ELSE

fata I('modeCompatibIe: unknown mode’);

END;

END modeCompatibIe;

PROCEDURE hasMode(n.node; m:modeType):BOOLEAN;

(* A node has a particular mode iff:

1. The node is on Index and the array being indexed has mode m; OR

2. The node is a 8>r.bol, the symbol is a formal and it has mode m.

*)

BEGIN

IF nodeClass(n) *= nlndex THEN

RETURN hasMode(nodeArray(n), m);

ELSE

RETURN (nodeCIass(n) * nSymbol) AND

(Symbol.cI ass(nodeSymboI(n^) = Formal) AND (SymboI.mode(nodeSymboI(n)) = m);

END;

END hasMode;

PROCEDURE openArray(ftype, atype:symboI):BOOLEAN;

(* TRUE iff ftype is an open array and atype is an array of the identical base type. *)

BEGIN

RETURN (Symbol.cIass(ftype) = ArrayType) AND Symbol.open(ftype) AND (Symbol.cI ass(atype) - ArrayType) AND

typeldent leal(Symbol.type(ftype), Symbol.type(atype));

END openArray;

PROCEDURE stringConst(ftype:symboI; actuaI mode):BOOLEAN;

(* TRUE iff ftype is an array of char (possibly open} and actual is tString, and the string const is shorter than the array. *)

VAR s:stringType;

BEGIN

IF (Symbol,cIass(ftype) * ArrayType) AND

SymboI.equaI(SymboI.type(ftype), tChar) AND SymboI.equaI(nodeType(actuaI), tString) THEN nodeString(actual, s);

RETURN Symbol.open(ftype) OR (stringLen(s) <- SymboI.size(ftype));

ELSE

RETURN FALSE;

END;

END stringConst;

PROCEDURE numActuaIs(actuaIs:node)CARDINAL;

VAR count:CARDINAL;

BEGIN

count :■ 0;

WHILE NOT nodeEmpty(actuaIs) DO INC(count);

actuals :■ nodeRest(actuaIs);

END;

RETURN count;

END numActuals;

PROCEDURE readCheck(actuaIsmode);

VAR argmode;

BEGIN

IF nodeEmpty(actuaIs) THEN

compError('READ requires an argument');

ELSE

REPEAT

arg :* nodeFirst ( actuaIs);

IF NOT nodeEmpty(arg) THEN IF NOT assignabIe(arg) THEN

compError('READ must be able to assign to its arguments');

END;

(continued)

BYTE LISTINGS SUPPLEMENT 197

IF NOT chorOrInt(nodeType(org)) THEN

compError('READ can only read Integers or characters');

END;

END;

actuals :« nodeRest(actuaIs);

UNTIL nodeEmpty(actuaIs);

END;

END readCheck;

PROCEDURE wrIteCheck(actuaIsinode);

VAR arginode;

BEGIN

IF nodeEmpty(actuaIs) THEN

compError('WRITE requires an argument');

ELSE

REPEAT

arg := nodeFIrstfactuaIs);

IF NOT nodeEmpty(arg) THEN

IF NOT charOrlnt(nodeType(arg)) THEN

compError('WRITE can only write integers or characters’

END;

END;

actuals nodeRest(actuaIs);

UNTIL nodeEmpty(actuaIs);

END;

END wrIteCheck;

PROCEDURE binopCheck(op:tokenCIass; Ieftarg, rightarg;node):BOOLEAN; BEGIN

IF NOT opAppropriate(op, leftarg) THEN

compError('inapproprlate arg type: left arg*);

RETURN FALSE;

END;

IF NOT opAppropriate(op, rightarg) THEN

compError('inapproprlate arg type: right arg’);

RETURN FALSE;

END;

(* The two operands must be THE SAME, not just compatible. *)

IF NOT typeldentlea I(nodeType(Ieftarg), nodeType(rightarg)) THEN compError(’argument types not Identical');

RETURN FALSE;

ELSE

RETURN TRUE;

END;

END binopCheck;

PROCEDURE unopCheck(op:tokenCI ass; arg:node):BOOLEAN;

BEGIN

IF NOT opAppropriate(op, arg) THEN

compError(*inappropriate arg type');

RETURN FALSE;

ELSE

RETURN TRUE;

END;

END unopCheck;

PROCEDURE assignCheck(var, exprinode);

(* For assignment, the types must be identical, unless one is an open array, in which case only the base types need be identical. If the expr is a string constant, the var need only be an array of char. *) VAR t1,t2:symbol;

BEGIN

tl :« nodeType(var); t2 :* nodeType(expr);

IF NOT (openArrayft1, t2) OR openArray(t2, tl) OR typeldentIcaI(t1, t2) OR stringConst(t1, expr)) THEN compError(*types not assignment-compatible*);

END;

END assignCheck;

PROCEDURE booICheck(n:node);

BEGIN

IF NOT typeCompatlb Ie(nodeType(n), tBoolean) THEN compError('Boo Iean expression expected');

END;

198 BYTE LISTINGS SUPPLEMENT

February

END boo I Check;

PROCEDURE returnCheck(rout 1 ne:symbo I; expr-.node) :BOOLEAN;

BEG IN

IF (NOT nodeEmpty(expr)) AND (NOT Symbol .classEquol(routine, Func)) THEN compError(’only functions con return values’);

RETURN FALSE; , _ .

ELSIF nodeEmpty(expr) AND Symbol.classEquol(routine, Func) THEN compError(’function must return a value’);

RETURN FALSE;

ELSIF (NOT nodeEmpty(expr)) AND _ . Tuckl

(NOT typeIdenticoI(SymboI.type(routine), nodeType(expr))) THEN compError(’return type not identical to function type’);

RETURN FALSE;

ELSE

RETURN TRUE;

END;

END returnCheck;

PROCEDURE assignabIe(n:node):BOOLEAN;

(* Something can be assigned to if: it is a variable (including array indices), and it does not have mode IN. *)

BEGIN . , T n

RETURN variable(n) AND (NOT hasMode(n, min));

END assignable;

PROCEDURE indexCheck(index:node);

BEGIN

IF NOT nodeEmpty(index) THEN

IF hasMode(index, mOut) THEN

compError("can*t use an OUT formal to index an array");

ELSIF NOT typeCompatibIe(nodeType(index), tlnteger) THEN

compError("array index must be compatible with type INTEGER");

END;

END;

END indexCheck;

PROCEDURE variabIe(n:node):BOOLEAN;

(* TRUE iff n is a symbol of class Global, Local, or Formal; or if n is an Index. *)

BEGIN

RETURN (NOT nodeEmpty(n)) AND

((nodeClass(n) * nlndex) OR ((nodeCIass(n) * nSymbol) AND

(SymboI.cI ass(nodeSymboI(n)) IN Cset{Global, Local, Formal}))); END variable;

PROCEDURE char0rlnt(trsymbol):BOOLEAN;

(* TRUE iff t Is a type object compatible with

CHAR or INTEGER *)

BEGIN

RETURN typeCompatibIe(t, END charOrlnt;

tChar) OR typeCompatibIe(t,

tlnteger);

BEGIN

END TypeChecker.

BYTE LISTINGS SUPPLEMENT 199

.

• .

200 BYTE LISTINGS SUPPLEMENT

March

mscreen.mod TEXT

"Modula-2 System for Z80 CP/M." See mfiIecpy.mod.

MODULE MSCREEN;

FROM TERM1 IMPORT (* non-standard terminal module *) Write, WriteCard. WrlteString, WriteLn;

FROM ASCII IMPORT be I, sub;

VAR

i : CARDINAL;

BEGIN

Write (sub); Write (beI);

(* Clear Console Screen *)

FOR i := 1 TO 100 DO WriteCard (i, 3); WriteString

WriteString (•1234567890*); END;

(• The quick brown fox jumped over (•1234567890*); WriteLn;

the lazy dogs back. *);

Write (be I); END MSCREEN.

msieve.mod

TEXT

"Modula-2 System for Z80 CP/M."

See mfilecpy.mod.

MODULE MSIEVE;

FROM TERM1 IMPORT

WriteString. WriteCard. WriteLn;

CONST

Size - 8190; (* size of array *)

Iterations - 10; (* minimum 1 *)

VAR

count, i, iter, k, prime ; CARDINAL; flags ; ARRAY [0..Size] OF BOOLEAN;

BEGIN

WriteString (*10 Iterations*); FOR iter :« 1 TO Iterations DO count :* 0;

WriteLn;

FOR i 0 TO Size DO fIags[i] :« TRUE; END;

FOR i :« 0 TO Size DO IF fIags[i] THEN

prime :* i + i + 3; k :« i + prime;

WHILE k <* Size DO fIags[k] := FALSE;

INC (k, prime);

END;

INC (count);

END;

END; (* FOR *)

END; (* FOR *)

WriteString ('There were *); WriteCard (count, 0); WriteString (* primes.*) ;

END MSIEVE.

(continued)

BYTE LISTINGS SUPPLEMENT 201

mtImef.mod TEXT

"Modula-2 System for Z80 CP/M." See mfI Iecpy.mod.

MODULE MTIMEF; (* times floating point

operations ♦)

FROM Terminal IMPORT

Write, WriteLn, WriteStrlng;

FROM MathLib IMPORT

sin, cos, arctan, In, exp;

FROM ASCII IMPORT be I ;

VAR

x, y, z ; REAL; i : CARDINAL;

PROCEDURE Delay (x ; CARDINAL);

(* variable delay, x in milliseconds *)

VAR

i, j : CARDINAL;

BEGIN

FOR i :« 1 TO x DO FOR j 1 TO 18 DO END;

END;

END Delay;

BEGIN

x := 12.5; y :« 0.5;

WriteString ('Blank'); WriteLn;

Delay (500);

Write (be I); i := 1;

REPEAT z := y;

I i ♦ 1;

UNTIL i « 10000;

Write (be I);

Delay (4000);

WriteString ('Addition'); WriteLn; Delay (500);

Write (be I) ; i := 1;

REPEAT

z :■ x + y;

1 :« i + 1;

UNTIL i = 10000;

Write (bel);

Delay (4000);

WriteString ('Subtraction'); WriteLn; Delay (500);

Write (bel); i := 1;

REPEAT

z :« x - y;

i := i ♦ 1;

UNTIL i = 10000;

Write (be I) ;

Delay (4000);

WriteString ('Multiplication'); WriteLn; Delay (500);

Write (bel); i 1;

REPEAT

z :* x * y;

i :« 1 + 1;

UNTIL i « 10000;

Write (bel);

Delay (4000);

WriteString ('Division'); WriteLn;

Delay (500);

Write (beI); i :*« 1 ;

REPEAT

z :» x / y;

1 i + 1;

UNTIL I - 10000;

Wr 1 te (beI);

Delay (4000);

WriteString ('Sine'); WriteLn;

Delay (500);

Wr I te (be I); i :« 1;

REPEAT

r :« sin (y); i i + 1;

UNTIL i = 1000;

Write (be I);

Delay (4000);

WriteString (’Cosine'); WriteLn;

Delay (500);

Write (be I); i :« 1;

REPEAT

z :« cos (y); i i + 1;

UNTIL i = 1000;

Write (bel);

Delay (4000);

WriteString ('Arctangent'); WriteLn; Delay (500);

Write (bel); i :» 1;

REPEAT

z := arctan (x); i :« i + 1;

UNTIL i = 1000;

Write (bel);

Delay (4000);

WriteString ('Natural Log'); WriteLn; Delay (500);

Write (beI); i :« 1;

REPEAT

z := In (x); i : * i + 1;

UNTIL i * 1000;

Write (bel);

Delay (4000);

202 BYTE LISTINGS SUPPLEMENT

WriteString ('Natural Antilog*); WriteLn; Delay (500);

Write (be I); i s- 1;

REPEAT

z := exp (y);

i := I + 1; UNTIL i = 1000; Write (beI); Delay (4000); END MTIMEF.

mtimei.mod TEXT

"Modula-2 System for Z80 CP/M." See mfiIecpy.mod.

MODULE MTIMEI;

FROM Terminal IMPORT

(* standard module as defined by Wirth *) Write, WriteLn, WriteString;

FROM ASCII IMPORT be I ;

VAR

x, y. z ; INTEGER; i ; CARDINAL;

PROCEDURE Delay (x : CARDINAL);

(* variable Delay, x in milliseconds *)

VAR

i, j : CARDINAL;

BEGIN

FOR i :* 1 TO x DO FOR J :« 1 TO 18 DO END;

END;

END Delay;

BEGIN

x :« 11; y :« 2;

WriteString ('Blank'); WriteLn; Delay (500);

Write (be I); i :« 1;

REPEAT

z :« y;

1 := i + 1;

UNTIL i = 10000;

Write (bel);

Delay (4000);

WriteString ('Addition'); WriteLn; Delay (500);

Write (bel); i := 1;

REPEAT

2 :« x + y;

i s- i + 1;

UNTIL i - 10000;

Write (bel);

Delay (4000);

WriteString ('Subtraction'); WriteLn; Delay (500);

Write (bel); i := 1;

REPEAT

z :» x - y;

i := i + 1;

UNTIL i - 10000;

Write (bel);

Delay (4000);

WriteString ('Multiplication'); WriteLn; Delay (500);

Write (bel); i := 1;

REPEAT

z := x * y;

i :» i + 1;

UNTIL i - 10000;

Wr i te (be I);

Delay (4000);

WriteString ('Division'); WriteLn;

Delay (500);

Write (be I) ; i :■ 1;

REPEAT

z :« x DIV y;

I 2-1+1;

UNTIL i - 10000;

Write (bel);

Delay (4000);

WriteString ('Modulus'); WriteLn;

Delay (500);

Write (bel); i 1;

REPEAT

z x MOD y;

! I + 1;

UNTIL i - 10000;

Write (bel);

Delay (4000);

WriteString ('Good-bye...'); WriteLn;

END MTIMEI.

{continued)

BYTE LISTINGS SUPPLEMENT 203

mfI Iecpy.mod

TEXT l

Software Review: "Modula-2 System for Z80 CP/M," Brian R. Anderson.

March, page 225. Also download mscreen.mod, msieve.mod, mtimef.mod, and mtImei.mod.

MODULE MFILECPY;

FROM SeqlO IMPORT

FILE, FlleState, Open, Create, Close, Read, Write, EOF;

FROM Terminal IMPORT

ReadString, WriteLn, WriteString;

FROM Strings IMPORT STRING;

VAR

inFILE, outFILE ; FILE;

name, BAKname : STRING; (* file names *) c : CHAR;

PROCEDURE MakeBAK (in : STRING; VAR out : STRING; tag : STRING); VAR

i, j : CARDINAL;

BEGIN

i :« 0;

WHILE (in[I] # 0C) AND (in[i] # *.*) DO out[i ] :■ in[i);

INC (i);

END;

j := 0;

WHILE tag[j] # 0C DO out[iJ :* tag[j1; INC (i); INC (j); END;

out[i] := END MakeBAK;

0C; (* add NULL terminator *)

BEGIN

WriteString (Tile Backup Utility*); WriteLn; WriteLn;

WriteString ('Enter filename: ');

ReadString (name); WriteLn;

MakeBAK (name, BAKname, *.bak*);

IF Create (outFILE. BAKname) * FileOK THEN IF Open (inFILE. name) = FileOK THEN WHILE NOT EOF (inFILE) DO Read (inFILE, c);

Write (outFILE, c);

END;

IF (Close (inFILE) <> FileOK) OR (Close (outFILE) <> FileOK) THEN WriteString ('Error closing files...’); WriteLn;

ELSE

WriteString (BAKname); WriteString (' completed.*); WriteLn; END;

ELSE

IF Close (outFILE) <> FileOK THEN (* do nothing *)

END;

204 BYTE LISTINGS SUPPLEMENT

WriteString ('Error creating new file...'); Writeln; END;

ELSE

WriteString ('Error opening file...*); WriteLn;

END;

END MFILECPY.

I isting3.386 TEXT

Circuit Cellar; "Real-Time Clocks; A View Toward the Future." See listing!.386 for details.

10 MTOP = MTOP - 30 (RESET MTOP POINTER)

20 DBY(18H)=040H (ASSUME SMARTWATCH AT 4000H) 30 CALL 6000H (INITIALIZE THE SYSTEM)

40 REM NOW SET SMARTWATCH TIME 50 FOR X-MTOP+24 TO MTOP+17 STEP -1 60 READ C 70 XBY(X)=C

80 NEXT X

85 REM ZZ/01/85 14;25;00.00

90 DATA 85,11,01,05,14,25.00,00 100 CALL 6003H (WRITE THE VALUES) 110 CALL 6006H (READ THE VALUES) 120 PRINT MTOP+18 (SECONDS COUNTER) 130 GOTO 110

I 1st i ng1.386 TEXT

Circuit Cellar; "Real-Time Clocks: A View Toward the Future," Steve Ciarcia. March, page 112. Also download Iisting2.386, and Iisting3.386.

100 DIM N(200) ; DIM M(200)

110 REM

120 REM REV 1.5 11/8/85

130 REM 5832 REAL TIME CLOCK FOR BCC-52 I/O PORT 140 REM

150 PI-51200 : P2-51201 : P3-51202 : P4-51203

155 REM SET 8255 PORT A AS INPUT AND B&C AS OUTPUT 160 XBY(P4)=90H

170 REM PORT B IS ADDRESS AND PORT C IS CONTROL BUS

180 PRINT "ENTER 0 TO SET TIME OR 1 TO READ TIME", : INPUT A

190 ON A GOSUB 350,220

200 GOTO 180

210 GOTO 145

220 REM READ 13 5832 REGISTERS

230 XBY(P3)*20H : REM SET READ MODE

240 FOR A=0 TO 12

250 XBY(P2)=A : N(A)-XBY(P1)

260 NEXT A

270 REM DISPLAY CONTENTS

280 PRINT "DATE ",

290 PRINT N(10)*10+N(9),"/",N(8)*10+N(7),"/",N(12)*10+N(11)

300 PRINT "TIME ",

310 IF N(5)>«8 THEN N(5)-N(5)-8

320 PRINT (N(5)*10)+N(4)," : ".(N(3)*10)+N(2)." : ",(N(1)*10)+N(0)

330 PRINT

340 RETURN

350 REM SET TIME

360 XBY(P4)=80H : REM SET PORTS A.B.&C AS OUTPUT

370 REM MSB OF REG 5 12(0)/24(1) HRS k MSB-1 AM(0)/PM(1)

380 FOR A=0 TO 12

390 PRINT "REGISTER",A, : INPUT X

400 XBY(P2)«A : XBY(P1)«X

405 REM WRITE STROBE

410 XBY(P3)-10H : XBY(P3)-50H : XBY(P3)«10H : XBY(P3)«00H

420 NEXT A

430 XBY(P4)«90H : REM RESTORE READ PORT SETTINGS

440 PRINT

450 RETURN

(continued)

BYTE LISTINGS SUPPLEMENT 205

list)092.386 TEXT

Circuit Collar: "Real-Time Clocks: A View Toward the Future." See llstingl.386 for details.

E

10 REM APPLICATION PROGRAM USING ONLY BASIC TO DEMONSTRATE

20 REM SMARTWATCH REAL TIME CLOCK ON BCC52 COMPUTER CONTROLLER BOARD

30 CLEAR

40 STRING 200,15

50 $(1)-"SUNDAY"

60 $(2)«"MONDAY"

70 $(3)-"TUESDAY"

80 $(4)-"WEDNESDAY"

90 $ ( 5) -"THURSDAY"

100 $(6)=“FRIDAY"

110 $(7)«"SATURDAY"

120 REM

130 REM ************* MAIN MENU ******************************************** 140 REM

150 PRINT "0-READ DATE/TIME 1-ENTER NEW DATE/TIME ?"

160 G-GET

170 GOSUB 1350 : REM GET NUMBER 0-9

180 PRINT CHR(18),CHR(27),"Y" : REM CLR 4 HOME TERMITE TERMINAL

190 IF G=0 THEN GOSUB 790 : REM READ 4 DISPLAY DATE/TIME INFO 200 IF G=1 THEN G0SU8 250 : REM GATHER 4 SAVE NEW DATE/TIME INFO

210 GOTO 150 220 REM

230 REM ************* GATHER $ SAVE NEW DATE/TIME INFO ******************* 240 REM

250 J=XBY(4000H) : REM SAVE BYTE LOCATED IN 4000H TO REPLACE WHEN OONE

260 GOSUB 1420 : REM SENO PATTERN RECOGNITION CODES

270 PRINT "ENTER DATE MMDDYY"

280 G-GET

290 FOR Z-6 TO 8 : REM USE G(6) FOR MM. G(7) FOR DD. G(8) FOR YY

300 GOSUB 1350 : REM GET NUMBER 0-9

310 PRINT G. : REM ECHO NUMBER 0-9

320 H-G*16 : REM STORE NUMBER IN UPPER NIBBLE

330 GOSUB 1350

340 PRINT G.

350 G(Z)=H+G : REM COMBINE NUMBERS 1 IN UPPER NIBBLE, 1 IN LOWER NIBBLE

360 NEXT Z

370 PRINT

380 G=G(6) : REM

390 G(6)=G(7) : REM SWAP 6 & 7, NOW 6.7,8 IN DD/MM/YY

400 G(7)-G : REM

410 G(1)=0 : REM SET TENTHS k HUNDREDS OF A SECOND = 0

420 PRINT "DAY OF THE WEEK SUN=0 MON-1 TUE=2 WED-3 THU=4 FRI=5 SAT-6 ?"

430 G-GET

440 GOSUB 1350

450 PRINT G

460 PRINT

470 G(5)=G.0R.10H : REM OR BIT4 TO IGNORE RESET FROM PIN 1

480 PRINT "ENTER TIME HHMMSS"

490 G-GET

500 FOR Z-4 TO 2 STEP -1 : REM USE G(4) FOR HH. G(3) FOR MM, G(2) FOR SS

510 GOSUB 1350

520 PRINT G,

530 H=G*16

540 GOSUB 1350

550 PRINT G,

560 G(Z)«H+G

570 NEXT Z

580 PRINT

590 PRINT "IS THE TIME IN 0=24 HOUR FORMAT 1=12 HOUR FORMAT ?"

600 G=GET

610 GOSUB 1350

620 IF Gol THEN 680 : REM IF NOT 1 THEN JUMP

630 G(4)=(G(4).0R.80H) : REM OR BIT7 TO INDICATE 12 HOUR FORMAT

640 PRINT "IS IT 0=AM 1=PM ?"

650 G-GET

660 GOSUB 1350

670 IF G»1 THEN G(4)=(G(4).OR.20H) : REM OR BIT5 TO INDICATE PM

206 BYTE LISTINGS SUPPLEMENT

680 REM HOLD FOR TIME SYNCRONIZATION

690 PRINT “HIT ’0* TO GO SET THE NEW DATE/TIME"

700 GOSUB 1350

710 IF G<>0 THEN 700

720 GOSUB 1530 : REM STORE DATE/TIME INFO TO SMARTWATCH

730 XBY(4000H)=J : REM REPLACE BYTE TO 4000H

740 G=0

750 RETURN

760 REM

770 REM ************ READ & DISPLAY DATE/TIME ****************************

780 REM

790 J=XBY(4000H)

800 GOSUB 1420 : REM SEND PATTERN RECOGNITION COOES

810 GOSUB 1230 : REM READ SMARTWATCH REGISTERS

820 PRINT "TODAY IS " , $ ( (G(5 ).AND.7H)+1) : REM STRIP OFF DAY OF WEEK

830 $(8)«" / / REM INITIALIZE DATE STRING

840 Z*7 : REM USE G(7) MM REGISTER

850 X*1 : REM PLUG CHARACTERS INTO STRING STARTING AT POSITION 1

860 GOSUB 1630 : REM GET 2 CHARACTERS FROM G(Z) AND PLUG INTO STRING $(8)

870 Z-6

880 X=4

890 GOSUB 1630

900 Z=8

910 X*7

920 GOSUB 1630

930 $(9)«$(8) : REM SAVE IT IN $(9) FOR ANY FUTURE USE

940 PRINT $(9)

950 $(8" : REM INITIALIZE TIME STRING

960 G(9)«G(4)

970 IF fGm.AND.80H)=0 THEN 1020 : REM IF BIT7=0 THEN 24 HR FORMAT. JUMP 980 IF (G(4).AND.20H)=0 THEN ASC($(8),13)«41H : REM IF BIT5 = 0. PLUG A 990 IF (G(4).AND.20H)=20H THEN ASC($(8),13)«50H : REM IF BIT5 SET. PLUG P 1000 ASC($(8).14)-4DH : REM PLUG M

1010 G(9)«(G(4).AND.1FH) : REM STRIP OFF FORMAT FROM HOUR REGISTER

1020 Z-9

1030 X*1

1040 GOSUB 1630

1050 ASC($(8),3)=3AH : REM PLUG IN THE CHARACTER FOR COLON

1060 Z*3

1070 X=4

1080 GOSUB 1630

1090 ASC($(8),6)=3AH

1100 Z=2

1110 X-7

1120 GOSUB 1630

1130 Z«1

1140 X*10

1150 GOSUB 1630

1160 PRINT $(8)

1170 XBY(4000H)=J

1180 G=0

1190 RETURN 1200 REM

1210 REM ************ READ SMARTWATCH REGISTERS *************************

1220 REM 1230 FOR Z=1 TO 8 1240 G(Z)=0

1250 FOR X*=1 TO 8

1260 G=(XBY(4000H).AND.1) : REM G - BIT0

1270 IF G=0 THEN 1290 : REM BIT = 0, DON'T ADD ANYTHING TO REGISTER BYTE

1280 G(Z)-G(Z)+(2**(X-1)) : REM BUILD REGISTER BYTE FROM BITS RECEIVED

1290 NEXT X

1300 NEXT Z

1310 RETURN

1320 REM

1330 REM ************ GET NUMBER 0-9 ************************************

1340 REM 1350 G-GET

1360 IF G<48.0R.G>57 THEN 1350 1370 G-G-48 : REM ASC TO 0-9

1380 RETURN 1390 REM

1400 REM ************ INITIALIZE PATTERN RECOGNITION CODES **************

1410 REM 1420 G(1)*0C5H 1430 G(2)«3AH

{continued)

BYTE LISTINGS SUPPLEMENT 207

)

1440

G(3)-0A3H

1450

G(4)=5CH

1460

G(5)«0C5H

1470

G(6)«3AH

1480

G(7)=0A3H

1490

G(8)-5CH

1500 REM

1510 REM ************ SEND REGISTERS TO SMARTWATCH ***********************

1520 REM

1530 FOR Z-1 TO 8

1540 FOR X*1 TO 8

1550 IF (G(Z).AND.(2**(X-1)))<>0 THEN G-1 ELSE G-0 : REM STRIP OFF BIT

1560 XBY(4000H)=G : REM SEND BIT TO SMARTWATCH

1570 NEXT X

1580 NEXT Z

1590 RETURN

1600 REM

1610 REM ************ GET 2 CHARACTERS FROM G(Z) REGISTER, PLUG $(8) @ X 1620 REM V 9

1630 G«INT(G(Z)/16)

1640 ASC($(8),X)«G+48

1650 ASC($(8),X+1)-G(Z)-(G*16)+48

1660 RETURN

1670 REM

1680 REM ************ END ***********************************************

explorer.txt TEXT

Programming Insight. "Macintosh Explorer," Olav Andrade. March, page 145.

0EM

REM

REM

REM

REM

REM

REM

This program is to be made available at no charge.

Macintosh Explorer

Author: 0. Andrade CServe: 74726,1177

14 Shanley St.

Kitchener, Ontario

Canada

N2H 5N8

DEFINT A-Z:GOSUB 550 CLS:0N ERROR GOTO 4200:GOTO 2560 230 C2#=A0#:GOSUB 370:W=N FOR 16=0 TO 3 C2#=C2#+2

GOSUB 370:W0(I6)=N U0(I6)«F NEXT 16 N6=F:N3=F

N2=W0(0):N4=W0(1):GOSUB 420 K=0:WHILE K<4 AND U0(K):K=K+1:WEND A0#=A0#+2+2*K RETURN

370 N=PEEK(C2#):IF N>127 THEN N=N OR &HFF00 N=N*256+PEEK(C2#+1)rRETURN

420 14=0:WHILE((I4<06)AND(W AND 02(14))<>03(14)):14=14+1-WEND IF I4>=06 GOTO 500

S4=0:04$="":O0$=O1$(I4):B=F IF 05(I4)>0 THEN ON 05(I4)G0SUB 1460,1470,1560,1480.1490,1520,1720.1730,1740,1750 IF O5(I4)>10 THEN ON O5(I4)-10 GOSUB 2230,1770,1800,1570,1840.1870,1880,1900,1930,1970 IF 05(I4)>20 THEN ON O5(I4)-20 GOSUB 1990,2300.2020.2030,2050,2080,1600,2120,2320,1680 IF 05(I4)>30 THEN ON O5(I4)-30 GOSUB 1940,2360,2370,2380.2390,2400 IF NOT B THEN PRINT A0#;" ";O0$;" ";04$:G0T0 510

510 RETURN^ 1 " ^ $" ;HEX$(W) :FOR 16=0 TO 3:U0( I6)=F :NEXT

550 06-71:DIM 02(06),03(06),01$(06),05(06)

FOR 1=0 TO 06-1:READ 01$(I).02(1).03(1).05(1):NEXT

DATA reset, -1, 20080, 1. nop, -1, 20081. 1, stop, -1.

208 BYTE LISTINGS SUPPLEMENT

20082, 1. rte, -1, 20083, 1

DATA rts, -1. 20085, 1, trapv, -1, 2008$, 1, rtr, -1, 20087, 1,

swop, -8, 18496, 2

DATA "ext.w", -8, 18560, 2, "ext. I", -8, 18624, 2, link, -8, 20048,

3, unlk, -8, 20056, 4

DATA DATA DATA DATA DATA

32512, 10 DATA

19584, 11 DATA 18944,14 DATA DATA OATA 30

move, -8, 20064, 35, move, -8, 20072, 36, trop, -16, 20032, 5 nbcd, -64, 18432, 6. pea. -64, 18496, 6, move, -64, 16576, 32 move, -64, 17600, 34, move, -64, 18112, 33, tos, -64, 19136, 6 jsr, -64, 20096, 6. jmp, -64, 20160, 6, exg, -3592, -16064, 7 exg, -3592, -16056, 8, exg, -3592, -15992, 9. sbcd, -3600,

abed, -3600, -16128, 10, movem, -128, 18560, 11, movem, -128,

db, -3848, 20680, 12, stotBit, -256, 2048, 13, tst, -256,

cIr, -256, 16896, 14, neg, -256, 17408, 14, or. -256, 0, 30 not. -256, 17920, 14, and, -256, 512, 30. bsr, -256, 24832, 15 sub, -256, 1024, 30, empm, -3784, -20216, 16, add, -256, 1536,

DATA

14

eor,

-256, 2560, 30. cmp, -256, 3072,

30, negx,

-256, 16384,

DATA

16192,19

subx.

, -3792. -28416,17,

movep, -4040,

8, 18, mulu, -3684,

DATA

32576, 19

mu 1 s ,

, -3648, -15936, 19,

chk, -3648,

16768, 19,

dlvu, -3648,

DATA

12032, 17

di vs,

, -3648, -32320, 19,

lea, -3648,

16832, 31,

addx, -3792,

DATA

3840, 256, 22

memShifts, -1856, -8000,

20, s, -3904

, 20672, 21

, dynBit,

DATA

eor,

-3840, -20224, 23.

addq, -3840,

20480, 24,

subq, -3840,

20736, 24 DATA 4096, 27 DATA

-20480, 28 DATA

4096, 12288, 27

DATA dataRegShifts, -4096, -8192, 29, and. -4096, -16384, 28

A5=ASC( " 0 " ) :A6-ASC("a"):F=0:T-NOT F DIM S3$(3):S3$(0)-".b":S3$(1)-".w":S3$(2)-".I"

DIM W0(3).U0(3),C0$(16),B3$(4),S2$(4),M(16)

moveq, -3840, 28672, 25, b. -4096, 24576. 26. "move.b", -4096, sub, -4096, -28672, 28, "move.I", -4096, 8192, 27, cmp. -4096, or, -4096, -32768, 28. add. -4096, -12288, 28, "move.w".

C0$(0)-“t":C0$(1)-"f":C0$(2)-"hl":C0$(3)«"Is" C0$(4)="cc“:C0$(5)«"cs":C0$(6)«"ne":C0$(7)="eq" C0$(8)-"vc":C0$(9)-"vs":C0$(10)-"pl":C0$(11)-"m C0$(12)-"ge":C0$(13)-"lt":C0$(14)-"gt":C0$(15)« B3$(0)-"btst":B3$(1)-"bchg":B3$(2)-"bcIr":B3$(3)-" S2$(0)-"as":S2$(1)-"Is":S2$(2)-"rox":S2$(3)-"ro" CALL TEXTFONT(4):CALL TEXTSIZE(9)

B5-85:B4-15:S«278

bset"

DIM 18(4):I.-5:100-5:I8(0)-I00:18(1)-I.:I8(2)-I8(0)+B4:I8(3)-I8(1)+B5

DIM M0(4):M2-I.+B5+20:M3-I00:M0(0)-M3:M0(1)-M2:M0(2)-M0(0)+B4:M0(3)=M0(1)+B5

DIM

D7(4):D.-M2+B5+20:D00-I00:D7(0)«D00:D7(1)-0.:D7(2)=D7(0)+B4:D7(3)»D7(1)+B5 DIM D(4):D1«I.:02-100+84+5:O(0)=D2:D(1)-D1:D(2)-D(0)+B4:D(3)-D(1)+B5 DIM

D02(4):D04-M2:D05-D2:D02(0)=D05:D02(1)-D04:D02(2)-D02(0)+B4:D02(3)=D02(1)+B5 DIM L0(4):L2»D.:L3«D2:L0(0)=L3:L0(1)=L2:L0(2)»L0(0)+B4:L0(3)-L0(1)+B5 DIM A1(4):A3-D.+B5+20:A4-D2:A1(0)-A4:A1(1)-A3:A1(2)=A1(0)+84:A1(3)=A1(1)+B5 DIM V(4):V2«A3+B5+10:V3=D2:V(0)=V3:V(1)-V2:V(2)»V(0)+B4:V(3)=V(1)+B5 DIM Cl(4):C1(0)-0:C1(1)=0:C1(2)-V(2)+4:C1(3)=V(3)

DIM 101(1),I7(1):N1-1

DIM D9(310):D5-0:D3-0:B2“52:FOR 15=0 TO 27:READ D9(I5):NEXT DATA &h4e56, 0, 16890, 50, 12668, -5, 24 DATA 12668, 1, 22. 12668, 1, 44, 8572, 0, 0, 46, 8572, 0 DATA 512, 36, 17402, 60, 8521, 32. &ho002, &h4e5e, &h4e75 U=0:19-1:MI-2:D8-3:00-4

D03-5:A2-6:V0-7:L1=8

SI-Ml:RETURN 1100 E$»"“

ON M4+1 GOSUB 1130.1140,1150.1160.1170,1180,1190.1250 RETURN

1130 E$="d"+CHR$(R0+A5):RETURN 1140 E$-"o"+CHR$(R0+A5):RETURN 1150 E$«"(a"+CHR$(R0+A5)+")":RETURN 1160 E$="(a"+CHR$(R0+A5)+")+":RETURN 1170 E$="-(o“+CHR$(R0+A5)+“)":RETURN

{continued)

BYTE LISTINGS SUPPLEMENT 209

1180 E$-STR$(N2)+" (o"+CHR$(R0+A5)+")":N6«T:RETURN 1190 IF N2<0 THEN E$«"o"ELSE E$="d"

E$-E$+CHR$((N2 AND 4H7000)\4096+A5)

IF N2 AND 4H800 THEN E$-E$+ M .l“

E$»" (a"+CHR$(R0+A5)+", “+E$+")"

IF(N2 AND 4H80)THEN E$-STR$((N2 AND 4HFF)0R 4HFF00)+E$ELSE E$»STR$(N2 AND 4HFF)+E$

N6-T:RETURN

1250 ON R0+1 GOSUB 1280.1290.1310.1320.1380.1270.1270.1270 RETURN

1270 B-T:RETURN

1280 E$-"($"+HEX$(N2)+")":N6=T:RETURN 1290 GOSUB 1410:E$="($"+HEX$(N2)+I3$+")"

N6»T:N3=T:RETURN

1310 E$=STR$(N2)+"(pc)":N6-T:RETURN 1320 IF N2<0 THEN E$-'*o"ELSE E$="d"

E$=E$+CHR$((N2 AND 4H7000)\4096+A5)

IF N2 AND 4H800 THEN E$-E$+".l"

E$“"(pc, "+E$+”)"

IF(N2 AND 4H80)THEN E$-STR$((N2 AND 4HFF)0R 4HFF00)+E$ELSE E$«STR$(N2 AND 4HFF)+E$

N6-T:RETURN

1380 E$="#$"+HEX$(N2):N6«T IF S4=2 THEN GOSUB 1410:E$«E$+I3$:N3«T RETURN

1410 I3$-HEX$(N4):IF LEN(I3$)<4 THEN I3$=STRING$(4-LEN(13$).“0 M )+I3$

1420 RETURN 1460 04$-"":RETURN

1470 04$="d"+CHR$((W AND 7)+A5):RETURN 1480 04$="o“+CHR$((W AND 7)+A5):RETURN 1490 IF((W AND 15)>9)THEN 1510 04$-CHR$((W AND 15)+A5):RETURN 1510 04$=CHR$((W AND 15)+A6-10):RETURN 1520 M4=(W ANO &H38)\8:R0=(W AND 7)

GOSUB 1100:O4$-E$:IF N6 THEN U0(0)-T IF N3 THEN U0(1)-T RETURN

1560 04$-"o”+CHR$((W AND 7)+A5)+". "+STR$(N2):U0(0)-T:RETURN 1570 S4=(W AND &HC0)\64:M4-(W AND 4H38)\8:R0-(W AND 7):G0SUB 1100:04$=E$:O0$=O0$+S3$(S4)

1580 IF N6 THEN U0(0)«T:IF N3 THEN U0(1)-T 1590 RETURN

1600 M4«(W AND 4H38)\8:R0»(W AND 7)

1610 IF(W AND 4HF000)»4H1000 THEN S4-0ELSE IF(W AND 4HF000)-4H2000 THEN

S4-2ELSE S4=1

1620 GOSUB 1100:S0$=E$

1630 IF N6 THEN U0(0)-T:N6-F:IF N3 THEN U0(1)=T:N3=F:N2=W0(2):N4=W0(3)ELSE N2-N4:N4-W0(2)

1640 M4-(W AND 4H1C0)\64:R0-(W AND 4HE00)\512:GOSUB 1100:O4$=S0$+". “+E$ 1650 IF N6 THEN IF U0(0)THEN IF U0(1)THEN U0(2)-TELSE U0(1)-TELSE U0(0)-T 1660 IF N3 THEN IF U0(1)THEN IF U0(2)THEN U0(3)-TELSE U0(2)-TELSE U0(1)“T 1670 RETURN

1680 S4-(W AND 4HC0)\64:M4-(W AND 4H38)\8:R0-(W AND 7):O4$-"#$"+HEX$(N2):U0(0)-T:IF S4<>2 THEN 04$-04$+", "ELSE GOSUB 1410:N3-T:04$-04$+I3$+“, “

1690 IF((W AND 4H3F)«4H3C)THEN 04$-04$+"sr":GOTO 1700ELSE IF NOT N3 THEN N2=W0(1):N4=W0(2)ELSE U0(1)-T:N3-F:N2-W0(2):N4-W0(3)

1695 GOSUB 1100:04$=04$+E$

1700 O0$=O0$+S3$(S4):IF N6 THEN IF NOT U0(1)THEN U0(1)-T:IF NOT N3 THEN RETURNELSE U0(2)=TELSE U0(2)=T:IF N3 THEN U0(3)-T 1710 RETURN

1720 04$="d"+CHR$((W AND 4HE00)\512+A5)+". d"+CHR$((W AND 7)+A5):RETURN 1730 04$="a”+CHR$((W AND 4HE00)\512+A5)+". o"+CHR$((W AND 7)+A5):RETURN 1740 04$="d"+CHR$((W AND 4HE00)\512+A5)+". a"+CHR$((W AND 7)+A5):RETURN 1750 IF(W AND 8)THEN 1760ELSE 04$-"d"+CHR$((V» AND 7)+A5)+", d"+CHR$((W AND 4HE00)\512+A5):RETURN

1760 04$«"-(a"+CHR$((W AND 7)+A5)+"), -(a"+CHR$((W AND 4HE00)\512+A5)+")":RETURN

1770 O0$=O0$+C0$((W AND 4HF00)\256):04$="d"+CHR$((W AND 7)+A5)+", $"

1780 U0(0)=T:IF N2<0 THEN 04$=04$+STR$(N2)ELSE 04$=04$+" +"+STR$(N2)

1790 RETURN

1800 O0$=B3$((W AND 4H60)\64):M4=((W AND 4H38)\8):R0=(W AND 7)

1810 U0(0)=T:04$= ")jl"+STR$((4H1F AND N2)) + ". " :N2=N4:N4=W0(2) :GOSUB 1100:04$=04$+E$

1820 IF N6 THEN U0(1)=T:IF N3 THEN U0(2)«T 1830 RETURN

1840 IF(W AND 128)THEN O0$=O0$+".s": 04$-"$ "+STR$((W AND 4HFF)0R 4HFF00)+"

210 BYTE LISTINGS SUPPLEMENT

"+STR$(A0#+2-(W AND 4HFF)):RETURN

1850 IF(W AND 4HFF)=0 THEN U0(0)=T:IF N2<0 THEN 04$="$ "+STR$(N2)+"; "+STR$(A0#+4+N2):RETURN ELSE 04$="$ +"+STR$(N2)+"; "+STR$(A0#+4+N2):RETURN

1860 O0$=O0$+".s“: 04$="$ +"+STR$(W AND 4HFF)+"; "+STR$(A0#+2+(W AND

&HFF)):RETURN

1870 O0$=O0$+S3$((W AND 4HC0)\128):04$=“(a"+CHR$((W AND 7)+A5)+")+,

(o"+CHR$((W AND 4HE00)\512+A5)+")+":RETURN

1880 IF(W AND 8)THEN 1890ELSE 04$="d"+CHR$((W AND 7)+A5)+". d"+CHR$((W AND 4HE00)\512+A5):RETURN

1890 04$="-(a"+CHR$((W AND 7)+A5)+"), -(a"+CHR$((W AND 4HE00)\512+A5)+")":RETURN

1900 U0(0)=T:IF(W AND 64)THEN O0$=O0$+".I"ELSE O0$=O0$+".w"

1910 IF(W AND 128)THEN 04$="d"+CHR$((W AND

4HE 00)\512+A5) + "."+STR$(N2)+"(a"+CHR$((W AND 7)+A5)+")":RETURN 1920 04$=STR$(N2)+“(a"+CHR$((W AND 7)+A5)+"), d"+CHR$((W AND 4HE00)\512+A5):RETURN

1930 M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 1100:O4$=E$+". d"+CHR$((W AND 4HE00)\512+A5):G0T0 1950

1940 M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 1100:04$=E$+". a"+CHR$((W AND 4HE00)\512+A5)

1950 IF N6 THEN U0(0)=T:IF N3 THEN U0(1)=T 1960 RETURN

1970 O0$=S2$((W AND 4H600)\512):IF(W AND 256)THEN O0$=O0$+"I"ELSE O0$=O0$+"r" 1980 M4=(W AND 4H38)\8:R0=(W AND 7):GOSUB 1100:O4$=E$:GOSUB 1580:RETURN 1990 O0$=O0$+C0$((W AND 4HF00)\256):M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 1100:04$=E$:GOSUB 1580:RETURN

2000 O0$=B3$((W AND 4H60)\64):04$="d"+CHR$((W AND 4HE00)\512+A5)+". 2010 M4=(W AND 4H38)\8:R0=(W AND 7):G0SU8 1100:04$=04$+E$:GOSUB 1580:RETURN 2020 04$= *d”+CHR$((W AND 4HE00)\512+A5):GOTO 2040

2030 t0=(W AND 4HE00)\512: IF t0=0 THEN 04$="#8“ ELSE O4$="#"+CHR$(t0+A5)

2040 S4=(W AND 4HC0)\64 :O0$=O0$+S3$(S4):M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 1100:04$=04$+", "+E$:GOSUB 1580:RETURN 2050 04$=". d"+CHR$((W AND 4HE00)\512+A5)

2060 IF(W AND 128)THEN 04$="#"+STR$((W AND 4HFF)0R 4HFF00)+O4$:RETURN 2070 04$="#"+STR$(W AND 4HFF)+04$:RETURN

2080 O0$=O0$+C0$((W AND 4HF00)\256):IF(W AND 128)THEN O0$=O0$+".s“: 04$= M $"+STR$((W AND 4HFF)0R 4HFF00)+"; "+STR$(A0#+2-(W AND 4HFF)):RETURN

2090 IF(W AND 4HFF)=0 THEN U0(0)=T:O0$=O0$+".w": IF N2<0 THEN 04$="$ "+STR$(N2)+"; "+STR$(A0#+4+N2):RETURN ELSE 04$="$ +"+STR$(N2)+";

"+STR$(A0#+4+N2):RETURN

2100 O0$=O0$+".s“: 04$="$ +"+STR$((W ANO 4HFF))+“; "+STR$(A0#+2+(W AND

4HFF)):RETURN 2110 RETURN

2120 0=(W AND 4HE0)\64+1:0N 0 GOSUB 2160.2170.2180.2160,2170.2180.2170.2180 2130 ON 0 GOSUB 2190.2190.2190,2200,2200.2200.2210.2210 2140 IF N6 THEN U0(0)=T:IF N3 THEN U0(1)=T 2150 RETURN

2160 O0$=O0$+".b":S4=0:RETURN 2170 O0$=O0$+".w":S4=1:RETURN 2180 O0$=O0$+".I":S4=2:RETURN

2190 GOSUB 2220:04$=E$+", d"+CHR$((W AND 4HE00)\512+A5):RETURN 2200 GOSUB 2220:04$="d"+CHR$((W AND 4HE00)\512+A5)+". "+E$:RETURN 2210 GOSUB 2220:O4$»E$+", o"+CHR$((W AND 4HE00)\512+A5):RETURN 2220 M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 1100:RETURN 2230 IF(W AND 64)THEN O0$=O0$+“.I":S4=2ELSE O0$=O0$+".w":S4=1 2240 R2=N2:U0(0)=T:N2=N4:N4=W0(2)

2250 M4=(W AND 4H38)\8:R0=(W AND 7):G0SUB 1100 2260 IF N6 THEN U0(1)=T:IF N3 THEN U0(2)=T

2270 IF M4=4 THEN FOR 11=1 TO 15:M(I1)=2~(15-I1):NEXT:M(0)=-327681ELSE FOR 11=0 TO 14:M(I1)=2*I1:NEXT:M(15)»-32768!

2280 GOSUB 2440:IF(W AND 4HF00)=4H800 THEN 04$=04$+'\ "+E$ELSE 04$=E$+", "+04$ 2290 RETURN

2300 04$="d"+CHR$((W AND 4HE00)\512+A5)

2310 O0$=B3$((W AND 4HC0)\64):M4=((W AND 4H38)\8):R0=(W AND 7):G0SUB 1100:O4$=O4$+", "+E$:GOSUB 1580:RETURN

2320 IF(W AND 32)THEN 04$="d"+CHR$((W AND 4HE00)\512+A5)ELSE t0=(W AND 4HE00)\512: IF t0=0 THEN 04$=#8" else O4$="#"+chr$(t0+A5)

2330 04$=04$+", d"+CHR$((W AND 7)+A5)

2340 O0$=S2$((W AND 4H18)\8):IF(W AND 256)THEN O0$=O0$+"I"ELSE O0$=O0$+"r"

2350 O0$=O0$+S4$((W AND 4HC0)\64):RETURN 2360 GOSUB 1520:O4$="sr, "+04$:RETURN 2370 GOSUB 1520:O4$=O4$+", sr":RETURN 2380 GOSUB 1520:O4$=O4$+", ccr":RETURN 2390 GOSUB 1480:04$=04$+", usp":RETURN 2400 GOSUB 1480:O4$="usp, "+04$:RETURN 2410

2420 REM return movem operand (extension word decoding)

Continued)

BYTE LISTINGS SUPPLEMENT 211

2430

2440 FOR 11-0 TO 1

2450 F0-T:IF 11-0 THEN 04$-"“:R$-"d"ELSE R$-"o":IF 04$<>"”THEN IF M(15)<0 AND(R2 AND &HFF00)<>0 THEN 04$-04$+"/"ELSE IF M(15)>0 AND(R2 ANO &HFF)<>0 THEN 04$-04$+"/”

2460 I2»0:WHILE I2<8

2470 IF(M(I2+I1*8)AN0 R2)-0 THEN J0-I2+1:GOTO 2510

2480 IF F0 THEN 04$-04$+R$+CHR$(I2+A5):F0=FELSE 04$-04$+“, "+R$+CHR$(I2+A5)

2490 J0-I2+1:WHILE J0<8 AND(M(J0+I1*8)AND R2):J0-J0+1:WEND

2500 IF(M(J0+I1*8-1)AND R2)AN0 J0>12+1 THEN O4$-O4$+"-"+R$+CHR$(J0+A5-1)

2510 I2-J0:WEND 2520 NEXT:RETURN 2530

2540 REM main loop 2550

2560 L-F:GOSUB 2950 2570 WHILE NOT L 2580 GOSUB 2650

2590 ON R1 GOSUB 2820,2820,2820,3130.3230,3420.3450.2615 2600 WENO 2610 ENO

2615 IF MOUSE(0)<>0 THEN L-T:SYSTEMELSE RETURN 2620

2630 REM determine mouse region 2640

2650 006-MOUSE(1)-I.:007-MOUSE(2)-I00:IF 0<=D06 AND D06<B5 AND 0C-D07 AND D07<=B4 THEN R1-I9:D01=MOUSE(0):RETURN

2660 D06=MOUSE(1)-M2:D07=MOUSE(2)-M3:IF 0<=D06 AND D06<B5 AND 0<-D07 AND D07<=B4 THEN R1-M1:D01-MOUSE(0):RETURN

2670 D06-MOUSE(1)-D.:D07-MOUSE(2)-D00:IF 0<-D06 AND D06<B5 AND 0<-D07 AND D07<-B4 THEN R1-08:D01-MOUSE(0):RETURN

2680 D06-MOUSE(1)-D1:D07-MOUSE(2)-D2:IF 0<-D06 AND D06<B5 AND 0C-D07 AND D07<=B4 THEN R1=D0:D01=MOUSE(0):RETURN

2690 D06-MOUSE(1)-D04:D07-MOUSE(2)-D05:IF 0C-D06 AND D06<B5 AND 0<=D07 AND D07<-84 THEN R1-003:001-MOUSE(0):RETURN

2695 D06-MOUSE(1)-L2:D07-MOUSE(2)-L3:IF 0<-D06 AND D06<B5 AND 0<-D07 AND D07<-B4 THEN R1-L1:D01-MOUSE(0):RETURN

2700 D06»MOUSE(1)-A3:007-MOUSE(2)-A4:IF 0<=D06 AND D06<B5 AND 0<-D07 AND O07<=B4 THEN R1-A2:D01-MOUSE(0):RETURN

2710 D06»MOUSE(1)-V2:D07-MOUSE(2)-V3:IF 0<-D06 AND D06<85 AND 0<-D07 AND D07<=B4 THEN R1-V0:D01-MOUSE(0):RETURN 2720 R1-U:D01-MOUSE(0):RETURN 2730

2740 REM select a path 2750

2760 ON SI GOSUB 2780.2790.2800 2770 RETURN

2780 CALL INV£RTRECT(VARPTR(18(0))):RETURN 2790 CALL INVERTRECT(VARPTR(M0(0))):RETURN 2800 CALL INVERTRECT(VARPTR(D7(0))):RETURN 2810

2820 IF MOUSE(0)=0 THEN RETURNELSE ON SI GOSUB 2880.2890.2900 2830 ON R1 GOSUB 2850,2860,2870

2840 S1-R1:WHILE MOUSE(0)=1:WEND:GOSUB 2940:RETURN

2850 A0#-C:RETURN

2860 A0#-M5#:RETURN

2870 A0#=D4#:RETURN

2880 C-A0#:RETURN

2890 M5#=A0#:RETURN

2900 D4#-A0#:RETURN

2910

2920 REM draw screen controls 2930

2940 CALL ERASERECT(VARPTR(C1(0))) , vvv

2950 CALL M0VET0(I8(1)+10.I8(2)-5):PRINT"input";:CALL FRAMERECT(VARPTR(I8(0))) 2960 CALL MOVETO(M0(1)+10,M0(2)-5):PRINT"memory";:CALL

FRAMERECT(VARPTR(M0(0))) , , ,

2970 CALL MOVETO(D7(l)+10.D7(2)-5):PRINT"disk";:CALL FRAMERECT(VARPTR(D7(0))) 2980 CALL MOVETO(D(1)+10,D(2)-5):PRINT"disassemble";:CALL FRAMERECT(VARPTR(D(0;))

2990 CALL MOVETO(D02(1)+10.D02(2)-5):PRINT"dump“;:CALL FRAMERECT(VARPTR(D02(0)))

2995 CALL MOVETO(L0(1)+10,L0(2)-5):PRINT"quit";:CALL FRAMERECT(VARPTR(L0(0))) 3000 CALL M0VET0(A1(1)+5,D7(2)-5):PRINT"address";

3010 CALL MOVETO(V(1)+5,D7(2)-5):PRINT"vaIue“;

3020 CALL M0VET0(A1(1)+5,A1(2)-5):PRINT A0#;:CALL FRAMERECT(VARPTR(A1(0)))

3030 CALL MOVETO(V(1)+5,V(2)-5):0N SI GOSUB 3050.3070,3080:PRINT VI$;:CALL

212 BYTE LISTINGS SUPPLEMENT

FRAMERECT(VARPTR(V(0)))

3040 GOSUB 2760:RETURN

3050 IF A0#>=N1 THEN V1$-"?"ELSE IF P THEN V1$=STR$(I01(A0#))ELSE V1$=STR$(I7(A0#))

3060 RETURN

3070 C2#=A0#:GOSUB 370:VI$«STR$(N):RETURN

3080 IF 0>A0|ff-D5*256 OR A0#-D5*256>«2*D3 THEN V1$="?”ELSE V1$=STR$(D9((A0#D5*256)\2+B2))

3090 RETURN 3100

3110 REM mouse in disassemble button 3120

3130 IF MOUSE(0)=0 THEN RETURN 3140 WHILE MOUSE(0)<>0 3150 CALL MOVETO(0,S)

3160 ON SI GOSUB 3730,230.3990: ’pick o path 3170 GOSUB 2940:001-MOUSE(0)

3180 WEND 3190 RETURN 3200

3210 REM mouse in dump button 3220

3230 IF MOUSE(0)«0 THEN RETURN 3240 WHILE MOUSE(0)<>0 3250 CALL MOVETO(0,S)

3260 ON SI GOSUB 3820,3330,4100 3270 GOSUB 2940:001-MOUSE( 0 )

3280 WEND 3290 RETURN 3300

3310 REM dump input path 3320

3330 I2$-'"':PRINT A0#;"

3340 FOR 10=0 TO 15

3350 I1=PEEK(A0#):IF I1<16 THEN PRINT”0";HEX$(I1);ELSE PRINT HEX$(I1);

3360 IF ASC(" ")<I1 AND I1<128 THEN I2$-I2$+CHR$(I1)ELSE I2$-I2$+“."

3370 A0#=A0#+1:NEXT

3380 PRINT" ";12$:RETURN

3390

3400 REM mouse in address box 3410

3420 IF MOUSE(0)-0 THEN RETURN

3430 CALL INVERTRECT(VARPTR(A1(0))):CALL M0VET0(A1(1)+5,A1(2)-5):B1-T:G0SUB 3520

3440 CALL INVERTRECT(VARPTR(A1(0))):D01-MOUSE(0):A0|»N5#:GOSUB 2940:RETURN 3450 IF MOUSE(0)-0 THEN RETURN

3460 CALL INVERTRECT(VARPTR(V(0))):CALL MOVETO(V(1)+5,V(2)-5):0N SI GOSUB 3650,3645,3645

3470 D01»MOUSE(0):IF N5#>32767 THEN N5#=N5#-65536!

3480 VI-N5#:RETURN

REM fetch keys: address or input

3520 I1$-INKEY$:IF I1$=""THEN 3520

3530 IF ASC(11 $)—13 THEN IF N0 THEN N5#—1*N5#:RETURNELSE RETURN 3540 IF B1 THEN N5#-0:B1-F:H=F:N0=F:IF I1$-”$“THEN H-T:PRINT I1$;:G0T0 3520ELSE IF I1$-”-"THEN PRINT 11$;:N0-T:GOTO 3520

3550 IF“0"<«I1$AN0 I1$<«"9"THEN PRINT 11$;:A7-ASC(I1$)-ASC("0"):IF H THEN N5#-N5#*16+A7:G0T0 3520ELSE N5#-N5#*10+A7:GOTO 3520

3560 IF"A“<«I1$AND I1$<-"F"THEN IF NOT H THEN BEEP:GOTO 3520ELSE PRINT 11$;:N5#=N5#*16+ASC(11$)-ASC("A”)+10:GOTO 3520

3570 IF"o"<«I1$AN0 I1$<-"f"AND H THEN PRINT 11$;:N5#-N5#*16+ASC(11$)ASC("o")+10:GOTO 3520 3580 BEEP:GOTO 3520

3620 P-NOT P:IF P THEN ERASE 101:OIM 101(A0#+1)ELSE ERASE I7:DIM I7(A0#+1)

3630 FOR 11-0 TO N1-1.-IF P THEN I01(I1)-I7(I1)ELSE I7(11 )-I01 (II)

3640 NEXT:N1-A0#+1 3645 RETURN

REM disassemble input 3650 IF A0#>-N1 THEN GOSUB 3620

3660 B1-T:GOSUB 3520:N5#-N5#-65536!*INT(N5#/65536!):IF N5#>32767 THEN N5#-N5|65536!

3670 IF P THEN 101(A0#)-N5#ELSE I7(A0#)-N5#

3680 A0#-A0#+1:GOSUB 2940:RETURN

3730 IF A0#>N1 THEN W—1ELSE IF P THEN W-I01(A0#)ELSE W-I7(A0#)

3740 P0-A0#:FOR 16-0 TO 3:P0«P0+1:IF P0>-N1 THEN W0(I6)—1ELSE IF P THEN W0(I6)«I01(P0)ELSE W0(I6)-I7(P0)

3750 U0(I6)-F:NEXT:N6-F:N3-F

BYTE LISTINGS SUPPLEMENT 213

3760 N2-W0(0):N4-W0(1):GOSUB 420

3770 K-0:WHILE K<4 AND A0#+1+K<N1 AND U0(K):K-K+1:WEND 3780 A0#-A0#+1+K:RETURN REM dump disk

3820 PRINT A0#;" M ;:12$-"":FOR 10-0 TO 7

3830 IF A0#>=N1 THEN PRINT"????”;:I2$-I2$+“ M :GOTO 3880

3840 IF P THEN 11-101(A0#)ELSE I1-I7(A0#)

3850 I3$=HEX$(I1):IF LEN(I3$)-4 THEN PRINT I3$;ELSE PRINT STRING$(4LEN(13$),"0");13$;

3860 IF(ASC(" ”)<INT(I1\256))AND(INT(I1\256)<128)THEN I2$-I2$+CHR$(INT(I1\256))ELSE I2$-I2$+".«

3870 IF ASC(“ ")<(I1 AND 255)AND(I1 AND 255)<128 THEN I2$=I2$+CHR$(II AND 255)ELSE I2$=I2$+".“

3880 A0#=A0 j|l+1: NEXT: PR I NT " “;I2$

3890 RETURN

REM fetch a disk sector

3930 B0«F:D5»INT(A0#/512):IF 05 AND 64 THEN D9(15)-(05 OR &HFF80)*512ELSE D9(15)-(D5 AND tH7F)*512

3935 D9(14)=05\128:D5-2*D5:D6I-VARPTR(D9(0)):CALL D6!

3940 D3-(D9(28+20)*256+D9(28+21))\2:IF A0#-D5*256>-2*D3 THEN B0-T

3950 RETURN

REM disassemble disk

3990 IF A0#-D5*256<0 OR A0#-D5*256>2*D3 THEN GOSUB 3930:IF B0 THEN BEEP:RETURN 4000 P0=(A0#-256*D5)\2:A0#-2*P0+256*D5:W-D9(P0+B2)

4010 FOR 16-0 TO 3:P0=P0+1:IF P0>-D3 THEN J#-A0#:A0#=A0#+2*P0:GOSUB 3930:P0-0:A0#-J#:IF B0 THEN W0(I6)—1:GOTO 4030 4020 W0(I6)=D9(P0+B2)

4030 U0(I6)=F:NEXT:N6-F:N3-F 4040 N2-W0(0):N4-W0(1):GOSUB 420 4050 K-0:WHILE K<4 AND U0(K):K-K+1:WEND 4060 A0#=A0#+2+2*K:RETURN REM dump disk

4100 IF 2*INT(A0#/2)<>A0#THEN A0#-A0#-1

4105 PRINT A0#;“ “;:I2$«“":FOR 10=0 TO 7

4110 IF A0#-D5*256<0 OR A0#-D5*256>-2*D3 THEN GOSUB 3930:IF B0 THEN PRINT"????";:I2$«I2$+" ":GOTO 4160

4120 I1=D9((A0#-D5*256)\2+82)

4130 I3$»HEX$(I1):IF LEN(I3$)-4 THEN PRINT I3$;ELSE PRINT STRING$(4LEN(13$),"0");13$;

4140 IF(ASC("*")<INT(I1\256))AND(INT(I1\256)<128)THEN 12$-12$+CHR$(INT(11\256))ELSE I2$-I2$+"."

4150 IF ASC(" ")<(I1 AND 255)AND(I1 AND 255)<128 THEN I2$-I2$+CHR$(I1 AND 255)ELSE I2$-I2$+“.“

4160 A0#=A0#+2:NEXT:PRINT" ";I2$

4170 RETURN

REM expand the input path array

4200 IF NOT(ERL=3620 AND ERR=7)THEN ON ERROR GOTO 0

4210 BEEP:BEEP:P=NOT P:IF P THEN DIM I7(1)ELSE DIM 101(1)

4220 GOSUB 2940:RESUME 2570

diophant.bas TEXT

Mathematical Equations, "Diophantine Equations," Robert T. Kurosaka, March, page 343.

10 ******************************************

20 '* DIOPHANTINE EQUATION SOLVER *

30 * * BY BOB KUROSAKA *

40 '*****************************************

50 CLS

60 PRINT "This program solves equations of the form AX + BY = C,"

70 PRINT "where A, B, C, X, and Y are all integer values."

80 PRINT :PRINT "Enter your equation as shown in the general form."

90 PRINT "For example, enter 154X + 69Y « 5000 or 154X - 69Y = 5000."

100 PRINT "Do not enter negative coefficients with parentheses."

110 PRINT "That is, do NOT enter 154X + (-69Y) = 5000."

120 PRINT :PRINT "The program will not work properly for the degenerate case" 130 PRINT "where either A or B is 0."

140 PRINT :INPUT "Enter equation";EQUATI0N$:A$-EQUATION$

150 REM DEFINE A READABLE FUNCTION FOR DISCARDING LEFTMOST CHARACTERS.

160 DEF FNDROP.LEFT$(A$)=RIGHT$(A$,LEN(A$)-1)

170 REM PARSING ROUTINE 180 A*VAL(A$)

214

BYTE LISTINGS SUPPLEMENT

March

190 IF A=0 THEN A=1:IF LEFT$(A$,1)="-" THEN A—1 200 A$=FNDROP.LEFT$(A$)

210 DISCARD$=LEFT$(A$,1)

220 WHILE DISCARD$<>"+" AND DISCARD$<>"-"

230 A$=FNDROP.LEFT$(A$)

240 DISCARD$=LEFT$(A$,1)

250 WEND 260 B=VAL(A$)

270 IF B=0 THEN B=1:IF DISCARDS-"-" THEN B—1 280 WHILE DISCARD$<>"-"

290 AS-FNDROP.LEFTS(A$)

300 DISCARD$-LEFT$(AS,1)

310 WEND

320 AS-FNDROP.LEFTS(A$)

330 C-VAL(AS)

340 IF AoINT(A) OR BoINT(B) OR CoINT(C) THEN PRINT "NOT A DIOPHANTINE EQUATION":GOTO 760 350 REM END OF PARSING ROUTINE 360 REM EUCLIDEAN ALGORITHM FOR FINDING GCD.

370 REM FIRST, INITIALIZE THE TERMS FOR THE ALGORITHM

380 IF ABS(A)>=ABS(B) THEN DIVIDEND-A:DIVISOR=B

390 IF ABS(A)<ABS(B) THEN DIVISOR=A:DIVIDEND=B:SWAP.XY$="YES"

400 REM USE ‘FIX’ INSTEAD OF *INT' TO TRUNCATE RATHER THAN ROUND NEGATIVE #s. 410 QUOTIENT-FIX(DIVIDEND/DIVISOR)

420 REMAINDER»DIVIDEND-DIVISOR*QUOTIENT

430 REM XI-ONGOING COUNT OF X’, Y1-ONGOING COUNT OF Y*. YOU CAN KEEP TRACK OF ALL ONGOING COUNTS BY ONLY USING THE PREVIOUS 2 VALUES FOR X' AND Y\ SO WE ONLY NEED XI, X2, X3. AND Y1, Y2, Y3.

440 X1 = 1:Y1—QUOTIENT

450 REM IF EITHER A OR B IS AN EVEN MULTIPLE OF THE OTHER, THEN EITHER X’ OR Y’WILL EQUAL 1 WHILE THE OTHER EQUALS 0.

460 IF REMAINDER-0 THEN X2-0:Y2-1:GOTO 620 470 DIVIDEND-DIVISOR:DIVISOR-REMAINDER 480 QUOTIENT-FIX(DIVIDEND/DIVISOR)

490 REMAINDER-DIVIDEND-DIVISOR*QUOTIENT 500 X2—QUOTIENT*X1:Y2-1-QUOTIENT*Y1

510 REM IF A GCD IS FOUND ON THE SECOND ITERATION OF THE EUCLIDEAN ALGORITHM, THEN X'=X1, Y'-Y1. IN ALL SUBSEQUENT CASES. X’-X2, Y’-Y2.

520 IF REMAINDER-0 THEN X2-X1:Y2-Y1:GOTO 620

530 REM THE FIRST TWO ITERATIONS ARE THE ONLY ONES THAT DO NOT FOLLOW THE PATTERN: X(N)=X(N-2)-QUOTIENT*X(N-1), Y(N)-Y(N-2)-QU0TIENT*Y(N-1).

540 WHILE REMAINDERO0

550 DIVIDEND-DIVISOR:DIVISOR-REMAINDER

560 QUOTIENT-FIX(DIVIDEND/DIVISOR)

570 REMAINDER-DIVIDEND-DIVISOR*QUOTIENT

580 IF REMAINDER-0 THEN 610

590 X3-X1-QUOTIENT*X2:Y3-Y1-QUOTIENT*Y2

600 X1-X2:X2-X3:Y1-Y2:Y2-Y3

610 WEND

620 REM CALCULATE BASIC SOLUTION FOR AX + BY = C FROM GCD RESULTS. WHICH HAVE PROVIDED AX’ + BY 1 = D BASIC SOLUTION.

630 D=DIVISOR:E=C/D

640 IF C/D<>INT(C/D) THEN PRINT "NO INTEGER SOLUTIONS.":GOTO 760 650 IF SWAP.XY$-"YES" THEN SWAP X2.Y2

660 PRINT "The boslc solution to the Dlophontine equation,"

670 PRINT EQUATION$;" is:"

680 PRINT "X - ";X2*E:PRINT "Y - ";Y2*E

690 PRINT "The GCD of ";A;" and ";B;" is:";ABS(D)

700 PRINT "The parametric equations for all integer answers is:"

710 PRINT "X - ";X2*E;:IF B/D>0 THEN PRINT " +";

720 PRINT B/D;"N, and"

730 PRINT "Y »" ;Y2*E; : IF A/D<0 THEN PRINT " +"; ELSE PRINT " -";

740 PRINT ABS(A/D);"N"

750 PRINT "for all integer values N."

760 END

BYTE LISTINGS SUPPLEMENT 215

216 BYTE LISTINGS SUPPLEMENT

runkut.doc TEXT

"The Runge-Kutta Methods # " Benku Thomas. ApriI, page 191.

1. RUNKUT - AN INITIAL VALUE ORDINARY DIFFERENTIAL EQUATION SOLVER.

1.1. INTRODUCTION

RUNKUT Is a subroutine that contains three Runge-Kutta initial value ordinary differential equation (IVP ODE) solvers They are:

A fourth order Fehlberg method.

- A fifth order Verner method.

An seventh order Verner method.

RUNKUT solves coupled IV ODE’s of the form:

Y* = F(x, Y)

There is no limit to the number of coupled equations in a system to be solved other than the amount of memory available. The differential equations are defined in a user-supplied subroutine—more about that later. The subroutine is called using the following FORTRAN call statement:

CALL RUNKUT(XA,Y,XB,NEQN,TOLA,TOLR.HSTART,WORK, k IMETH,IERROR.ICOM,FUNC)

and must be called from a main "calling" program.

1.2. VARIABLES PASSED TO RUNKUT.

The variables passed are explained below and are listed in the order in which they appear in the call statement. The superscripted numbers refer to notes appearing at the end of this section.

XA (Real-Input)

XA is the starting point of the interval over which integration of the ODE’s is to be per formed.(1)

Y (Real array of size NEQN - Input/Output)

On entry, Y must contain the initial values of the Y-variables—that is Y must contain the solutions at the point XA. On exit from RUNKUT, Y wiI I contain the solutions at the end of the specified interval—that is at XB.(2)

XB (Real-Input)

XB specifies the end of the interval over which integration Is to be performed—the point at which solutions to the differential equations are desired.(1,2)

NEQN (Integer-Input)

NEQN specifies the number of coupled differential equations In the system to be solved.

TOLA (Real-Input)

TOLA Is the absolute error tolerance required on the solution.(3)

(continued)

BYTE LISTINGS SUPPLEMENT 217

TOLR (Real-Input)

TOLR Is the relative error tolerance required on the solution.(3)

HSTART (Rea 1-Input/Output)

On the very first call to RUNKUT In a caI I Ing‘sequence,

HSTART must contain a non-zero value as an Initial estimate for the step-sIze.(1) The actual value used Is relatively unimportant as the program will optimize step-sizes to keep the tolerances within specified limits and keep the number of function evaluations to a minimum. It is left to the user’s discretion to choose a value that will not require excessive readjustment by the program. On exit from RUNKUT, this variable will contain the last step size used by the program. It is recommended that for subsequent calls to RUNKUT, the step size returned by the program be used as the value for HSTART to solve the equations over the Immediately following interval.

WORK (Real array of minimum size NEQN*17 - Input)

This is a work area made available to RUNKUT by the calling program.

IMETH (Integer-Input)

Indicates to the solver, the order of the method to be used. IMETH can take on the following values:

1. - Fourth order Fehlberg method

2. - fifth order Verner method

3. - seventh order Verner method

While solving a given set of differential equations it is possible to change the order of the method over sucessive intervals simply by setting IMETH to the desired value and resetting IC0M(1) to 0 on each subsequent call to RUNKUT in which a change of order is required.(4)

IERROR (Integer-Output)

IERROR is an error status indicator returned by RUNKUT after each call. It can have one of the following values:

0 - no error.

1 - the sum of TOLA and TOLR Is less than 100 times machine

epsilon. This can be caused by setting both TOLA and TOLR to 0, or by specifying values that are too small for the program to handle sucessfully. In this case TOLR is set to a default value.

2 - the problem is too stiff for the method to handle, or

there is a discontinuity in the function. It is impossible to proceed in either case.(2)

3 - both conditions 1 and 2 above have occured.

IERROR is set to 0 on every entry to RUNKUT.

ICOM (Integer array of size 4)

ICOM is a communications vector. Each array element is used to pass a specific item of information (as defined below) to and from the subroutine.

ICOM(1) (Input)

ICOMM^ must be set to 0 on the first call to RUNKUT.

IC0M(1) is internally set to a non-zero value by the program after the first call. For subsequent calls to RUNKUT with the same set of equations, IC0M(1) must be left at this non-zero value. It is possible to change the order of the method used (see also IMETH) over sucessive intervals. In this case IC0M(1) must be reset to 0 each time the order of the method is changed.(4)

IC0M(2) (Input)

A flag that indicates to the program whether to perform checks on the specified values of TOLA and TOLR.

0 - no checking of the error tolerances.

1 - program checks if the sum of TOLA and TOLR is at least 100 times machine epsilon. If not, TOLR is set to a default value and the error indicator IERROR is set to 1.

218 BYTE LISTINGS SUPPLEMENT

If IC0M(2) is set to 0, the program assumes that it will be receiving non-zero values of at least one of TOLA or TOLR. Failure to check this before entry to RUNKUT could result in fatal program errors. Also, as will be shown in an example, decreasing the error tolerances does not always result in improved solution accuracy.

IC0M(3) (Input)

A flag that indicates to the program whether to use the default values of mimimum and maximum step size set by the subroutine.(5)

0 - default values of the maximum and minimum step size are used.

1 - allows the user to set values for the maximum and minimum permissible step size. These values are set by including the following FORTRAN common block statement in the main "caI Iing" program:

COMMON /CONS/HMIN,HMAX IC0M(4) (Output)

Status flag that indicates the presence of round-off error in the solution.

0 - No round-off error.

1 - Severe round-off error possible in answer.

IC0M(4) is reset to 0 on entry to RUNKUT.

FUNC (Function name)

FUNC is replaced by the name of the subroutine that is part of the main user routine In which the differential equations are specified (See section on user supplied routines). The subroutine name must be declared external by the following FORTRAN statement:

EXTERNAL [SUBROUTINE NAME].

1.2.1. NOTES

1. XA could be greater than XB. In other words it is possible to use RUNKUT to solve the differential equations in a negative X-direction given initial values at XA. In that case the step-size will also be negative. HSTART could be specified as a negative value, but that is not essential as the program internally adjusts the algebraic sign of the step-size.

2. If a discontinuity or extreme stiffness is encountered, RUNKUT will return in XB, the value of X closest to the point of discontinuity or stiffness, at which the solutions are still within the specified error bounds.

The array Y wiI I then contain solutions at this value of X.

3. If the sum of TOLA and TOLR is less than 100 times machine epsilon (for example if neither were defined in the main program), TOLR is set to a default value of 10(6) times machine epsilon. TOLA is not set to any default value. The program uses a combination of TOLA and TOLR to determine the accuracies of the solutions, and specifying TOLR to a certain value almost always gives better results than specifying TOLA to the same value.

4. Changing the order of the method on every subsequent call to RUNKUT with a given system of equations can lead to excessive computaion times since a large number of constants are re-evaluated each time the order is changed.

5. The default values used by the subroutine are 10(-8) for HMIN, and for HMAX as follows:

0.5 - if the fourth order method is used.

1.0 - If the fifth order method is used.

2.0 - If the seventh order method is used.

( continued)

BYTE LISTINGS SUPPLEMENT 219

However, If ony of these values are larger than the absolute value of the Interval width, HMAX Is set to the Interval width. It is sometimes necessary to specify HMAX to a small value to keep the step sizes to relatively small values that keep the runge-kutta methods within regions of stability. The subroutine detects the onset of problem "stiffness" or the occurence of a discontinuity In the function by checking if the step size is smaller than HMIN. If the equations are being solved in the negative X-direction, HMIN and HMAX are the smallest and largest permissible step sizes in the negative X-direction respectively. In other words, HMIN and HMAX always define absolute constraints on the step size.

6. Machine epsilon on the IBM PC is very much a function of the compiler used (even with an 8087 math coprocessor installed). For example Microsoft's Fortran-77 compiler (with 8087 support) generates an epsilon of about 10(-16), whereas IBM/Ryan-McFarI and's Professional Fortran-77 generates an epsilon of about 10(-20)

1.3. THE USER-SUPPLIED ROUTINES Two routines must be supplied:

1. A main "calling" program that calls RUNKUT. It must also define the Initial values of Y at XA, set TOLA and TOLR, set IC0M(1) to 0 on the first call to RUNKUT. define the number of equations in the sytstem to be solved, dimension a WORK array for RUNKUT, and check for the error status as passed back from RUNKUT through IERROR. See the examples at the end of this section.

2. A subroutine containing the system of differential

equations. The subroutine name must be declared EXTERNAL in the main calling program and its name passed to RUNKUT through the parameter FUNC-see above. The subroutine is defined using the foilwing FORTRAN statement:

SUBROUTINE [FUNC] (X.Y.YPRIME.NEQN)

where the parameters have the following definitions:

X (Real)

Contains the current value of X as set in RUNKUT. Do not alter this value within [func]

Y (Real - array of size NEQN)

Contains the current solutions at X. Do not alter in [func].

YPRIME (Real - array of size NEQN)

YPRIME is set in the subroutine to the differentials dy/dx as follows:

YPRIME(1) - F/1/(X,Y(1),...,Y(NEQN))

YPRIME(NEQN)*F/NEQN/(X,Y(1).Y(NEQN))

where F/i/ is the i'th differential function.

1. RUNKUT - AN INITIAL VALUE ORDINARY DIFFERENTIAL EQUATION SOLVER.

1.1. INTRODUCTION

RUNKUT is a subroutine that contains three Runge-Kutta initial value ordinary differential

equation (IVP ODE) solvers They are:

220 BYTE LISTINGS SUPPLEMENT

A fourth order Fehlberg method.

A fifth order Verner method. - An seventh order

Verner method.

RUNKUT solves coupled IV ODE’s of the form:

V = F(x, Y)

There is no limit to the number of coupled equations in a system to be solved other than the

amount of memory available. The differential

equations are defined in a user-supplied

subroutine—more about that later. The subroutine is called using the following FORTRAN call statement:

CALL

RUNKUT(XA,Y.XB,NEQN,TOLA,TOLR,HSTART,WORK, &

IMETH,IERROR,ICOM.FUNC)

and must be called from a main "calling" program.

1.2. VARIABLES PASSED TO RUNKUT.

The variables passed are explained below and are listed in the order in which they appear in the

call statement. The superscripted numbers refer to

notes appearing at the end of this section.

XA (Real-Input) XA Is the starting

point of the interval over which integration of

the ODE’s is to be per formed.(1)

Y (Real array of size NEQN - Input/Output)

On entry, Y must contain the initial values of the Y-variables—that is Y must contain the solutions at the point XA. On exit from RUNKUT. Y wlI I contain the solutions at the end of the specified interval—that is at XB.(2)

XB (Real-Input) XB specifies the end

of the interval over which integration is to be

performed—the point at which solutions to the differential equations are desired.(1,2)

NEQN (Integer-Input) NEQN specifies

the number of coupled differential equations in

the system to be solved.

TOLA (Real-Input) TOLA is the

absolute error tolerance required on the solution.(3)

TOLR (Real-Input) TOLR is the

relative error tolerance required on the solution.(3)

HSTART (Real-Input/Output) On the

very first call to RUNKUT In a calling sequence,

HSTART must contain a non-zero value as an initial estimate for the step-size.(1) The actual value used is relatively unimportant as the program will optimize step-sizes to keep the tolerances within specified limits and keep the number of function evaluations to a minimum. It is left to the user’s discretion to choose a value that will not require excessive readjustment by the program. On exit from RUNKUT, this variable will contain the last step size used by the program. It Is recommended that for subsequent calls to RUNKUT, the step size returned by the program be used as the value for HSTART to solve the equations over the immediately following intervaI.

WORK (Real array of minimum size NEQN*17 - Input) This Is a work area made available to RUNKUT by the calling program.

IMETH (Integer-Input) Indicates to

the solver, the order of the method to be used.

IMETH can take on the following values: (continued)

BYTE LISTINGS SUPPLEMENT 221

1. - Fourth order Fehlberg method

— fifth order Verner method 3. ■ seventh

order Verner method

While solving a given set of differential equations It is possible to change the order of

the method over sucessive intervals simply by

setting IMETH to the desired value and

resetting IC0M(1) to 0 on each subsequent call to RUNKUT in which a change of order is required.(4)

IERROR (Integer-Output) IERROR is an

error status indicator returned by RUNKUT after each call. It can have one of the following values:

_ 4 0 " no error. 1 - the sum of

TOLA and TOLR is less than 100 times machine epsilon. This can be caused by setting both TOLA and TOLR to 0, or by specifying values that are too small for the program to handle sucessfully. In this case TOLR is set

to a default value. 2 - the

problem is too stiff for the method to handle, or there is a discontinuity in the function. It is impossible to proceed in either case.(2) 3

both conditions 1 and 2 above have occured.

IERROR is set to 0 on every entry to RUNKUT.

ICOM (Integer array of size 4) ICOM

is a communications vector. Each array element is used to pass a specific Item of Information (as defined below) to and from the subroutine.

ICOM(1) (Input) ICOM(1) must be set

to 0 on the first call to RUNKUT. IC0M(1) is

internally set to a non—zero value by the program after the first call. For subsequent calls to RUNKUT with the same set of equations, IC0M(1) must be left at this non-zero value. It is possible to change the order of the method used (see also IMETH) over sucessive intervals. In this case ICOM(1) must be reset to 0 eoch time the order of the method Is changed.(4)

IC0M(2) (Input) A flag that indicates

to the program whether to perform checks on the

specified values of TOLA and TOLR.

0 - no checking of the error tolerances.

1 - program checks if the sum of TOLA and TOLR is at least 100 times machine epsilon. If not, TOLR is set to a default value and the error indicator IERROR is set to 1.

If IC0M(2) is set to 0, the program assumes that it will be receiving non-zero values of at

least one of TOLA or TOLR. Failure to check

this before entry to RUNKUT could result in fatal program errors. Also, as will be shown in an example, decreasing the error tolerances does not always result in improved solution accuracy.

IC0M(3) (Input) A flag that indicates

to the program whether to use the default

values of mimimum and maximum step size set by the subroutIne.(5)

0 - default values of the maximum and minimum step size are used. 1

allows the user to set values for the maximum and minimum permissible step size. These values are set by including the following FORTRAN common block statement in the main "calIIng" program:

222 BYTE LISTINGS SUPPLEMENT

COMMON /CONS/HMIN,HMAX

IC0M(4) (Output) Status flag

that Indicates the presence of round-off

error in the solution. 0 - No round-off

error. 1 - Severe round-off error possible

in answer.

IC0M(4) is reset to 0 on entry to RUNKUT.

FUNC (Function name) FUNC is

replaced by the name of the subroutine that is part of the main user routine in which the differential equations are specified (See section on user supplied routines). The subroutine name must be declared external by the following FORTRAN statement:

EXTERNAL [SUBROUTINE NAME].

1.2.1. NOTES

1. XA could be greater than XB. In other words

It is possible to use RUNKUT to solve the

differential equations in a negative

X-direction given Initial values at XA. In

that case the step-size will also be negative.

HSTART could be specified as a negative value, but that is not essential as the program internally adjusts the algebraic sign of the step-size.

2. If a discontinuity or extreme stiffness is

encountered, RUNKUT will return in XB, the

value of X closest to the point of

discontinuity or stiffness, at which the

solutions are still within the specified error bounds.

The array Y wiI I then contain solutions at this value of X.

3. If the sum of TOLA and TOLR is less than

100 times machine epsilon (for example if

neither were defined in the main program),

TOLR is set to a default value of 10(6)

times machine epsilon. TOLA is not set to any

default value. The program uses a combination of TOLA and TOLR to determine the accuracies of the solutions, and specifying TOLR to a certain value almost always gives better results than specifying TOLA to the same value.

4. Changing the order of the method on every

subsequent call to RUNKUT with a given

system of equations can lead to excessive

computaion times since a large number of

constants are re-evaluated each time the order is changed.

5. The default values used by the subroutine

are 10(-8) for HMIN, and for HMAX as

foI lows:

0.5 - If the fourth order method is used.

1.0 - if the fifth order method is used.

2.0 - if the seventh order method is used.

However, if any of these values are larger than the absolute value of the interval

width, HMAX Is set to the interval width.

It Is sometimes necessary to specify HMAX to a small value to keep the step sizes to relatively small values that keep the runge-kutta methods within regions of stability. The subroutine detects the onset of problem “stiffness" or the occurence of a discontinuity in the function by checking if the step size is smaller than HMIN. If the equations are being solved in the negative X-direction, HMIN and HMAX are the smallest and largest permissible step sizes in the negative X-dlrection respectively. In other words, HMIN and HMAX

always define absolute constraints on the step size. ( continued )

BYTE LISTINGS SUPPLEMENT 223

6. Machine epsilon on the IBM PC is very much a function of the compiler used (even with

an 8087 math coprocessor installed). For

example Microsoft's Fortran-77 compiler (with 8087 support) generates an epsilon of about 10(-16), whereas IBM/Ryan-McFarI and *s Professional Fortran-77 generates an epsilon of about 10(-20)

1.3. THE USER-SUPPLIED ROUTINES

Two routines must be supplied:

1. A main "calling" program that calls RUNKUT. It must also define the initial values of Y

at XA, set TOLA and TOLR, set IC0M(1) to 0

on the first call to RUNKUT, define the number of equations In the sytstem to be solved,

dimension a WORK array for RUNKUT, and check for the error status as passed back from RUNKUT through IERROR.

See the examples at the end of this section.

2. A subroutine containing the system of differential equations. The subroutine

name must be declared EXTERNAL In the main

calling program and its name passed to RUNKUT through the parameter FUNC-see above. The subroutine is defined using the foilwing FORTRAN statement:

SUBROUTINE [FUNC] (X.Y,YPRIME.NEQN)

where the parameters have the following

definitions:

X (Real) Contains the

current value of X as set in RUNKUT. Do not alter this value within [func]

Y (Real - array of size NEQN)

Contains the current solutions at X. Do not alter in [func].

YPRIME (Real - array of size NEQN) YPRIME is set in the subroutine to the differentials dy/dx as foilows:

YPRIME(I) = F/1/(X,Y(1),....Y(NEQN))

YPRIME(NEQN)=F/NEQN/(X,Y(1).Y(NEQN))

where F/i/ is the i'th differential

function.

The following table should be printed out in 132-column format.

TABLE 2 - The numerical solution of the equations in example 3. (TOLR « 1.E-10, TOLA - 0.0)

RKF-4 RKV-5 RKV-7

x y(i) y(2)

y(i) y(2) y(i)

y(2)

.0 .750000000 .000000000 .5 .619768033 .477791373 1.0 .294417538 .812178519

1.5- .105176381 .958038093 2.0-.490299792 .939874997

2.5- .813942831 .799590803 3.0-1.054031516.575706079

3.5- 1.200735041.300160709 4.0-1.250000000.000000000

.750000000

.619768033

.294417538

-.105176381

-.490299792

-.813942831

-1.054031516

-1.200735041

-1.250000000

.000000000 .750000000 .477791373 .619768033 .812178519 .294417538 .958038093-.105176381 .939874997 -.490299792 .799590803 -.813942831 .575706079 -1.054031516 .300160709 -1.200735041 .000000000 -1.250000000

.000000000

.477791373

.812178519

.958038093

.939874997

.799590803

.575706079

.300160709

.000000000

224 BYTE LISTINGS SUPPLEMENT

4.55.0

5.56 . 0

6.57.0

7.5 8.0

8.5 9.0

9.510.010.511.0 11.5 12.0

1.200735041-,

1.054031516

.813942831

.490299792

.105176381

.294417538

.619768033

.750000000

.619768032

.294417538

.105176382

.490299793

.813942832

-1.054031516

-1.200735042

-1.250000000

300160709 -1 575706079 -1 799590803 -. 939874997 -. ,958038093 -. ,812178519 .

477791373 .

,000000000 . .477791374 .

.812178520 .

.958038093 -. .939874996 -. .799590803 -. .575706078 .300160708 -.000000001

.200735041 -. .054031516 -. 813942831 -.

490299792 -,

105176381

294417538

619768033

750000000 619768033 294417538 105176381 490299792 813942831 -1.054031516 -1.200735041 -1.250000000

300160709 575706079 799590803 939874997 958038093 812178519 477791373 000000000 ,477791373 .812178519 .958038093 .939874997 ■ .799590803 .575706079 .300160709 .000000000

1.200735041 1.054031516 .813942831 .490299792 .105176381 .294417538 .619768033 .750000000 .619768033 .294417539 •.105176381 -.490299792 -.813942831 -1.054031516 -1.200735041 -1.250000000

-.300160708

-.575706078

-.799590803

-.939874997

-.958038093

-.812178519

-.477791373

.000000000

.477791373

.812178519

.958038093

.939874997

.799590804

.575706079

.300160709

.000000001

Re 1 ative

error 1.220E-010 at x=12

5.665E-010 6.948E-012 1.184E-010

1.919E-010 8.529E-010

Total function eva1uations

2928 2640

1872

The following table should be printed out in 132-column format.

Table captionTABLE 3 - Comparison of code accuracy and efficiency for different

Table captionexpressions for the parameter POWER in the step size adjuster.

RKF

-4

RKV

*5

RKV-7

examp 1e:

i

(ot x-1)

2

(at x-12)

y(D

i

(ot x-1)

2

(at x-12)

i

(at x-1)

2

(ot x-12)

with POWER = O/p+i)

[.567E-08] (3216)

[1.22E-10]

(2928)

[ . 138E-08] (2008)

[6.95E-12]

(2640)

[.276E-08] (1053)

[1.92E-10] (1872)

with POWER * O/p)

[.713E-08] (3072)

[1.54E-10]

(2844)

[.165E-08] (1968)

[8.68E-12]

(2472)

[.316E-08]

(1053)

[1.92E-10] (1703)

- The figures in square brackets [] are absolute values of the relative global errors

- The figures in round brackets () are total number of function evaluations taken to reach specified x value from the starting point.

(TOLA ■ 0, TOLR * 1.E-09 for example 1 and 1.E—10 for example 2)

predict.for TEXT

"The Runge-Kutta Methods," Benku Thomas. ApriI, page 191.

$NOFLOATCALLS $NODEBUG $STORAGE:2

subroutine rkp(x,ys,h,neqn,Imeth,kt,est,yoId.ynew.w,func)

implicit double precision (a-h,k,p-z) external func

dimension w(13,neqn),kt(neqn),ys(neqn),est(neqn) dimension a I(12),b(12,12),yoId(neqn).ynew(neqn)

(continued)

BYTE LISTINGS SUPPLEMENT 225

common /coeffs/al,6,01,03,04,05,06,07,08,09,010,011, & 0l2,a13,er1,er3,er4,er5,er6,er7,er8,

& er9,er10,er11,er12,er13,Inum

xs-x

do 5 i*1,neqn ys(l)-yold(!) contInue

call func(xs,ys,kt,neqn) do 7 1*1,neqn w(1.l)-kt(I) contInue

10

15

17

20

do 20 j*2,lnum JI-j-1

xs*x+h*aI(J1) do 15 i*1,neqn ksum=0.d0 do 10 m*1,J1

ksum*ksum+b(m,j1)*w(m,I) continue

ys(I)*yoId(I)+h*ksum contInue

call func(xs,ys,kt,neqn) do 17 i*1,neqn

w(JJ)-kt(i)

continue contInue

c**** evaluate YNEW[I] and the error estimates EST[i]

If(lmeth.EQ.I) then do 30 1*1,neqn

ynew(i)*yoId(I)+h*(a1*w(1,I)+a3*w(3,l)+a4*w(4,i)

& +a5*w(5,i)+a6*w(6,I))

est(I)*h*(er1*w(1,1)+er3*w(3,i)+er4*w(4,I)+er5*w(5,I)

& +er6*w(6,i))

30 continue

end I f

If(Imeth.EQ.2) then do 40 1*1,neqn

ynew(I)*yoId(I)+h*(a1*w(1,i)+a3*w(3,I)+a4*w(4,i)

& +a5*w(5,I)+a7*w(7,i)

& +a8*w(8,I))

est(I)*h*(er1*w(1,I)+er3*w(3,i)+er4*w(4,I)+er5*w(5,i)

& +er6*w(6,I)+er7*w(7,i)+er8*w(8,i))

40 continue

end if

if(Imeth.EQ.3) then do 50 i=1,neqn

ynew(i)*yoId(i)+h*(a1*w(1,i)+a6*w(6,i)+a7*w(7,i)

& +a8*w(8,i)+a9*w(9,i)

& +a12*w(12,i)+a13*w(13,i))

est(i )=h*(er1*wM , i )

& +er6*w(6,i)+er7*w(7,i)+er8*w(8,i)+er9*w(9,i)

& +er10*wf10,i}+er11*w(11,i)+er12*w(12,i)

& +er13*w(13,i;)

50 continue

end if

return

end

226 BYTE LISTINGS SUPPLEMENT

runkut.for TEXT

"The Runge-Kutta Methods," Benku Thomas. Apr i I, page 191.

$NOFLOATCALLS $NODEBUG $STORAGE:2

c***************************************************************************** c NOTE: Some of the variables are not the same as in the article

c For example hadj = v, est=e(i+1), hfact=s, hlim = vlim.

c*****************************************************************************

c

c

subroutine runkut(xa,ya,xb,neqn,tola,tolr,hstart,w, k imeth,ierror,icom,func)

c

c**** This is simply a front-end subroutine to split up the work c**** array specified by the user into smalller arrays c

implicit double precision (a-h,k,o-z) external func dimension icom(4),w(*) common /epsil/eps

cal I solver(xa,ya,xb,neqn,tola,tolr,hstart,ierror,imeth, k icom(1),icom(2),icom(3),icom(4),w(1),w(1+neqn),

k w(1+neqn*2),w(1+neqn*3),w(1+neqn*4),func)

return end

c*****************************************************************************

c

c

subroutine solver(xa,ya,xb,neqn,tola,tolr,hstart,ierror,Imeth, k 1st,ichk,idef,iround,kt,est,yoId,ynew,w,func)

implicit double precision (a-h,k,o-z) logical hflag external func

dimension ya(neqn),w(13,neqn),kt(neqn) dimension est(neqn),yoId(neqn),ynew(neqn) common /cons/hmin,hmaxI,hfact,hIim,power common /epsil/eps

c * * * * If TOLA is set to zero, then a relative error test

c**** If TOLR is set to zero, then an absolute error test

c**** If neither are set to zero, then a mixed error test

c***» If this is the first call to RUNKUT calculate the machine

c**** epsilon and work out the constants depending on method used, c**** To ensure that the results will always be "safe", the value c**** EPS used by RUNKUT is actually 20 times the machine epsilon.

if(ist.EQ.0) then call caleps

call const(ist,imeth,idef) eps=eps*20.d0 end i f

c**** Check If the sum of TOLA and TOLR is greater than 10*EPS c**** If not, set TOLR to one million times EPS.

ierror=0

if(ichk.GT.0)then

if(tola+tolr.LT.10.d0*eps)then ierror«1 to Ir*1.d06*eps end if end I f 1round«0

isig«dint((xb-xa)/dabs(xb-xa))

ho Id-hstart

x*xa

( continued)

BYTE LISTINGS SUPPLEMENT 227

10

do 10 1*1,neqn yold(i)-yo(i) continue

c#***

c****

c****

Set HMAX to the maximum value HMAXL set in CONST unless this is greater than the interval width, in which case HMAX is equal to the interval width.

hmax-dminl(hmax1,dabs(xa-xb))

c****

c * * * *

call the runge-kutta solver using the current step size to predict y(n+1)

15

cal 1 rkp(x,ya,ho1d,neqn,imeth,kt,est,yo1d,ynew,w,func)

c****

c****

calculate step size adjustment factor HADJ

then calculate HNEW using the smallest value of HADJ

20

hadj*9999.d0 do 20 1*1,neqn

absest*dabs(est(i)) if(absest.EQ.0)then had j1=h1im e 1 se

if(yold(i).EQ.0)then

hadjl*((tola+tolr*tolr)/absest)**power e 1 se

hadjl*((tola+tolr*dabs(yold(i)))/absest)**power end i f end i f

if(hadj1.LT.hadj) hadj-hadjl contInue

c****

c****

c** + *

c****

adjust the step size to HNEW using the calculated value of HADJ unless HADJ is greater than HLIM, in which case use HUM

If HNEW is larger than HMAX, choose HMAX as the new step size

If HNEW is less than HOLD/10, keep HNEW as HOLD/10 to avoid excessively large swings in the step size

&

holdl-dabs(hold) hnew * dmaxl(ho 1 di/10.,

dminl(hfact*ho1d1*(dmin1(hadj,hlim)),hmax))

c****

c****

c****

c**#*

c****

c****

C****

C ****

c****

Check if HOLD is large enough compared to EPS to avoid severe round-off errors. If HNEW is less than HMIN, the problem has got too stiff or is discontinous-exit saving the last points calculated. If the last step was sucessful let YOLD*YNEW and calculate YNEW using new step size. If it was unsuccessful, recalculate YNEW using reduced step size.

If the HOLD was a reduced step size, then restrict HNEW to HOLD If XB will be reached or exceeded, exit after calculating

Y at XB.

30

if(dabs(x).GT.0) then

if((hnew/(dabs(x)*18.d0)).LE.eps) iround*1 end i f

if(hnew.GE.hmin) then hnew=isig*hnew

If(hadj.GE.1.d0) then

if(isig*(x+ho1d-xb).LT.0.d0) then x*x+ho1d

if(.not.hf1ag) hnew*hold hf1ag*.true. do 30 i*1,neqn yold(i)*ynew(l) continue ho 1d=hnew goto 15 e 1 se

hstart*hnew

50

ho 1d=xb-x

cal 1 rkp(x,ya,hold,neqn,imeth,kt,est,yo1d,ynew,w,func) do 50 i*1,neqn ya( i)=ynew(i) continue end i f e 1 se

Table caption228 BYTE LISTINGS SUPPLEMENT

hfIag*.false, ho Id=hnew goto 15 end i f e I se

hnew=isig*hnew ierror=ierror+2 xb«x

do 60 i»1,neqn y°( •)*yold( I) 60 continue

end I f return end

ordit.for TEXT

"The Runge-Kutta Methods," Benku Thomas. Apr I I, page 191.

$NOFLOATCALLS SNODEBUG $STORAGE:2

c**** User’s calling program

c**** NEQN*4 so dimension of work array = 4*17 = 68

implicit double precision (a-h.o-z) dimension y(4),work(68),icom(4) external orbit common alfasq

open(2,fiIe=' *.status-’new’) icom(1)*0

wr ite(*,*) •imeth«,tola»,tolr»* read(*,*) imeth,to I a,to Ir ecc=0.25d0

a If a*3.141592653589d0/4.d0

a I fasq=aIfa*aI fa

neqn«4

hstart=0.01d0 y(1)«1.d0-ecc y(2)-0.d0 y(3)»0.d0

y(4)*aIfa*dsqrt((1.d0+ecc)/(1.d0-ecc)) x0-0.d0 xb»0.d0 icomf2J«0 icom(3)*0 do 20 j-1.24 xa«xb

xb=0.5d0*dbIe(j)+x0 wrlte(2,100)xa,y(1),y(2)

cal I runkut(xa,y,xb,neqn,tola,to Ir,hstart,work,

& imeth,ierror,icom,orbit)

if(ierror.GT.1) then

write(2,100)xb,y(1),y(2)

writef2,*) • ERROR-ProbIem too stiff or is discontinous’ cIose(2) stop end i f

20 contInue

if(icom(4).GT.0)write(2,*) " Severe round-off error possible stop

100 format(F5.1,3F15.9)

end

C *********************************************^********** , * c ********** , * t c**** User supplied subroutine that contains the system of c**** differential equations to be solved.

c**** Notice that in this routine it is necessary to have an array c**** yprime(neqn)

BYTE LISTINGS SUPPLEMENT

229

subroutine orbit (x.y.yprirne.neqn) implicit double precision (a-h,o-z) dimension y(neqn),yprime(neqn) common alfasq

r-y(1)*y(1)+y(2)*y(2) r«r*dsqrt(r)/alfasq yprime(1)*y(3) yprime(2)*y(4) ypr imef32«-y(1 )/r ypr ime(4)—y(2;/r return end

react.for TEXT

"The Runge-Kutta Methods," Benku Thomas. Apr I I, page 191.

$NOFLOATCALLS $NODEBUG $STORAGE:2

Implicit double precision (a-h,p-z) dimension y(2),work(34),icom(4) external freact

common /reacts/ifeval,Da,deIta,beta,Hw,Tw

open(2,file= * *,status* ’new’)

Ifeva1=0 Icomf1 icom(2)*0 lcom(3)*0

write(*,*) ’Wall Temp.=, Reactant Inlet Temp=, htc-’ read(*,*) Tw.Tr.U Tw»Tw/Tr U-U/1000.0

write(*,*) * imeth=, tola=, tolr»' read(*,*) imeth,to I a,to Ir

c**** evaluate constants In the equations Da=2.d0*5.d0/3.d0 beta=0.03d0*1,d04/1,2d0/1.d0/Tr delta=1,d3/8.3144d0/Tr Hw»2.d0*U*2.d0/0.1d0/1.2d0/1.d0/3.d0

c****

hstart=0.01d0 neqn*2 x0=0.d0 xb=0.d0 y(1)*1.d0 y(2)*1.d0 conc=yf12*0.03 temp=y(2)*Tr

write(2,30)xa,y(1),y(2),hstart do 20 j-1,10 xa*xb

xb«0.1*dble(j)+x0

cal I runkut(xa,y,xb,neqn,tola,to Ir,hstart.work,

& imeth,ierror,icom,freact)

conc*y(1)*0.03 temp*y(2)*Tr if(ierror.GT.1)then writef2,30)xb,y(1),y(2),hstart

write(2,*)’ ERROR-ProbIem too stiff or is discontinous• close(2) stop e I se

write(2.30)xb,y(l),y(2),hstart end i f

230 BYTE LISTINGS SUPPLEMENT

20 continue

i f ( icom(4).GT.0) write(2,*) * Severe round-off error possible* write(2,*) * Number of function evaluations * *,ifeval close (2) stop

30 format(1x,f11.2.1x,d15.6,1x,f15.4,lx,d15.6)

end

c user supplied subroutine containing the system of first

c order ordinary initial value differential equations

subroutine freact(x,y,yprime,neqn)

implicit double precision (a-h,p-z)

dimension y(neqn),yprime(neqn)

common /reacts/ifeval,Da,delta,beta,Hw,Tw

yprime(1)* -Da*y(1)*dexp(deIta*(1.d0-1.d0/y(2))) yprime(2)» beta*Da*y(1)*dexp(deI ta*(1.d0-1.d0/y(2)))

& -Hw*(y(2)-Tw)

i feval = ifeva1 + 1

return

end

rkconst.for TEXT

"The Runge-Kutta Methods," Benku Thomas. ApriI, page 191.

$NOFLOATCALLS $NODEBUG $STORAGE:2

C*************************************************************************

subroutine const(ist,imeth,idef)

c**** subroutine supplies constants used in the runge-kutta c**** method,in the format required by RKP.

Implicit double precision (a-h,p) dimension al(12),b(12,12)

common /coeffs/al,b,a1,a3,a4,a5,a6,a7,a8,a9,a10,a11,

& a12,a13,er1,er3,er4,er5,er6,er7,er8,

& er9,er10,er11,er12,er13,inum

common /cons/hmin,hmaxI,hfact,hlim,power

do 10 j-1,12 do 5 1-1,12 b(i,j)-0.d0 5 continue

a I (j)*0.d0 10 continue

if(imeth.EQ.I) then

c**** Fourth order runge-kutta method specified by

c**** Felberg, E., COMPUTING, 6(1970)p61-71

c write(*,*) ’Fourth order Runge-Kutta-FehI berg method*

al (0

1-1.d0/4.d0

o 1 <

23

l-3.d0/8.d0

all

3

I-I2.d0/I3.d0

a 1 <

43

1-1.d0

al <

5

1-1.d0/2.d0

b(1,1)«1.d0/4.d0

b(1,2)»3.d0/32.d0

b(2,2)-9.d0/32.d0

b(1,3)-1932.d0/2197.d0

b (2,3)—7200. d0/2197. d0

b(3,3)-7296.d0/2197.d0

b(1,4)«439.d0/216.d0

b(2,4)*-8.d0 ( continued)

BYTE LISTINGS SUPPLEMENT 23!

b(3,4)=3680.d0/513.d0 b(4,4)«-845.d0/4104.d0 b(1,5)—8.d0/27.d0 b(2,5l=2.d0

b (3,5)—3544. d0/2565. d0 bU,51=1859.d0/4104.d0 b(5,5)=-11.d0/40.d0

er1«1,d0/360.d0 er3=-384.d0/12825.d0 e r 4—41743.d0/1429560.d0 er5=1.d0/50.d0 er6=2.d0/55.d0

01-16.d0/135.d0 o2=0.d0

o3=6656.d0/12825.d0 04=28561.d0/56430.d0 o5=-9.d0/50.d0 o6-2.d0/55.d0

lnum-6 i st=4

i f ( idef.eq.0) hmoxl=0.5d0 hiIm1=3.d0 end I f

c**»*

c****

c

If(imeth.EQ.2) then

Fifth order runge-kutto method specified by Verner J.H., SIAM J. Numer. Anal. V15.(1978),p772.(tabIe 5) wrlte(*,*) ’Fifth order Runge-Kutta-Verner method' a I (11=1.d0/18.d0

2) =1.d0/6.d0

3) =2.d0/9.d0

4) =2.d0/3.d0 51=1,d0

)=8.d0/9.d0 1. d0

al a I ol a I al

6

ol(7).

bf1,11=1,d0/18.d0 b(1.2)=-1.d0/12.d0 bf2,2)»1.d0/4.d0 b(1,3)=-2.d0/81.d0 bf2,3)=4.d0/27.d0 b(3.3)=8.d0/81.d0 b(1,4)=40.d0/33.d0 b(2,4)—4.d0/11.d0 b(3,4)—56.d0/11.d0 b(4,4)=54.d0/11.d0 b(1,5)=-369.d0/73.d0 b(2,5)=72.d0/73.d0 b(3,5l=5380.d0/219.d0 b(4.5)=-12285.d0/584.d0 bf5,51=2695.d0/1752.d0 b(1.6)=-8716.d0/891.d0 bf2.61=656.d0/297.d0 b(3,6)=39520.d0/891,d0 b(4*6)=-416.d0/11,d0 b(5.6)=52.d0/27.d0 bf1,7)=3015.d0/256.d0 b(2,7)=-9.d0/4.d0 b(3.71—4219. d0/78.d0 b(4,7)=5985.d0/128.d0 b ( 5.7)=-539.d0/384.d0 b(7,7)=693.d0/3328.d0

e r1=33.d0/640.d0 er3=-132.d0/325.d0 er4=891.d0/2240.d0 e r5=-33.d0/320.d0 e r 6—73. d0/700. d0 er7=891,d0/8320.d0 er8=2.d0/35.d0

232 BYTE LISTINGS SUPPLEMENT

C**** C****

c

a1=57.d0/640.d0 a3—16.d0/65.d0 a4=1377.d0/2240.d0 a5-121.d0/320.d0 07=891.d0/8320.d0 o8=2.d0/35.d0

inum=8 i st=5

if(idef.eq.0) hmaxl=1.0d0 hiim1=4.d0 end 1 f

if(imeth.EQ.3) then

Seventh order runge-kutto method specified by

Verner J.H., SIAM J. Numer. Anal. V15.(1978),p772.(tabIe 7)

write(*,*) 'Seventh order Runge-Kutta-Verner method'

a I(1)»1.d0/4.d0

al(2) = 1.d0/12.d0

al (3)=1.d0/8.d0

al(4)=2.d0/5.d0

al(5)=1.d0/2.d0

Ol(6)=6.d0/7.d0

ol(7)=1.d0/7.d0

a I(8)=2.d0/3.d0

a I(9)=2.d0/7.d0

ol(10)=1.d0

al (11)=1.d0/3.d0

al(12)=1.d0

b(1,1)=1.d0/4.d0

b(1,2)=5.d0/72.d0

b(2.2)=1.d0/72.d0

b(1,3)=1.d0/32.d0

b(3,3)=3.d0/32.d0

b(1,4)=106.d0/125.d0

b(3,4)=-408.d0/125.d0

b(4,4)=352.d0/125.d0

b(1,5)=1.d0/48.d0

b(4,5)=8.d0/33.d0

b(5,5)=125.d0/528.d0

b(1,6)=-1263.d0/2401.d0

b(4,6)=39936d0/26411d0

b(5,6)=-64125.d0/26411d0

b(6,6)=5520.d0/2401,d0

b(1,7)=37.d0/392.d0

b(5,7)=1625.d0/9408.d0

b(6,7)=-2.d0/15.d0

b(7,7)=61.d0/6720.d0

b(1,8)=17176.d0/25515.d0

b(4.8)=-47104.d0/25515.d0

b(5.8)=1325.d0/504.d0

b(6.8)=-41792.d0/25515.d0

b(7,8)=20237.d0/145800.d0

b(8,8)=4312.d0/6075.d0

b(1.9)=-23834.d0/180075.d0

b(4,9)=-77824.d0/1980825.d0

b(5,9)=-636635.d0/633864.d0

b(6,9)=254048.d0/300125.d0

b(7,9)=-183.d0/7000.d0

b(8,9)=8.d0/11.d0

b(9,9)=-324.d0/3773.d0

b(1,10)=12733.d0/7600.d0

b(4,10)=-20032.d0/5225.d0

b(5.101=456485.d0/80256.d0

b(6,10)=-42599.d0/7125.d0

b(7,101=339227.d0/912000d0

b(8,10)=-1029.d0/4180.d0

b(9,10)=1701.d0/1408.d0

b(10,10)=5145.d0/2432.d0

b(1.11)=-27061.d0/204120.d0

b(4,11)=40448.d0/280665.d0

b (5,111—1353775. d0/1197504. d0

b(6,11)=17662.d0/25515.d0

b (7,111—71687. d0/1166400d0

b(8,11 )*98. d0/225. d0 (continued)

BYTE LISTINGS SUPPLEMENT 233

b(9,11)-1.d0/16.d0 b(10,11)-3773.d0/11664.dO b(1,12)»11203.d0/8680.d0 b(4,12)—38144.d0/11935.d0 b(5.12)-2354425.d0/458304.d0 b(6.12)—84046.d0/16275.d0 b(7,12)»673309.d0/1636800.d0 b(8.12)-4704.d0/8525.d0 b(9,12)-9477.d0/10912.d0 b(10,12)—1029.d0/992.d0 b(12,12)-729.d0/341,d0

erl—1 ,d0/480.d0 er6—16.d0/375.d0 er7—2401.d0/528000.d0 er8-2401.d0/132000.d0 «r9=243.d0/14080.d0 er10—2401.d0/19200.d0 erll—19.d0/450.d0 er12-243.d0/1760.d0 er13»31.d0/720.d0

al-31.d0/720.d0 o6-16.d0/75.d0 o7-16807.d0/79200.d0 o8-16807.d0/79200.d0 09-243.d0/1760.d0 012-243.d0/1760.d0 013-31.d0/720.d0

lnum-13

ist-7

I f( i def.eq.0) hmoxl«2.d0 hiIm1-5.d0 end if

power-1.d0/dble(ist+1)

hfoct-0.5d0**(1.d 0 /dble(ist- 1 ))

hIim-hIiml/hfoct lf(idef.eq.0) hmln-1.d-06 c wrIte(*,*)’ Constants evaluated* return end

epsiIon.for

$NOFLOATCALLS

$NODEBUG

$ST0RAGE:2

c***********************************************************^***^***

subroutine caleps

c**»* subroutine calculates the machine epsilon EPS using an c**»* algorithim adapted from Forsythe et. ol. "Computer Methods c*«** for Mathematical Computations", Prentice-Ha11,N.J. (1977). c**** The EPS calculated can differ from the true machine EPS by c**** at most a factor of 2.

double precision eps common /epsil/eps

eps-1.d0

10 eps-.5d0*eps

if((eps+1.d0),GT.1.d0) goto 10 c write(*,*) ’Machine Epsilon used-’,eps

return end

234 BYTE LISTINGS SUPPLEMENT

therm.for TEXT

"The Runge-Kutta Methods," Benku Thomas. ApriI, page 191.

implicit double precision (a-h,o-z) dimension y(1), work(17), icom(4) external thermo common etherm,ifevaI,j

open(2,fiIe=’ *,status=’new’)

ifeva1=0

icom(1}=0

icomf2)=0

icom(3)=0

neqn«1

write(*,*) *etherm», imeth*, tola=, tolr=* read(*,*) etherm,imeth,to I a,to Ir hstart=0.01d0 y(1)=1.d0 x0=0.d0 xb=0.d0 do 20 J-1,6 xa=xb

xb=0.2d0*dbIe(j)+x0

abserr=dexp(-etherm*xa)-y(1)

re Ierr=abserr/dexp(-etherm*xa)

write(2,100)xa,y(1),abserr,re I err

cal I runkut(xa,y,xb,neqn,tola,tolr,hstart.work,

& imeth,ierror,icom,thermo)

if(ierror.GT.I) then write(2,100)xb,y(1),abserr,re I err

write(2,*)' ERROR-ProbIem too stiff or is discontinous' close(2) stop end i f 20 continue

if(icom(4).GT.0) wrlte(2,*) ’Round-off error possible’ write(2,*) ’Number of function evaluations = ’.ifeval close (2) stop

100 format(F10.5,4E14.6)

end

subroutine thermo (x,y,yprime,neqn) implicit double precision (a-h,o-z) dimension y(neqn), yprime(neqn) common etherm,ifevaI,j

yprime(1)= -etherm*y(1) i f(j.LE.5) i fevaI *ifeva1+1 return end

examp Ier.for TEXT

"The Runge-Kutta Methods," Benku Thomas. Apr 1 I , page 191.

RUNGE KUTTA EXAMPLES.

Let us look at three examples which we will attempt to solve by using the FORTRAN implementations of the algorithms outlined in the BYTE article.

EXAMPLE 1. This is the radlactivlty problem from the article. The dimensionless form of the equation was solved, with the decay constant set to a value of 25. Since the solution produced values close to zero, a relative error tolerance was used, and its value

BYTE LISTINGS SUPPLEMENT 235

set to 10(-9). The calling (user) program is similar to the listing for example 3. The result of running the program with the fifth order method is given In table la. For comparison, table 1b gives the absolute and relative global errors at each step using each of the methods. The total number of function evaluations Is a measure of the efficiency of the method and the global error, a measure of the accuracy. The expression for the parameter POWER, used in the formula for the step size adjustment factor v. was 1/(P+D.

TABLE la - Results of solving the equation y’«-25y using the variable

step size fifth order method. (Relative error tol. - 1.E-09)

X

y(x)

Absolute global error

Re 1 ative global error

0.0

0.100000E+01

0.000000E+00

0.000000E+00

0.2

0.673795E-02

-0 .186541E-11

-0.276851E-09

0.4

0.453999E-04

-0.250863E-13

-0.552562E-09

0.6

0.305902E-06

-0.25337IE-15

-0.828274E-09

0.8

0.206115E-08

-0.227547E-17

-0.110398E-08

1.0

0.138879E-10

-0.191612E-19

-0.137970E-08

Total number

of function evaluations ■

2008

Table captionTABLE 1b - Comparison of the relative global error in the numerical solutions of the equation y’=-25y, using the 4th. 5th and 7th order variable step methods.

Table caption(TOLR = 1.E-09, TOLA » 0.0)

x RKF-4

RKV-5

RKV-7

0.0

0.2

0.4

0.6

0.8

1.0

0.000000E+00 0.113247E-08 0.226672E-08 0.340097E-08 0.453523E-08 0.566949E-08

0.000000E+00 -0.276851E-09 -0.552562E-09 -0.828274E-09 -0.110398E-08 -0.137970E-08

0.000000E+00 -0.519695E-09 -0.107925E-08 -0.16388IE-08 -0.219837E-08 -0.275792E-08

Total function 3216 2008 1053

evaIuations

EXAMPLE 2. The classic stiff problem involving the rate of formation of methyl iodide in a nuclear reactor is solved, using a reactant inlet temperature of 800 K. The temperature of the cooling fluid on the outside of the reactor (T/w/) was varied from 400 K to 800 K. The results obtained from the numerical solution are plotted in figure 2 for cooling fluid temperatures of 400K, 600K, and 800K. This gives the dimensionless temperature in the reactor as a function of fractional distance down the length of the tubular reactor. From the physics of the problem, we know that the reaction gives off heat, that the amount of heat released will increase with the rate of reaction which in turn is proportional to the amount of reactant present. At the inlet of the reactor there is a large amountof reactant present, so the rate will be high , resulting in a high heat release. The heat is being produced by the reaction faster than can be removed by the cooling fluid, so the mixture heats up, driving the reaction even faster. However, the amount of reactant is also falling down the length of the reactor, so eventually the reaction slows down. The heat released drops off until a point is reached when the amount of heat removed by the cooling fluid just equals the rate of heat production from the reaction. The temperature tops off and then starts to fall as the rate of reaction drops even further. We see

236 BYTE LISTINGS SUPPLEMENT

April

this maximum in the temperature profiles as expected. In addition, if the temperature of the cooling fluid is lowered, the amount of heat removed increases and so the maximum in the temperature will be lower, and will shift towards the inlet. This trend too is observed in the profiles. The rate of reaction is proportional to the temperature, so we would expect to see less reactant in the outlet of the hotter reactor. The (dimensionless) outlet concentrations obtained from the program were .03548,

.03424, and .03321 for the coolant temperatures of 400K, 600K, and 800K respectively. Although we do not know the analytical solution to this problem, we are able to say that our program is producing reasonable results by checking to see if the trends are what we would expect.

EXAMPLE 3. This problem describes the orbit of a satellite. The problem statement and the derivation of the differential equations are described in Shampine, L.F., and M.K. Gordon,

COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS: THE INITIAL VALUE PROBLEM, Freeman, San Fransisco (1975). For our purposes, we will only deal with the final set of equations. They are included in the FORTRAN listing for the user supplied programs for this problem. The format used for this program is similar to that used for the other examples.

The solutions using the three methods over the range t=0 to t*12 are given in table 2. A relative error tolerance of 10(—10) was used. The values of y/1/ and y/2/ at x*12 should be -1.25 and 0 respectively.

NOTE: TABLES 2 & 3 ARE IN SEPARATE FILES ON THIS DISK. THEY MUST BE PRINTED OUT IN 132-COLUMN FORMAT TO BE READABLE.

Table 3 compares the use of the two expressions for the step size adjustement factor - that is for the parameter POWER * 1/p and 1/(p+1). It would appear from this that the expression that contains the term 1/(p+1) is preferrable. Also, the fifth order method gives the most accurate results and the seventh order method uses the least number of function evaluations (the fastest). However, if memory usage is a consideration, the fourth order method is the code that requires the least amount of memory, and is the easiest to code.

atomcc.exe BINARY

"The ATOMCC Toolbox," Y. F. Chang.

April, page 215. If you have and MS-DOS-based system, also download cdrdcv.obj crdcv.obj, drdcv.obj, rdcv.obj, and manual.doc. For other formats, download atspgm.for and painI eve.for .

c*+*+*+*+*+*

c This program was produced by the ATOMCC translator version 7.10 c Copyright (C) 1985, Y. F. Chang

C*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ c Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved, c This program was written for the following inputs c

C FIRST PAINLEVE TRANSCENDENT C DIFF(Y,T,2) = 6.0*Y*Y + T

c no instructions in second Input block

COMMON /IPASS/ LENSER,LENVAR,MPRINT,MSTIFF,LRUN,

+ KTRDCV,KNTSTP,KTSTIF.KXPNUM,KDIGS,KENDFG,NTERMS,NOPT A /RPASS/ RADIUS,ERRLIM,ADJSTF,RCREAL,RCIMAG,RDCERR B /CPASS/ START,END,ORDER C /DPASS/ H,HNEW,XPRINT,DLTXPT DIMENSION TMPS( 36, 1)

CHARACTER*6 NAMES EQUIVALENCE (TMPS(1,1),Y(1))

DIMENSION NAMES(1), Y(36), T(2), TMPAA8(30), TMPAAA(30)

DATA NAMES(1)/*Y.’/ {umUnued)

BYTE LISTINGS SUPPLEMENT 237

O O

April

C

c

c

Y(33) =1.1

10 F0RMAT(72H ATOMCC Ver. 7.10, Copyright (C) 1985. Y. F. Chang: S

Aolution results./9H ******)

11 F0RMAT(/5X,1IHStep number,16.13H at the point,1P1E12.4/1X.

A 9Hvolues of )

12 FORMAT MX, A6. (IX, 1P4E13. 5))

13 FORMAT(5X,21HStepsize adjusted to .1PE13.5)

14 FORMAT(/5X,35HThe solution stopped normally after, I4.24H steps as a set by nsteps. )

16 FORMAT(/5X,63HThe adjustment for stepsize seems to be in a loop P Alease try a /5X,22Hshorter series length. )

WRITE(*,10) '

Initialize variables to default values.

NSTEPS * 40 H = 1.E0 ERRLIM = 1.E- 6 LENSER = 30 MPRINT = 4 NTERMS = 2 KTRDCV = 1

ADJSTF - 1.E-2 MSTIFF = 0

DLTXPT = 0.E0

c

c start of third input block

READ INTEGRATION INTERVAL AND INITIAL CONDITIONS READ(5,1010) START,END,Y(1),Y(2)

1010 FORMAT(4F10.3)

WRITE(*.1020) START,END,Y(1),Y(2)

1020 FORMAT(* SOLVE THE FIRST PAINLEVE TRANSCENDENT* / + * INTERVAL: \2F10.3 /

4 * INITIAL CONDITIONS:*,2F10.3 /)

input block

c end of third

c

c More initializations

DLTXPT = SIGN(DLTXPT,(END-START))

H = SIGN(H,(END-START))

KDIGS = 6

XPRINT - START + DLTXPT

KXPNUM = 35

LENVAR = 36

LRUN = 1

KTSTIF - 0

NUMEQS = 1

IF(LENSER.GT.(LENVAR- 6)) LENSER = LENVAR - 6

IF(MPRINT.LT.2) GO TO 17 WRITE(*,11) KTSTIF,START K = Y(33)

WRITE(*,12) NAMES(K).Y(I), Y(2)

c Loop for integration steps. Inside the loop, print the desired output

17 DO 27 KINTS=1.NSTEPS KOUNT = 0 KNTSTP - KINTS 19 CONTINUE

T(1) = START T(2) = H Y(2) = Y(2)*(H)

c Preliminary series calculations

TMPAAA(I) = 6.E0*Y(1)

TMPAAB(1) = TMPAAA(1)*Y(1)

Y(3) - (TMPAAB(1) + T(1))*(H*H/2.E0) TMPAAA(2) - 6.E0*Y(2)

TMPAAB(2) = TMPAAA(1)*Y(2) + TMPAAA(2)*Y(1) Y(4) = (TMPAAB(2) + T(2))*(H*H/6.E0)

238 BYTE LISTINGS SUPPLEMENT

c Loop for series calculations

DO 23 K= 5,LENSER KA - K - 1 KB = K - 2

TMPAAA(KB) * 6.E0*Y(KB)

TMPAAB(KB) = 0.E0 KZ = 1 + KB DO 30 N=1, KB L = KZ - N

TMPAAB(KB) = TMPAAB(KB) + TMPAAA(N)*Y(L) 30 CONTINUE

Y(K) = (TMPAAB(KB))*(H*H/(KB*KA))

c Test and adjust H to avoid over/under flow.

IF(MSTIFF.GE.20 .AND. KTSTIF.GT.0) GO TO 23 TMP = ABS(Y(K))

IF(TMP.LE.1.E-35) GO TO 23

IF(TMP.LT.1.E20 .AND. TMP.GT.1.E-20) GO TO 23 IF(KTSTIF.NE.0 .AND. TMP.LT.1.0) GO TO 23 KOUNT = KOUNT + 1 IF(KOUNT.LT.9) GO TO 22 WRITER.16)

GO TO 28

22 CONTINUE

Y(2) = Y(2)/(H)

H = H * TMP**(0.3/(1-K))

IF(MPRINT.GE.4) WRITE(*,13) H GO TO 19

23 LRUN - 1

c Calculate radius of convergence and take optimum step.

CALL RDCV(TMPS.LENVAR.NUMEQS,NAMES) 24 CALL RSET(TMPS,LENVAR,NUMEQS,NAMES)

c no instructions in fourth input block

25 GO TO (26,28,24), KENDFG

26 H = SIGN(RADIUS.H)

START = START + HNEW IF(MPRINT.LT.4) GO TO 27 WRITE(*.11) KNTSTP, START K = Y(33)

WRITE(*,12) NAMES(K),Y(1), Y(2)

27 CONTINUE WRITE(*,14) NSTEPS

28 CONTINUE

29 STOP END

onebody.bos

TEXT

"The Runge-Kutto Methods" Benku Thomas.

April, poge 191. This is Listing A, poge 197, written by David M. Leo.

OEM N = THE NUMBER OF INTEGRATORS

20 REM V(I) = INTEGRATOR INPUTS

30 REM X(I) - INTEGRATOR OUTPUTS

40 REM X(1) “ VELOCITY; X(2) - DISPLACEMENT

50 REM C - THE DAMPING CONSTANT

60 REM M - MASS; K - SPRING CONSTANT

70 REM TMIN - TIME AT WHICH PRINTING TO OUTPUT FILE BEGINS

80 REM TMAX - TIME AT WHICH PRINTOUT ENDS

90 REM DT - TIME STEP SIZE

100 REM ********************************

110 OPEN"OUT.DAT" FOR OUTPUT AS #1 120 N-2;C-1500:M-2:K-100000!

130 DIM X(N),K1(N),K2(N),K3(N),K4(N),DUM(N),V(N)

140 DT-.0001:TMIN-DT:TMAX-500*DT

150 REM FNX(T) IS THE DRIVING FORCE mtinuect)

BYTE LISTINGS SUPPLEMENT 2J9

April

160 DEF FNX(T)-5000*(SIN(200*T))^5

170 REM NEXT ARE THE INITIAL CONDITIONS ON VELOCITY,X(1),AND DISPLACEMENT X(2) 180 X(1)-.001:X(2)-.001 V '

190 REM NEXT IS THE EQUATION FOR THE INPUT TO INTEGRATOR #1 200 REM IN THIS CASE, THERE IS COULOMB DAMPING 210 V(1)-(FNX(T)-K*X(2)-C*SGN(X(1)))/M:V(2)«X(1)

220 REM NEXT ARE THE STEPS IN THE INTEGRATION ACROSS ONE TIME STEP

230 COUNT-COUNT+1:IF COUNT-2 THEN 260:IF COUNT-3 THEN 270:IF COUNT-4 THEN 280

240 FOR I- 1 TO N:K1(I)-DT*V(I):NEXT I

250 T-T+DT/2:F0R 1-1 TO N:DUM(I)-X(I):X(I)-DUM(I)+K1(I)/2:NEXT IsIF COUNT-1

260 FOR I- 1 TO N:K2(I)«DT*V(I):X(I)-DUM(I)+K2(I)/2:NEXT I:IF COUNT-2 THEN 210 270 FOR 1=1 TO N:K3(I)=DT*V(I):X(I)=DUM(I)+K3(I):NEXT I:T=T+DT/2:IF COUNT-3 THEN 210 280 FOR 1-1 TO

N:K4(I)-OT*V(I):X(I)-DUM(I)+(K1(I)+K4(I))/6+(K2(I)+K3(I))/3:NEXT I

290 REM NEXT STEPS APPROXIMATE STATIC/DYNAMIC FRICTION

300 IF ABS(X(1))>.5 THEN 330

310 C-3000

320 GOTO 340

330 C-1500

340 IF X(2)>1I THEN 440

350 REM FROM RUNNING THIS A FEW TIMES, WE EXPECT A8S(DISPLACEMENT) < .030 360 REM OVER THIS RANGE, THE NONLINEAR SPRING RATE CAN BE APPROXIMATED AS FOLLOWS:

370 K=100000!+300000!*(SIN(50*X(2))W 380 IF T<TMIN THEN 210

390 PRINT #1,FNX(T):FOR 1-1 TO N:PRINT #1.X(I):NEXT I

400 IF T>TMAX THEN 420

410 GOTO 210

420 CLOSE

430 GOTO 450

440 PRINT" DIVERGENT OSCILLATION ENCOUNTERED"

450 END

remes.c TEXT

"Computer Approximations," Stephen Moshler. See chbevl.c.

0 remes.c *

* This Is an interactive program that computes least maximum polynomial

* and rational approximations.

*/

^define P 15 /* max total degree of polynomials, + 2 */

^define N 20 /* number of items to tabulate for display */ extern double PI; /* 3.14159... */

static int IPS[P] = {0.}; static double AA[P*P] * {0.0,}; static double BB[P] = {0.0,}; static double param[P] = {0.0,}; static double xx[P] = {0.0,}; static double ref[N+1] * {0.0,}; static int n * 0; static int d = 0; static int ndl * 0;

/* simq() work vector */

/* coefficient matrix */

/* right hand side vector */

/* solution vector */

/* points in approximation interval*/ /* function values for display */

/* degree of numerator polynomial*/

/* degree of denominator polynomial*/ /* n + d + 1 */

main()

int l. Ip, j, ncheb, neq, relerr; double a, apstrt, apwidt, b, c, x, y, z; char s[40];

double abs(), approxQ, cos(), funcQ; int simq();

P r intf( "\nRationaI Approximation by Remes Algorithm\n\n" );

START:

Printf( "Relative error (y or n) ? " ); /* Ask for error criterion */

gets( s ); /* read in a line of characters */

240 BYTE LISTINGS SUPPLEMENT

re I err * 0;

|f( s[0] == -y' )

re I err ■ 1;

April

printf( "Degree of numerator polynomial? " ); gets( s ); /* read line */

sscanf( s, "%d", &n ); /* decode characters */

printf( "Degree of denominator polynomial? " ); gets( s );

sscanf( s, "%d", &d );

printf ( "Start of approximation interval ? " gets( s );

sscanf( s, "%E", fcapstrt );

printf ( "Width of approximation interval ? " ); gets( s );

sscanf( s, "%E", fcapwidt ); ndl « n + d + 1;

/* remes.c 2 */

/* Supply initial guesses for points in approximation interval */

If( d

e I se

== 0 )

{ /* there is no denominator polynomial */

neq = n + 2; /* The number of equations to solve */ ncheb « n + 1; /* Degree of Chebyshev error estimate */ /* Extrema of Chebyshev polynomial */ a * ncheb;

for( i*0; i<neq; i++ ) xx[i] - apstrt

+ 0.5 * apwidt * (1.0 - cos( (PI * i) / a ) );

{ /* there is a denominator polynomial */

neq * ndl; ncheb * ndl;

/* Zeros of Chebyshev polynomial */

a ■ 2.0 * ncheb;

for( l»0; icncheb; i++ )

{

xx[i] * apstrt

+ 0.5 * apwidt * (1.0 - cos( PI * (2*i+1) / a ) ); c - 0.0; /* deviation at solution points */

/* calculate function table for error curve display */

a - apwidt/N;

b = apstrt;

for( i=0; i<«N; i++ )

ref[i] * func(b); /* func is the f(x) to be approximated */

b +* a;

*

/* remes.c 3 */

LOOP:

/* Display old values of guesses and let user change them if desired */

/* First do the deviation guess if rational form */

I f ( d > 0 )

{ /* there Is a denominator */

c « abs(c); /* deviation at solution points */ printf( "deviation « %.4E ? ", c ); gets( s );

lf( s[0] !« *\0’ ) /* if input is not a null line, */

sscanf( s, "%E", See ); /* then decode the number */

[continued)

BYTE LISTINGS SUPPLEMENT 241

\

else /* no denomlnotor: */

c - 1.0; /* coefficient of the deviation */

/* Read in guesses for locations of solution */ for( 1-0; l<neq; I++ )

prIntf( "x[%d] - %. 4E ? ", I, xx[I] ); gets( s );

If( s[0] !- # \0’ )

sscanf( s, "%E", &x ); xx[i] « x;

/* remes.c

4 */

/* Set up the equations for solution by simq() */ for( i=0; I<neq; I++ )

ip « neq * I; /* offset to 1st element of this row of matrix*/ x = xx[i]; /* the guess for this row */

/* right-hand-side vector */

y = func(x); /* accurate function value f(x) */ lf( d > 0 )

{ /* add the deviation If rational form */ if( relerr ) /* relative error criterion */

y - y * (1.0+c);

else /* absolute error criterion */

^ y » y + c;

/* insert powers of x[i] for numerator coefficients */

2 - 1 . 0 ;

for( j*0; j<«n; j++ )

AA[ip+j] - z; z » z * x;

\

/* insert denominator terms, if any */

If( d > 0 )

i

z = 1.0;

for( j-0; j<d; j++ )

AA[ip+n+1+j] = -y * z; z = z * x;

BB[T] = y * z; /* right hand side vector */

e I se

J /* no denominator */

BB[i] = y; /* right hand side vector */ y = c;

If( relerr )

y » y * BB[i];

AA[ip+n+1] = y;

c = -1.0 * c; /* switch sign of deviation for next row */

/* Solve the simultaneous linear equations */ slmq( &AA[0], &BB[0], &param[0], neq, 0, &IPS[0] );

/*

/* Display the results */

j * 0; /* printout variable */

ip = 0; /* solution vector counter */ printf( "Numerator coefficients:\n" ); for( i-0; I<»n; i++, j++, ip++ )

if( j > m ? )

prlntf( “\n" )-.

remes.c

5 */

242 BYTE LISTINGS SUPPLEMENT

printf( "%.4E ", param[ip] ); if( d > 0 )

j = 0;

printf( "\nDenominator coefficients:\n" ); for( i»0; i<d; i++, j++, ip++ )

if( j >=^7 )

printf( "\n" );

pr intf( "%.4E ", param[ip] );

e I se

pr I nt f( "\nDeviatIon: %.4E", paramfip] );

/* Display table of function and approximation error */

printf( "\n\n x func approx error\n" );

a = apwidt/N;

b = apstrt;

for( i=0; i<=N; 1++ )

x * b + i * a; z * approx(x); y « z - ref[i]; i f( re I err kk (z !« 0.0) )

y = y/z;

pr Intf( "%.3E %.3E %.3E %.3E\n",

printf( "Another iteration (y or n)? " ) gets( s ); i f ( s[0] *y' )

goto LOOP; if( s [0] == ’x* ) exit(0);

e I se

^ goto START;

x. ref[i], z. y );

/* Ask what to do next

*/

/*

remes.c 6 */

/* This subroutine computes the rational form P(x)/Q(x) fusing coefficients from the solution vector param[]

double approx(x) double x;

{

double yn, yd;

Int I;

yn = param[n]; /* highest order numerator coefficient */

for( i»n-1; i>«0; i— ) /* work backwards toward the constant term */ yn ■ x * yn + param[i];

I f ( d > 0 )

yd » x + param[n+d]; /* highest order coefficient = 1.0 */

for( i«n+d-1; 1>n; i— )

^ yd - x * yd + param[i];

e I se

yd ■ 1.0; /* if there is no denominator */ return( yn/yd );

/* Put here an accurate routine for the function * to be approximated

(continued)

\

BYTE LISTINGS SUPPLEMENT 243

April

double func(x) double x;

double cos(), sqrt(); double y;

y - sqrt(x);

return( cos(PI * y / 2.0) );

Screen #1

( begin Dragon curve )

CREATE CURVE ( a FORGETabIe name)

CARTESIAN OFF

: RECURS SMUDGE ; IMMEDIATE ( trick verb for recursion)

VARIABLE ANGLE VARIABLE XCOOD VARIABLE YCOOD VARIABLE STEPSIZE

: TURN ( deltangle— | turn slgn*delta)

ANGLE +! ;

2 4 THRU

Screen #2

: MOVE ( — | takes a step In present turtle direction) STEPSIZE @ DUP

ANGLE e COS * 10000 / ( r* cos of theta) XCOOD @ +

DUP ( newX) XCOOD ! ( update X)

SWAP

ANGLE e SIN * 10000 / ( r* sine theta ) YCOOD @ +

DUP ( newY) YCOOD l ( update Y)

DRAW.TO ;

Screen #3

: DRAGON ( sign level— | )

DUP ( level) 0=

IF ( at bottom of recursion)

DROP ( level) DROP ( sign) MOVE ( by stepsize) ELSE

OVER 45 * TURN ( getsign and turn)

1 ( newsign)

OVER 1- ( I eve I = I eve 1-1)

RECURS DRAGON RECURS

OVER -90 * TURN ( getsign & turn)

-1 ( newsign) ( edit to +1 for diff curve)

OVER 1- ( level-level-1)

RECURS DRAGON RECURS

DROP ( Input level) 45 * TURN ( getsign and turn) THEN ;

Screen #4

: DCURVE (level —| )

( Inlt pen position)

PAGE 100 XCOOD I 90 YCOOD ! 360 6 * ANGLE I

WHITE PENPAT XCOOD @ YCOOD @ MOVE.TO

PEN.NORMAL 1 STEPSIZE !

1 SWAP ( level) DRAGON

WHITE PENPAT 4 10 MOVE.TO PEN.NORMAL ;

244 BYTE LISTINGS SUPPLEMENT

s imq.c TEXT

"Computer Approximations," Stephen Moshier. See chbevl.c.

0

* Solution of simultaneous linear equations AX = B

* by Gaussian elimination with partial pivoting

*

♦

*

* SYNOPSIS:

*

* double A[n*n], B[n], X[n];

* int n, flag;

* int IPS[1;

* Int simqQ;

*

* ercode « simq( A, B, X, n, flag, IPS );

♦

*

*

♦ DESCRIPTION:

♦

* B, X, IPS are vectors of length n.

* A is an n x n matrix (i.e., a vector of length n*n),

* stored row-wise: that is, A(i,j) « A[ij],

* where ij = i*n + j, which is the transpose of the normal

* column-wise storage.

*

* The contents of matrix A are destroyed.

*

* Set flag=0 to solve.

* Set flag=-1 to do a new back substitution for different B vector

* using the same A matrix previously reduced when flag=0.

*

* The routine returns nonzero on error; messages are printed.

*

♦

♦ ACCURACY:

*

* Depends on the conditioning (range of eigenvalues) of matrix A.

♦

♦

* REFERENCE:

*

* Computer Solution of Linear Algebraic Systems,

* by George E. Forsythe and Cleve B. Moler; Prentice-Hall, 1967.

int simq( A, B, X, n, flag, IPS ) double A[], B[j, X[]; int n, flag;

int i, j, IJ, ip, ipj, ipk. ipn; int idxpiv, iback; int k, kp, kpl, kpj, kpk, kpn; int nip, nkp, nml;

double em, q, rownrm, big, size, pivot, sum; double abs();

l f ( f lag < 0 )

goto solve;

/* Initialize IPS and X */

I J-0;

for( i-0; I<n; I++ )

IPS[I] - I;

rownrm - 0.0;

for( j-0; J<n; J++ )

^ ( continued)

BYTE LISTINGS SUPPLEMENT 245

April

{■

/*

/♦

nml

q - obs( A[IJ]

1 1 ( rownrm < q

rownrm * q;

r 1J:

if( rownrm ■■ 0.0 )

puts("SIMQ ROWNRM®0"); return(1);

X[i] * 1.0/rownrm;

Gaussian elimination with partial pivoting

n-1;

for( k=0; k<nm1; k++ ) bIg= 0.0;

for( i-k; I<n; i++ )

ip - IPS[I];

Ipk = n*ip + k;

size ■ abs( A[ipk] ) * X[Ip];

I f ( size > big )

big = size;

Idxplv * I;

• 1

*/

I f( big — 0.0 )

pu18( “SIMQ BIG-0" ); return(2);

I f ( Idxpiv !« k )

j - IPS[k] ;

IPS[k] - IPS[idxpiv];

IPS[ldxpIv] - j;

kp = IPS[k]; kpk ■ n*»«kp + k; pivot - A[kpk]; kpl = k+1;

for( i=kp1; i<n; I++ )

ip - IPS[i];

Ipk * n*ip + k; em » -A[ipk]/pivot;

A[ipk] = -em; nip = n*ip; nkp = n*kp;

for( J-kpl; j<n; j++ ) ipj = nip + J;

A[< p j] - A[ipj] + em * A[nkp + j];

kpn = n * IPS[n— 1 3 + n - 1; /* lost element of IPS[n] th row */

if( A[kpn] =» 0.0 )

puts( "SIMQ A[kpn]=0"); return(3);

/*

/* back substitution */

solve:

ip = IPS[0];

X[0] = B[ip];

for( i»1; i<n; i++ )

246 BYTE LISTINGS SUPPLEMENT

ip ° i P j sum for (

X[i]

IPS[ i ]-; n * ip;

0 . 0 ;

j=0; J<i; j++ )

sum += A[ipj] * X[j]; ++ipj;

= b|i P ] - sum;

ipn * n * IPS[n-1] + n - 1;

X[n-1] - X[n-1]/A[ipn];

for( Iback*1; iback<n; iback++ )

/* i goes (n-11 */

i = nml - iback;

Ip - IPS[i]; nip = n*ip; sum = 0.0;

for( j«i+1; j<n; j++ )

sum +* A[nip+j] * X[j]; X[f] ■ (X[i] - sum)/A[nip+iJ;

return(0);

List!ng4.pas TEXT

Programming Project: "A Simple Windowing System, Part 2: Implementation," Bruce Webster.

April, page 96. Listing 4, page 101. Apple Pascal.

BBuf"[Of fset+3] :* Height;

DoXfer(Save,Buffer);

OldOff :« Offset;

Offset := Offset + Size;

BBuf"[Of fset-11 :« OldOff div 256; BBuf~[0ffset-2J OldOff mod 256; BufUsed :* True end;

XI XI * PPB; X2 X2 * PPB; Viewport(XI,X2,Y1,Y2);

Fi I IScreen(White);

ViewPort(X1+2.X2-2,Y1+1,Y2-1);

Fi I IScreen(Black) end; j of proc OpenWindow {

procedure CloseWindow(var Error : Integer); var

XI.X2.Y1,Y2,Width,Height : Integer; beg i n

(* error checking again omitted for space *) Offset OldOff;

DoXfer(Restore,Buffer) ;

If Offset * 0

then BufUsed :« False

else with Buffer do

OldOff 256*BBuf^[Offset-1] + BBuf"[Offset-2];

If BufUsed then with Buffer do begin

XI Y1

Width Height X2 Y2

BBuf"[01dOff] * PPB;

BBuf " ‘oldOff + r BBuf" 0 1 dOf f+2 BBuf "[01dOf f+3 XI + PPB*Width - 1 Y1 + Height - 1;

ViewPo r t(X1+2,X2-2,Y1 +1,Y2-1) end

else VlewPort(0,279,0,191) end; { of proc CloseWindow j

( continued)

BYTE LISTINGS SUPPLEMENT 247

procedure Initialize; beg I n

InitTurtIe;

Offset 0; OldOff 0; BufUsed :■ False end; ) of proc Initialize }

[LISTING 4] 0onst

XMln

0

XMax

m

39

YMin

m

0

YMax

=

191

PPB

=

7

BufAddr

m

16384

BufSize

m

16383

type

Byte = 0..255;

Direction = (Save.Restore);

ByteBuffer * packed array[0..BufSIze] of Byte; BufRec *

record

case Boolean of

False : (Addr : Integer);

True : (BBuf : ^ByteBuffer)

end;

var

BufUsed : Boolean;

Buffer ; BufRec;

Offset,01dOff: Integer;

function ScrAddr(Line : Integer) : Integer; var

Addr,Temp : Integer;

beg i n

Line :■ 191 - Line;

Addr 8192 + 1024 * (Line mod 8);

Temp :■ (Line div 8) mod 8;

Line :* Line div 64;

ScrAddr :« Addr + 128 * Temp + 40 * Line end; { of func ScrAddr }

function DoXfer(Dir : Direction; var Buffer : BufRec); var

XI,Y1.Y2.Width,Height,BStart,Line : Integer;

TBuf : BufRec;

begin

with Buffer do begin

XI := BBuf^[Offset];

Y1 := BBuf^[Of fset + 11;

Width := BBufn0ffset+2l;

Height := BBuf~[0ffset+3J;

BStart ;= Offset + 4;

Y2 :* Y1 + Height - 1; for Line := Y1 to Y2 do begin TBuf.Addr ;« ScrAddr(Line); if Dir * Save

then MoveLeft(TBuf.BBuf*[X1],BBuf A [BStart],Width) else MoveLeft(BBuf~[BStart],TBuf.BBuf*[XI].Width) BStart := BStart + Width

end

end

end; { of proc DoXfer }

procedure 0penWindow(X1,Y1.Width,Height : Integer;

var Error : Integer);

var

Size,X2,Y2 : Integer;

248 BYTE LISTINGS SUPPLEMENT

beg I n Size X2 Y2

6 + Width*Height;

XI + Width - 1;

Y1 + Height - 1;

(* error checking goes here — with Buffer do begin

removed for space

BBuf^[Offset BBuf~[Offset+1 BBuf~[0f fset+2

XI;

Y1;

Width;

*)

chbevI.c TEXT

"Computer Approximations," Stephen Moshier.

April, page 161. Also download cheby.c, remes.c, and simq.c. For related modules, see the Cephes subsection of the C+UNIX file area.

0 chbevI.c

♦

♦ Evaluate Chebyshev series

*

♦

*

* SYNOPSIS:

*

* int N;

* double x, y, coef[N], chebevlQ;

*

* y « chbevl( x, coef, N );

*

*

★

* DESCRIPTION:

★

* Evaluates the series

♦

*

*

* y

*

*

♦

* of Chebyshev polynomials Ti at argument x/2.

*

* Coefficients are stored in reverse order, i.e. the zero

* order term is last in the array. Note N is the number of

♦ coefficients, not the order.

♦

* If coefficients are for the interval a to b, x must

* have been transformed to x -> 2(2x - b - a)/(b-a) before

* entering the routine. This maps x from (a, b) to (-1, 1),

* over which the Chebyshev polynomials are defined.

*

* If the coefficients are for the inverted interval, in

* which (a, b) is mapped to (1/b, 1/a), the transformation

* required is x -> 2(2ab/x - b - a)/(b-a). If b is infinity,

* this becomes x -> 4a/x - 1.

*

*

♦

* SPEED:

*

* Taking advantage of the recurrence properties of the

* Chebyshev polynomials, the routine requires one more

* addition per loop than evaluating a nested polynomial of

* the same degree.

*

*/

/* chbevl.c */

N-1 _ »

- > coef[i] T (x/2)

i

i *=0

[continued)

BYTE LISTINGS SUPPLEMENT 249

/* * Cephas Math Library Release 1.1: March, 1985

♦ Copyright 1985 by Stephen L. Moshler

* Contributed to BIX for personal, noncommercial use only.

★ Direct Inquiries to 30 Frost Street, Cambridge, MA 02140 */

double chbevl( x, array, n ) double x; double array[];

Int n;

doubIe b0, b1. b2, *p;

Int I;

p = array; b0 « *p++; bl - 0.0;

I ■ n - 1;

do

i

b2 = bl; bl - b0;

b0 » x * bl - b2 + *p++;

}

while( —i ); return( 0.5*(b0-b2) );

cheby.c TEXT

"Computer Approximations," Stephen Moshier. See chbevl.c.

'*

>u

i

:o

I

vh

cc

/<

h

pi

X

y

ii

r

pi

,s

P'

I

wl

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

Note 8

Note 9

Note 10

Note 11

Note 12

Note 13

Note 14

Note 15

Note 16

Note 17

Note 18

Note 19

low « 0.0; high - 1.0; i nvfIg = 0;

/* Note: inverted z = 0.0; n = 64;

n2 « n/2; t * n; t « PI/t;

/* 3.14159... */

/* cosine array for Fourier transform */ /* values of the function */

temp;

/

/

/

/

Note 20

/* calculate array of cosines */ puts("caIcuI ating cosines"); s = 1.0; cosi[0] = 1.0; i = 1;

while( i <32 )

y = cos( s * t ); cosi[i] = y; s += 1.0;

++i;

cosi[32] = 0.0;

/* cheby.c 2 */

/* calculate function at special values of the argument */

puts("caIcuI ating function values"); x * low; y - high;

I f ( invflg && (low !« 0.0) )

{ /* inverted interval */

temp « 1.0/x; x = 1.0/y; y ** temp;

r = (x + y)/2.0;

printf( "center %.15E ", r);

8 “ (y - *)/2.0;

prIntf( "width %.15E\n", s); i - 8;

whil«( I < 65 )

if( i < n2 )

c - cosi[i];

e I se

c - -cosi[64-i]; temp * r + s * c;

/* if inverted interval, compute function(1/x) */ if( invflg && (temp l* 0.0) ) temp « 1.0/temp;

prIntf( "X.15E ", temp );

/* insert call to function routine here: */

/♦***♦*♦***+*+****♦♦*****♦*♦*++♦**♦/

1 f( temp *= 0.0 )

y - 1.0;

e I se

y « exp( temp * log(2.0) );

/♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦♦★♦♦♦♦♦♦♦♦♦♦♦♦♦/ func[i1 = y; printf( "X.15E\n", y );

++i;

/* cheby.c 3 */

puts( "calculating Chebyshev coefficients"); rr » 0;

whiIe( rr < 65 )

z » func[0]/2.0;

J - i;

whi le( J <65 )

k - (rr * J)/n2; i ■ rr * J - n2 * k; k &- 3;

if( k — 0 )

c ■ cos i [ i ]; lf( k — 1 )

^ {continued)

BYTE LISTINGS SUPPLEMENT 251

Chapter Notes

0 cheby.c

♦

* Program to calculate coefficients of the Chebyshev polynomial

* expansion of a given Input function. The algorithm computes

* the discrete Fourier cosine transform of the function evaluated

* at unevenly spaced points. Library routine chbevl.c uses the

* coefficients to calculate an approximate value of the original

* function.

* — S. L. Moshier */

extern double PI; extern double PI02; double cosi[331 * {0.0,|; double func[65J - {0.0,{;

main()

double c, r, s, t, x, y, z, double low, high, dtemp; long n;

Int l, M, J, n2, k, rr, invflg; short *p; char st[40];

double cos(), log(), exp(), sqrt();

/* low end of approximation interval */

/* high end */

/* set to 1 if inverted interval, else zero */ interval goes from 1/high to 1/low */

/* will find 64 coefficients */

/* but use only those greater than roundoff error */

250 BYTE LISTINGS SUPPLEMENT

April

I - 32-1; c ■ -cosi[I]; lf( I — 32 )

I c - -c;

lf( k -2 )

c * -cosi[! 1;

■«*>

i - 32-!; c ■ cos I [ I ];

I

ff( I !- 32)

i

temp * func[j]; temp » c * temp; z +* temp:

\

r Js

If( I !- 32 )

temp /* 2.0; z « z - temp;

2 *- 2 . 0 ; temp ■ n; z /■ temp; dtemp « 2 ;

++r r;

sprIntf( st. V* X.16E */". dtemp ); P u ts( st );

otspgm.for TEXT

"The ATOMCC Toolbox," Y. F. Chang. See atomcc.exe.

c*+*+*+★+*+*

c This program was produced by the ATOMCC translator version 7.10

c Copyright (C) 1985, Y. F. Chang

0 *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+♦+*+*+*+*+*+*+

c Portions (c) Copyright. Microsoft Corp., 1981. All rights reserved, c This program was written for the following inputs c

C FIRST PAINLEVE TRANSCENDENT C DIFF(Y,T,2) = 6.0*Y*Y + T

c no instructions in second input block

COMMON /IPASS/ LENSER.LENVAR.MPRINT.MSTIFF,LRUN,

+ KTRDCV. KNTSTP. KTSTIF. KXPNUM, KDIGS, KENDFG. NTERMS. NOPT A /RPASS/ RADIUS,ERRLIM,ADJSTF,RCREAL,RCIMAG,RDCERR B /CPASS/ START.END.ORDER C /DPASS/ H,HNEW,XPRINT,DLTXPT DIMENSION TMPS( 36. 1)

CHARACTER*6 NAMES EQUIVALENCE (TMPS(1,1),Y(1))

DIMENSION NAMES(I). Y(36). T(2). TMPAAB(30), TMPAAA(30)

DATA NAMES( 1 )/’Y.’/

Y(33) =1.1

10 F0RMAT(72H ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang; S

Aolution results./9H ******)

11 F0RMAT(/5X.IIHStep number,16,13H at the point,1P1E12.4/1X,

A 9Hvalues of )

12 FORMATfIX, A6,(IX,1P4E13. 5))

13 F0RMAT(5X,21HStepsize adjusted to .1PE13.5)

252 BYTE LISTINGS SUPPLEMENT

O O

April

14 FORMAT(/5X,35HThe solution stopped normally after, I4,24H steps as a set by nsteps. )

16 FORMAT(/5X,63HThe adjustment for stepsize seems to be in a loop. P Alease try a /5X,22Hshorter series length. )

WRITE(*,10)

c Initialize variables to default values.

NSTEPS = 40 H = 1.E0 ERRLIM = 1.E- 6 LENSER = 30 MPRINT « 4 NTERMS = 2 KTRDCV * 1

ADJSTF « 1.E-2 MSTIFF * 0

DLTXPT « 0.E0

c start of third input block

READ INTEGRATION INTERVAL AND INITIAL CONDITIONS.

READ(5,1010) START,END,Y(1),Y(2)

1010 F0RMAT(4F10.3)

WRITE(*,1020) START,END,Y(1),Y(2)

1020 FORMAT(’ SOLVE THE FIRST PAINLEVE TRANSCENDENT * / + * INTERVAL: *,2F10.3 /

+ # INITIAL CONDITIONS:*.2F10.3 /)

c end of third input block

c More initial!zations

DLTXPT - SIGN(DLTXPT,(END-START))

H - SIGN(H,(END-START))

KDIGS * 6

XPRINT * START + DLTXPT

KXPNUM - 35

LENVAR - 36

LRUN - 1

KTSTIF * 0

NUMEQS = 1

IF(LENSER.GT.(LENVAR- 6)) LENSER « LENVAR - 6

IF(MPRINT.LT.2) GO TO 17 WRITE(*,11) KTSTIF,START K « Y(33)

WRITE(*,12) NAMES(K),Y(1), Y(2)

c Loop for integration steps. Inside the loop, print the desired output

17 DO 27 KINTS-1,NSTEPS KOUNT - 0 KNTSTP - KINTS 19 CONTINUE

T(1) - START T(2) - H Y(2) * Y(2)*(H)

c Preliminary series calculations

TMPAAA(I) * 6.E0+YM)

TMPAAB(l) - TMPAAA(1)*Y(1)

Y(3) » (TMPAAB(I) + T(1))*(H*H/2.E0) TMPAAA(2) « 6,E0*Y(2)

TMPAAB(2) - TMPAAA(1)*Y(2) + TMPAAA(2)*Y(1) Y(4) - (TMPAAB(2) + T(2))^(H*H/6.E0)

c Loop for series calculations

DO 23 K- 5,LENSER KA - K - 1 KB ■ K — 2

TMPAAA(KB) - 6.E0*Y(KB) TMPAAB(KB) - 0.E0 KZ - 1 + KB DO 30 N-1, KB L - KZ - N

BYTE LISTINGS SUPPLEMENT

253

TMPAAB(KB) - TMPAAB(KB) + TMPAAA(N)*Y(L) 30 CONTINUE

Y(K) - (TMPAAB(KB))*(H*H/(KB*KA))

c Test ond adjust H to avoid over/under flow.

IF(MSTIFF.GE.20 .AND. KTSTIF.GT.0) GO TO 23 TMP - ABS(Y(K))

IF(TMP.LE.1.E-35) GO TO 23

IF(TMP.LT.1.E20 .AND. TMP.GT.1.E-20) GO TO 23 IF(KTSTIF.NE.0 .AND. TMP.LT.1.0) GO TO 23 KOUNT = KOUNT + 1 IF(KOUNT.LT.9) GO TO 22 WRITE(*,16)

GO TO 28

22 CONTINUE

Y(2) = Y(2)/(H)

H = H * TMP**(0.3/(1-K))

IF(MPRINT.GE.4) WRITE(*,13) H GO TO 19

23 LRUN - 1

c Calculate radius of convergence and take optimum step.

CALL RDCV(TMPS,LENVAR,NUMEQS.NAMES) 24 CALL RSET(TMPS,LENVAR,NUMEQS,NAMES) c

c no instructions In fourth Input block

25 GO TO (26,28,24), KENDFG

26 H = SIGN(RADIUS.H)

START - START + HNEW

IF(MPRINT.LT.4) GO TO 27 WRITE(*.11) KNTSTP, START K = Y(33)

WRITE(*,12) NAMES(K),Y(1), Y(2)

27 CONTINUE WRITE(*,14) NSTEPS

28 CONTINUE

29 STOP END

254 BYTE LISTINGS SUPPLEMENT

April

manuoI.doc BINARY

"The ATOMCC Toolbox," Y. F. Chang. See atomcc.exe.

ATOMCC USER MANUAL

For Micro-Computers on MSDOS Version 7.10 by

Y. F. Chang

Copyright (C) 1983, 1985 Y. F. Chang

MSDOS is a registered trademark of Microsoft Corp.

BYTE LISTINGS SUPPLEMENT 255

Table of Contents

Chapter 1 Introduction 1

1.1 The Major Advancements In this Version 1

1.2 Purpose and Requirements of the Translator 1

1.3 AppIicabiIity 2

1.4 System Overview 4

1.4.1 The Translator, ATOMCC 4

1.4.2 Tha Object Program, ATSPGM 4

1.5 Purpose of the User Manual 5

1.6 Acknowledgements 5

1 .7 References g

Chapter 2 For New Users g

2.1 Task of the ATOMCC Translator 8

2.2 Using the ATOMCC system 9

2.2.1 Step 1 - edit ODEINP 10

2.2.2 Step 2 - Run ATOMCC 14

2.2.3 Step 3 and 4 - Compile and link ATSPGM 15

2.2.4 Step 5 - Prepare the data 15

2.2.5 Step 6 - Run ATSPGM 16

2.3 Output at equally spaced points 17

2.3.1 2ER0T - Stopping at roots of variables 17

2.3.2 MSTIFF-20,21 ,22 - Stiff problems. 18

Chapter 3 How to Use - 20

3.1 Solving your problem 20

3.1.1 Translator file, ODEINP 20

3.1.2 Translator file, the terminal 22

3.1.3 Translator file, ATSPGM 23

3.1.4 DATA input file 27

3.1.5 Solution fiIe 28

3.1.6 User files 29

3.2 Using block 1 29

3.2.1 Format for the system of equations 30

3.2.2 Parameters in the equations 31

3.2.3 COPTION DOUBLE - Double-precision ATSPGM 31

3.2.4 COPTION COMPLX - Complex ATSPGM 32

3.2.5 COPTION DOUBLE. COMPLX - Double-complex ATSPGM 33

3.2.6 COPTION LENVAR=n - Series length 35

3.2.7 COPTION DUMP=n - Diagnostic messages 36

256 BYTE LISTINGS SUPPLEMENT

- ii

3.3 Using block 2 36

3.3.1 Subroutine form of ATSPGM 37

3.3.2 User declarations 37

3.3.3 Common blocks for user 38

3.4 Using block 3 38

3.4.1 Initial conditions 39

3.4.2 Parameters in the differential equations 39

3.4.3 Solve a problem repeatedly 40

3.4.4 START, END - Interval of integration 40

3.4.5 NSTEPS - Number of integration steps, default=40 40

3.4.6 H - Initial trial stepsize, default * 1.0 41

3.4.7 ERRLIM - Preset accuracy of the solution 41

3.4.8 ADJSTF - Error control for stiff problems 41

3.4.9 LENSER - Length of series used, default=30 42

3.4.10 MPRINT - Amount of print produced, default«4 42

3.4.11 DLTXPT - Print point increments, default * 0.0 43

3.4.12 KTRDCV - Dynamic suppression of CALL RDCV 43

3.4.13 KPTS - Number of points on complex poth 44

3.4.14 POINTS - Complex path of integration 44

3.4.15 MSTIFF=10 - Solutions which are entire 44

3.4.16 MSTIFF-20,21,22 - Stiff problems. 44

3.4.16.1 Steady-State Stiff Problems 45

3.5 Using block 4 46

3.5.1 Automatic printing of output points 46

3.5.2 User controlled printing of output points 47

3.5.3 Logarithmic spacing of output points 48

3.5.4 ZEROT - Stopping & printing at roots of variables 48

3.5.5 Finding singularities in real solutions 49

3.5.6 Stopping short of a singularity 51

3.6 Editing of ATSPGM 51

3.6.1 TERM - Fast generation of print at output points 51

3.7 Large systems 54

3.8 Solving ODE’s in the complex domain 54

BYTE LISTINGS SUPPLEMENT 257

- i

(Internal page reference for manual.doc)

Chapter 1 Int roduction

This chapter Is written to help you become familiar with the purpose and requirements of the ATOMCC system and with the organization of this manual.

1.1 The Major Advancements in this Version

The present version of ATOMCC, 7.10 for micros, contains a major advancement. Now, the ATOMCC system will solve stiff problems. This represents a significant departure from the central premise of the ATOMCC system, which is precise error control. For non-stiff problems, the user still have the most accurately controlled numerical method ever developed. For many problems, the precision Is so good that there is ALMOST global error control.

For stiff problems, due to the nature of the "approximating" solution, there cannot be true error control. Therefore, the controlling parameter for errors in stiff problems is called ADJSTF. It is only meant to be an adjusting constant that can be loosely refered to as an error control.

There is also another particularly useful feature in the current version. All the dependent variables are now placed into a temporary two-dimensional array (TMPS) by an EQUIVALENCE statement. This allows the user to reference each variable by an index value. For a system with x, y, and z as functions of t, the term y(5) can be also refered to as TMP$(5,2). Similarly, z(23) = TMPS(23,3).

1.2 Purpose and Requirements of the Translator

The ATOMCC system is a tool to be used in the solution of all initial value problems in ordinary differential equations, (stiff as well as non-stiff). It is simple enough to be used by students, practical enough to be used by engineers, and versatile enough to be used by research mathematicians.

The ATOMCC package is delivered on floppy disks. It uses Microsoft-F0RTRAN77 (a registered trademark of Microsoft Corp.)

258 BYTE LISTINGS SUPPLEMENT

- 2

(Internal page reference for manual.doc)

and works on a micro-computer operating under MS-DOS. With the ATOMCC system, you now have in your possession a research tool whose capabilities far exceed those of standard numerical integration methods available on main-frame computers. To be able to run ATOMCC on your MSDOS micro-computer, you must have the following hardware and software:

- an MSDOS computer, with an 8087 co-processor;

- at least 256K of RAM memory;

- two floppy disc drives, or a hard disc drive;

- the Microsoft-F0RTRAN77 version 3.30.

A complete system includes the following disc files.

- The ATOMCC system files are:

ATOMCC.EXE

RDCV.OBJ

DRDCV.OBJ

CRDCV.OBJ

CDRDCV.OBJ

This is the ATOMCC compiler that reads statements of differential equations and generates an object FORTRAN program called ATSPGM. The name ATSPGM for the object program file is fixed, but you may change it after it has been written by ATOMCC.

This is the ATOMCC subroutine library in singI e-precision.

This is the ATOMCC subroutine library in doubIe-prec1sion.

This is the ATOMCC subroutine library in comp I ex.

This is the ATOMCC subroutine library in comp Iex-doubIe.

- The Microsoft-F0RTRAN77 files are descripted in the Microsoft manual. The relevant files are:- F0R1.EXE, PAS2.EXE,

LINK.EXE, and FORTRAN.LIB.

Throughout the discussions in this User Manual, we shall assume that all of the ATOMCC system files are on the A: floppy-disk drive, and the Microsoft-F0RTRAN77 files are on the B: drive.

1.3 AppIicabiIity

- The ATOMCC method can solve:

* systems of stiff and non-stlff systems of initial value problems In ordinary differential equations in which

BYTE LISTINGS SUPPLEMENT 259

- 3

(Internal poge reference for manual.doc)

* the highest order derivative of each dependent variable

is given explicitly on the left hand side of an equation, whose right hand side has a finite sequence of +, — *

/•**• Exp - SIN. COS. TAN. SINH. COSH, TANH, ALOG, ACOS, ASIN, ATAN, or any function which is the solution to a differential equation.

- The known limitations of ATOMCC are:

* the derivatives may be of order at most 6, and

* there are at most 900 equations in the system.

- ATOMCC can also solve (with manual intervention):

* solutions which are polynomials,

* singular problems which require the application of I'HopitaI *s rule, or

* problems which have catastrophic subtractive errors in series generation.

- ATOMCC is most attractive for:—

* problems with stringent accuracy requirements,

* stiff problems,

* problems which must be solved repeatedly (such as parameter identification), or

* quick and easy problems (students* assignments).

The very high order and precise error control used by ATOMCC have enabled it to solve many problems which other methods were unable to solve.

- The ATOMCC compiIer a I Iows for the solution of ODE’s in the complex domain. This unique capability can be used to explore the structure of the singularities in the complex domain of non-linear problems. The analytic information about the location and order of singularities in the solution provides insight into the behavior of the system. This method has been used to map the first mathematical natural boundary discovered in the solution of a nonlinear dynamics problem (7).

- The complexity and execution time of ATSPGM depend on the number of functions and on the number of multiplications in the ODE system, not on the number of equations in the ODE system nor on the order of the derivatives involved. There is no penalty for high-order derivatives.

- As with all numerical methods, there is no substitute for insight into the structure of the ODE system and for the application of clever transformations.

260 BYTE LISTINGS SUPPLEMENT

- 4

(Internal page reference for manual.doc)

Solutions which are entire (have no singularities in the finite plane), should not be solved using the ATOMCC system. It is a total waste of computing power to solve linear problems using ATOMCC. This is particularly true for linear 'stiff 1 problems.

It can be EASILY show that ALL solutions that are entire can be solved in quasi-closed forms. This INCLUDES two-point boundary value problems!

Some special circumstances, which rarely occur, are identified either by ATOMCC or by the series analysis software, and an appropriate message is produced. In such cases, the user should examine the series (using MPRINT=10 in the third block), and seek the advice of the authors.

1.4 System Overview

1.4.1 The Translator, ATOMCC

The ATOMCC translator is an ODE-solving compiler written in FORTRAN. The ODE system to be solved is written into the ODEINP input file using conventions discussed in Chapters 2 and 3. The name ODEINP for the input file is fixed within ATOMCC; you must use this name. ATOMCC reads ODEINP and produces a FORTRAN object program, called ATSPGM. The name ATSPGM for the object program is also fixed; you must have a file by this name on your disc even if it is an empty file. The numerical solution to the ODE system is obtained by compiling and executing ATSPGM together with the library subroutine RDCV.OBJ or one of its variants.

ATOMCC accepts four blocks of data from ODEINP in which the user specifies the differential equations, the integration interval, initial conditions, and various other parameters to be used in the solution. The first block is used to specify the differential equations and commands to ATOMCC. The second through fourth blocks are used to insert statements directly into ATSPGM. The third block is required to specify the integration interval and the initial conditions. Detailed guidelines for the use of each block appear in Chapter 3.

1.4.2 Tha Object Program, ATSPGM

The ATSPGM object program implements the Taylor series algorithm for solving initial value problems in ordinary differential equations. This Taylor series algorithm is outlined be Iow.

- Initialize method control parameters which may be modified.

- Assign initial conditions, the integration interval, and method control parameters.

BYTE LISTINGS SUPPLEMENT 261

(Internal page reference for manual.doc)

- Initialize method control parameters which may not be modified.

- Loop for each integration step.

* Initialize the first few series terms.

* Generate the entire series.

* Call subroutine RDCV to determine the optimal stepsize from (a)the location and order of the primary singularities, fbHhe series length, (c)the error tolerance, and (d)adjust the stepsize.

* Call subroutine RSET to perform analytic continuation, and to print the solution.

In ATSPGM, the stepsize used to expand the series is related to the radius of convergence at each integration step. After a series Is generated, the location and order of the primary singularity are calculated. Then, the stepsize is adjusted to control the error in the following manner. The terms of the series for a function g(x) expanded at Xo with a stepsize of H :« X-Xo are stored as reduced derivatives, G(k+1) : = G(k) (Xo) H**k/kl. The stepsize H can be varied to control the error by multiplying G(k+1) by (HNEW/H)**k.

An exception is made In the solution of stiff problems. The step-size is determined in stiff problems by the length of a polynomial that can adequately represent the function.

A method which uses an infinite Taylor series is A-stable; however, in practice the series must be truncated to N terms.

Then, the characteristic polynomial is p(x,y) - x - Sum[y(k)/kI]. For example, the real-valued stability intervals are (-8.85,0), (-12.58,0), and (-16.29,0) for N ® 20, 30, and 40, respectively. Taylor series methods are best suited to solve problems with high accuracy. However, since very high order derivatives are used in these methods, the solution of stiff problems can be easily solved using the approximation of a polynomial with an exponential.

1.5 Purpose of the User Manual

This ATOMCC User Manual is designed to support easy, and efficient use of the ATOMCC system. Chapter 2 may be used as a tutorial; the rest of this User Manual is written as a reference manual, not as a tutorial, so information is repeated as appropriate when it applies to different issues.

Chapter 1 presents an overview of the ATOMCC system to help you understand how Its components fit together. This information is helpful to using the system as described in the rest of the manual. A more detailed discussion can be found in references (3) and (5).

262 BYTE LISTINGS SUPPLEMENT

- 6

(Internal page reference for manual.doc)

Chapter 2 is written as a tutorial for new users of the ATOMCC system. Its purpose is to show you how to use the ATOMCC system to solve initial value problems in ODE’s. It assumes that you are familiar with FORTRAN programming, and with the concept of computing a solution to a system of ODE’s. It gives examples showing how to solve some specific differential equations.

Chapter 3 is written for users who already have some experience using the ATOMCC system. This chapter is the heart of this User Manual. It attempts to show you how to use each of the features available from the ATOMCC translator and from the ATSPGM object program. It is organized for reference, not for sequential reading.

1.6 Acknowledgements

The author would like to express his gratitude to Roy Morris for the initial design and coding of the translator program, to students John Fouss, David Lowery, and Manuel Prieto for their work on series analysis, to Ray Moore, Mike Tabor, John Weiss, Mike Ziegler, Phil Bender, and others for many helpful suggestions, and to Jon Wright for the many suggestions which arose from his extensive use of the ATOMCC system. He Is particularly indebted to Professor George Corliss, who assisted him in every aspect of this program.

1.7 References

Here we include some references which are relevant to the ATOMCC system. A more complete list of references appears in refernce(5).

1. D. Barton, I. M. WMIers, and R. V. M. Zahar, The automatic solution of ordinary differential equations by the method of

- Taylor series, Comput. J., v. 14, 1971, pp. 243-248.

2. Y. F. Chang, Automatic solution of differential equations, in Constructive and Computational Methods for Differential and Integral Equations, edited by D. L. Colton and R. P. Gilbert, Lecture Notes in Math., vol. 430, Springer-VerIag, New York, 1974, pp. 61-94.

3. Y. F. Chang and G. F. Corliss, Compiler for the solution of ordinary differential equations using Taylor series,

Marquette University technical report, 1981.

4. Y. F. Chang and G. F. Corliss, Ratio-like and recurrence relation tests for convergence of series, J. Inst. Math.

AppI., v. 25, 1980, pp. 349-359.

BYTE LISTINGS SUPPLEMENT 263

5.

6 .

7.

8 .

9.

(Internal page reference for manual.doc)

Computing, Univ.r.lty ol Monitob" Slis 'S'"^" 5 " d

»o^ t ?5 <, :?;uSiuJ.“:;-,i!; «»«*.

85A (1981). pp. 211-213 * SyStem > Ph y*- Lett.

** - -•

LL c ::;,;:r;or.ofco E -r ! rv •w* ,or u > [ ° r

3. 1977. pp. 251-256 9 ’ J> Comput - AppI. Moth.. v .

’ e ' Pr *ntlc«-HOI I , E „g,.« 00 g

HSS;,r

264 BYTE LISTINGS SUPPLEMENT

r

April

- 8

(Internal page reference for manual.doc)

Chapter 2 For New Users

This Chapter is written for new users of the ATOMCC system. Its purpose is to show how to use this system to solve initial value problems in ordinary differential equations. Here, we give some specific examples of how to solve a system of differential equations. More detailed explanations are found in Chapter 3.

2.1 Task of the ATOMCC Translator

The ATOMCC system is a tool to help you solve differential equations. It consists of two major components:- a translator program (ATOMCC.EXE), and a subroutine object library (RDCV, DRDCV, CRDCV, CDRDCV). To understand the operation of these two components, you must first understand the six steps involved in using the system. We discuss the purpose of each step briefly, to acquaint you with the terms used in the detailed discussion in Section 2.2.

At Step 1 (edit ODEINP), the system of differential equations are stated in the form which ATOMCC expects. The input file ODEINP contains four separate blocks. (The name ODEINP is fixed within ATOMCC; so you must use this name.) The first block contains the differential and algebraic equations. ATOMCC compiler processes the data in this block to produce a FORTRAN object program ATSPGM which is then compiled and executed to solve the problem. (The name ATSPGM is also fixed within ATOMCC.) The second, third, and fourth blocks are copied unchanged from ODEINP to predetermined locations In ATSPGM.

At Step 2 (run ATOMCC), ATOMCC (a)reads the first block from ODEINP, (b)analyzes the differential equations, and (c)copies the second, third, and fourth blocks from ODEINP directly into ATSPGM at locations shown by examples below.

At Step 3 (compile ATSPGM), the ATSPGM program is compiled using Microsoft-FORTRAN ver 3.30 compiler.

At step 4 (link ATSPGM k RDCV), ATSPGM.OBJ is linked with the ATOMCC subroutine library RDCV.OBJ and FORTRAN.LIB to produce an executable module, ATSPGM.EXE.

The recommended manner to supply the initial conditions, the interval of integration, and control parameters is to read them

BYTE LISTINGS SUPPLEMENT 265

- 9

(Internal page reference for manual.doc)

from a data file which you prepare at Step 5. The format of this data file Is completely under your control, as shown by examples below. Step 5 may be done at any time before Step 6, and it may be omitted completely.

At Step 6 (run ATSPGM), the differential equations are solved. Each component of the equations is expanded in a Taylor series, and the solution point is moved forward by analytic continuation.

ATSPGM reads the data file prepared at Step 5 and writes the solution results. The exact content, format, and location of the solution results depend on the data in ODEINP prepared at Step 1. Examples given below and in Chapter 3 show how this is done.

+-+

I Step 1 I

I edit ODEINP I

+-+

I

+-+

I Step 2 I

I run ATOMCC.EXE I

+-+

I

+-+

I Step 3 I

I compile ATSPGM I

+-+

I

I <

I

+-+

I Step 4 I

I I ink ATSPGM & RDCV I

--+

I

I <

I

+-+

I Step 6 I

I run ATSPGM.EXE I

+-+

+- +

I (RDCV.OBJ) I

+ - +

I

+- +

I Step 5 I

I prepare data I

+-+

I

Steps for using the ATOMCC system

2.2 Using the ATOMCC system

In this section, we take you step-by-step through an example using the ATOMCC system.

266 BYTE LISTINGS SUPPLEMENT

- 10

(Internal page reference for manual.doc)

2.2.1 Step 1 - edit ODEINP

The input file ODEINP specifies for ATOMCC

1 . the system of differential equations to be solved,

2 . how the initial conditions and the interval of integration are communicated to ATSPGM, and

3. the commands to control the operation of ATOMCC or to control the execution of ATSPGM.

The statements in ODEINP follows FORTRAN conventions. A "C" in column 1 denotes a COMMENT, columns 1-5 are used for label numbers, column 6 is used for continuation, columns 7-72 contain statements, and columns 73-80 are ignored. The statements in ODEINP may be in either upper-case or lower-case letters. In our discussions in this Manual, we use upper-case letters for emphasis. (One word of caution:- ATOMCC does not recognize tabs.)

Example 2-1. Simple ODEINP file.

C FIRST PAINLEVE TRANSCENDENT

DIFF(Y,T,2) » 6.0*Y*Y + T $

$

C READ INTEGRATION INTERVAL AND INITIAL CONDITIONS.

READ(5,1010) START,END,Y(1),Y(2)

1010 FORMAT(4F10.3)

WRITER, 1020) START,END,Y(1),Y(2)

1020 FORMAT(* SOLVE THE FIRST PAINLEVE TRANSCENDENT* /

+ * INTERVAL: *,2F10.3 /

+ * INITIAL CONDITIONS:*,2F10.3 /) $

$

ODEINP must contain four blocks. Each block must terminate with the block terminator "$" in columns 7-72. Blocks 2 and 4 are empty in Example 2-1 above.

The first block contains the system of differential equations. These equations are processed by ATOMCC to determine the recurrence relations that are written into ATSPGM to generate the Taylor series for each component of the solution. To enter the differential equations, DIFF(Y,X,N) is used to denote the N-th derivative of Y with respect to X. The value of N may range from 1 to 6, inclusively. The DIFF(,,) function is used to specify the system of ODE‘s with FORTRAN-1 ike statements using standard FORTRAN operators and functions.

Rarely, ATOMCC may fail to produce the correct ATSPGM for your problem. In such a case, write your equations differently using many auxiliary variables. This will allow you to solve your problem; then, send a copy of the ODEINP that caused the problem to Y. F. Chang, Claremont McKenna College, Claremont, CA, 91711.

BYTE LISTINGS SUPPLEMENT 267

- 11

(Internal page reference for manual.doc)

The first block can also be used to control the operation of ATOMCC. The most commonly used option Is for ATOMCC to write ATSPGM in double-precision with a "COPTION DOUBLE" card at the beginning of block 1 .

Example 2-2. Double precision ATSPGM.

COPTION DOUBLE C

C FIRST PAINLEVE TRANSCENDENT

DIFF(Y,T,2) = 6.0*Y*Y + T $

$

C READ INTEGRATION INTERVAL AND INITIAL CONDITIONS.

READ(5, 1010 ) START,END.Y(1),Y(2)

1010 FORMAT(4F10.3)

WRITE(*,1020) START,END,Y(1),Y(2)

1020 FORMAT(' SOLVE THE FIRST PAINLEVE TRANSCENDENT’ /

+ ’ INTERVAL: *.2F10.3 /

+ ’ INITIAL CONDITIONS:\2F10.3 /) $

The second block is usually empty. It is used to insert non-executobIe FORTRAN statements at the beginning of ATSPGM, such as a SUBROUTINE card, a DIMENSION card, a COMMON card, etc.

The second, third, and fourth blocks are not processed syntactically by ATOMCC: they are copied directly from ODEINP into ATSPGM. Example 2-3 is the ATSPGM program written by ATOMCC for the ODEINP file shown in Example 2—1. Notice where block 3 is copied into an early part of ATSPGM.

Example 2-3. ATSPGM for Example 2-1.

c*+*+*+*+*+*

c This program was produced by the ATOMCC translator version 7.10 c Copyright (C) 1985, Y. F. Chang

c #+*+*+*+*+*+*+* + * + * + * + # + * + » + # + * + * + » + * + * + » + * + * + * + * +++<1+ , + , + * +#+<t+#+#+#+ c Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved, c This program was written for the following inputs c

C FIRST PAINLEVE TRANSCENDENT C DIFF(Y,T,2) = 6.0*Y*Y + T

c no instructions in second input block

COMMON /IPASS/ LENSER,LENVAR,MPRINT,MSTIFF,LRUN,

+ KTRDCV,KNTSTP,KTSTIF,KXPNUM,KDIGS,KENDFG,NTERMS,NOPT A /RPASS/ RADIUS,ERRLIM,ADJSTF,RCREAL,RCIMAG,RDCERR B /CPASS/ START.END,ORDER C /DPASS/ H,HNEW,XPRINT,DLTXPT DIMENSION TMPS( 36, 1)

CHARACTER *6 NAMES EQUIVALENCE (TMPS(1. 1 ),Y( 1 ))

DIMENSION NAMES(1), Y(36). T(2), TMPAAB(30), TMPAAA(30)

DATA NAMES(1 )/’Y.’/

Y(33) =1.1

10 FORMAT(72H ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang; S

268 BYTE LISTINGS SUPPLEMENT

- 12

(Internal page reference for manual.doc)

Aolution results./9H ******)

11 FORMAT(/5X,1IHStep number,16,13H at the point.1P1E12.4/1X,

A 9Hva!ues of )

12 FORMAT(IX, A6,(IX,1P4E13. 5))

13 FORMAT(5X,21HStepsize adjusted to ,1PE13.5)

14 FORMAT(/5X,35HThe solution stopped normally after, I4,24H steps as a set by nsteps. )

16 FORMAT(/5X,63HThe adjustment for stepsize seems to be in a loop. P Alease try a /5X,22Hshorter series length. )

WRITE(*,10)

c Initialize variables to default values.

NSTEPS = 40 H = 1.E0 ERRLIM = 1.E- 6 LENSER = 30 MPRINT = 4 NTERMS * 2 KTRDCV * 1

ADJSTF = 1.E-2 MSTIFF = 0

DLTXPT = 0.E0

c start of third input block

C READ INTEGRATION INTERVAL AND INITIAL CONDITIONS. READ(5,1010) START,END,Y(1),Y(2)

1010 FORMAT(4F10.3)

WRITE(*,1020) START,END,Y(1),Y(2)

1020 FORMAT(* SOLVE THE FIRST PAINLEVE TRANSCENDENT’ / + • INTERVAL: \2F10.3 /

+ * INITIAL CONDITIONS:*,2F10.3 /)

c end of third input block

c More initia Iizations

DLTXPT «= SIGN(DLTXPT, (END-START))

H = SIGN(H,(END-START))

KDIGS = 6

XPRINT - START + DLTXPT

KXPNUM « 35

LENVAR = 36

LRUN = 1

KTSTIF «= 0

NUMEQS - 1

IF(LENSER.GT.(LENVAR- 6)) LENSER = LENVAR - 6

IF(MPRINT.LT.2) GO TO 17 WRITE(*,11) KTSTIF,START K = Y(33)

WRITE(*,12) NAMES(K),Y(1), Y(2)

c Loop for integration steps. Inside the loop, print the desired output

17 DO 27 KINTS-1,NSTEPS KOUNT - 0 KNTSTP - KINTS

BYTE LISTINGS SUPPLEMENT 269

- 13

(Internal page reference for monual.doc)

19 CONTINUE

T(1) = START T(2) = H Y(2) = Y(2)*(H)

c Preliminary series calculations

TMPAAA(I) = 6.E0*Y(1)

TMPAAB(I) = TMPAAA(1)*Y(1)

Y(3) - (TMPAAB(I) + T(1))*(H*H/2.E0) TMPAAA(2) = 6.E0*Y(2)

TMPAAB(2) = TMPAAA(1)*Y(2) + TMPAAA(2)*Y(1) Y(4) = (TMPAAB(2) + T(2))*(H*H/6.E0)

c Loop for series calculations

DO 23 K- 5.LENSER KA - K - 1 KB as K — 2

TMPAAA(KB) « 6.E0*Y(KB)

TMPAAB(KB) = 0.E0 KZ = 1 + KB DO 30 N=1, KB L = KZ - N

TMPAAB(KB) = TMPAAB(KB) + TMPAAA(N)*Y(L) 30 CONTINUE

Y(K) - (TMPAAB(KB))*(H*H/(KB*KA))

c Test and adjust H to avoid over/under flow.

IF(MSTIFF.GE.20 .AND. KTSTIF.GT.0) GO TO 23 TMP - ABS(Y(K))

IF(TMP.LE.1.E-35) GO TO 23

IF(TMP.LT.1.E20 .AND. TMP.GT.1.E-20) GO TO 23 IF(KTSTIF.NE.0 .AND. TMP.LT.1.0) GO TO 23 KOUNT = KOUNT + 1 IF(KOUNT.LT.9) GO TO 22 WRITE(*,16)

GO TO 28

22 CONTINUE

Y(2) - Y(2)/(H)

H = H * TMP**(0.3/(1—K))

IF(MPRINT.GE.4) WRITE(*.13) H GO TO 19

23 LRUN - 1

c Calculate radius of convergence and take optimum step.

CALL RDCV(TMPS.LENVAR,NUMEQS.NAMES) 24 CALL RSET(TMPS,LENVAR.NUMEQS.NAMES)

c no instructions in fourth input block

25 GO TO (26,28,24), KENDFG

26 H = SIGN(RADIUS.H)

START = START + HNEW

IF(MPRINT.LT.4) GO TO 27 WRITE(*.11) KNTSTP, START

270 BYTE LISTINGS SUPPLEMENT

(Internal page reference for manual.doc)

K = Y(33)

WRITE(*,12) NAMES(K),Y(1), Y(2)

27 CONTINUE WRITE(*,14) NSTEPS

28 CONTINUE

29 STOP END

The third block is usually used to specify the interval of integration and the initial conditions by reading them from a data file prepared at Step 5. This is the file DATA opened in block 3. The interval of integration is from START to END. END is allowed to be less than START for integration in a negative direction. The initial values (at START) of a dependent variable named y and its derivatives are assigned to the array Y as follows:—

Y(1) denotes y at START,

Y(2) denotes y* at START,

Y(3) denotes y'* at START, etc.

Thus in Example 2-1, two initial conditions Y(1) for y(0) and Y(2) for y*(0) are entered for the second order differential equation.

Any valid FORTRAN statement may be included in block 3 to be copied into ATSPGM, as shown in Example 2-1 by the WRITE statement to echo the input. The third block may also be used to change the default values of method-controlling variables. You can see in Example 2-3 that many variables are initialized immediately before block 3. The meaning of these variables is described in Chapter 3.

The fourth block is usually empty. It may be used to insert statements into ATSPGM at the end of each integration step.

This concludes the discussion of how to prepare the input file. More information about the use of specific features can be found in Chapter 3.

2.2.2 Step 2 - Run ATOMCC

The appropriate command to execute the ATOMCC compiler is simply [ATOMCC]. The ATOMCC translator uses two files:- ODEINP for the equation statements and initial conditions, and ATSPGM for the output object program. (The names ODEINP and ATSPGM are fixed within ATOMCC.) The messages produced by ATOMCC are placed on your terminal. To have the messages written onto a disc file (say MSG), use the command [ATOMCC > MSG],

BYTE LISTINGS SUPPLEMENT 271

April

272

(Internal

- 15

page reference for manual.doc)

Example 2-4. Translator messages for Example 2-1.

ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang.

Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved.

FIRST PAINLEVE TRANSCENDENT

DIFF(Y,T,2) = 6.0*Y*Y + T $ equation 1 is in position 1 $

READ INTEGRATION INTERVAL AND INITIAL CONDITIONS.

READ(5,1010) START,END.Y(1),Y(2)

1010 F0RMAT(4F10.3)

WRITE(*,1020) START,END,Y(1).Y(2)

1020 FORMAT(’ SOLVE THE FIRST PAINLEVE TRANSCENDENT' /

+ ' INTERVAL: '.2F10.3 /

+ ' INITIAL CONDITIONS:',2F10.3 /) $

$

ATOMCC completed Stop - Program terminated.

2.2.3 Step 3 and 4 - Compile and link ATSPGM

As you get comfortable with the ATOMCC system, you will rarely inspect ATSPGM, unless either an error occurs, or you choose to edit ATSPGM by hand.

ATSPGM. written by ATOMCC. is just like any other FORTRAN program; you may edit it to suit your needs. Whether edited or not, ATSPGM is ready to be compiled and linked with the necessary subroutines from the ATOMCC library (RDCV).

The appropriate commands to compile and link ATSPGM ore:

- B:F0R1 ATSPGM. ;

- B:PAS2

- B:LINK ATSPGM+RDCV,.NUL,B:

2.2.4 Step 5 - Prepare the data

At Step 1. when you prepared ODEINP for ATOMCC. you may have included some READ statements in block 3 to communicate the interval of integration and the initial conditions to ATSPGM.

Before you run ATSPGM, the data file to be read by those statements must be prepared with the appropriate file name given in your OPEN statement.

BYTE LISTINGS SUPPLEMENT

- 16

(Internal page reference for manual.doc)

Example 2-5. Data file for Example 2-1.

0.000 1.100 1.000 0.000

If you know that you will be solving a simple problem only once, Step 5 can be eliminated by stating the values of START, END, and the initial conditions with FORTRAN assignment statements in block 3 as shown below.

Example 2-6. Assignment statements in block 3.

C First Painleve transcendent

DIFF(Y,T,2) = 6.0*Y*Y + T $

$

C Assign integration interval and initial conditions. START =0.0 END = 1.1 Y(1) = 1.0 Y(2) = 0.0

WRITE(*.1020) START,END,Y(1),Y(2)

1020 FORMAT(* Solve the first Painleve transcendent* / + * IntervaI: *,2F10.3 /

+ * Initial conditions:*,2F10.3 /) $

$

2.2.5 Step 6 - Run ATSPGM

At step 6 , you are ready to run ATSPGM; the command is simply [ATSPGM]. ATSPGM writes its output to your terminal, for solution output on a disc file (say PRTOUT) use [ATSPGM > PRTOUT].

Example 2-7. Solution Output for Example 2-1.

ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang; Solution results. * * * * * *

SOLVE THE FIRST PAINLEVE TRANSCENDENT INTERVAL: .000 1.100

INITIAL CONDITIONS: 1.000 .000

Step number 0 ot the point .0000E+00 values of

Y . 1.00000E+00 .00000E+00

Step number 1 at the point 7.1000E-01 values of

Y . 4.04877E+00 1.62701E+01

BYTE LISTINGS SUPPLEMENT 27J

(Internal

- 17 page reference

for manual.doc)

Step number 2 at the point 1.0100E+00 values of

Y . 2.58324E+01 2.62656E+02

Step number 3 at the point 1.1000E+00 values of

Y . 8.77693E+01 1.64459E+03

Stop - Program terminated.

2.3 Output at equally spaced points

You should be able to use ATOMCC to solve routine problems.

The points at which ATSPGM computes the solutions are determined by the actual integration steps taken, which are not uniform in size. This Section shows you how to force ATSPGM to print the solutions at equally spaced points.

The output from ATSPGM is controlled by two variables, MPRINT (amount of print), and DLTXPT (print interval). To produce output at equally spaced points, assign MPRINT=2 to turn off the print at the actual integration steps, and assign DLTXPT*DELTA, where DELTA is your desired print interval.

Example 2-8. Equally spaced output points.

c First Painleve transcendent

DIFF(Y,T,2) = 6.0*Y*Y + T $

$

c Assign integration interval and initial conditions. MPRINT = 2 DLTXPT * 0.2 START =0.0 END = 1.1 Y(1) = 1.0 Y(2) = 0.0

WRITER, 1020) START,END,Y(1),Y(2)

1020 FORMAT(* Solve the first Painleve transcendent* / + * Interval: *.2F10.3 /

+ * Initial conditions:*,2F10.3 /) $

$

2.3.1 ZEROT - Stopping at roots of variables

It is often of interest to locate points at which a component of the solution has a root or assumes some specified value. The subroutine ZEROT automatically solve such problems. DZEROT is the double-precision version.

274 BYTE LISTINGS SUPPLEMENT

- 18

(Internal page reference for manual.doc)

The form of the CALL is

CALL ZEROT(NUMBER,Y,ROOT,KEY,TMPS,LENVAR,NUMEQS)

where

NUMBER is the index of the Y series term whose root is sought,

Y is the variable whose root is desired,

ROOT is the value Y is to assume (= 0 for a root),

KEY is 1 if Y is a dependent variable, or

0 if Y is not a dependent variable.

The arguements TMPS, LENVAR, and NUMEQS must be exactly as written above.

Example 3-16. Rootfinding with ZEROT.

DIFF(Y,T,2) = 6*Y*Y + T $

$

START =0.0 END =1.15 ROOT =20.0

$

CALL ZEROT(1,Y,ROOT,1)

When the variable whose root is being sought is not a dependent variable, KEY is set to 0.

CALL ZER0T(2,VARY,0.0,0)

IF(LRUN.NE.0) GO TO 25 TEMP = START + HNEW

WRITE(7,1010) KINTS,TEMP,VARY(1),VARY(2)

1010 FORMAT(15,3F10.4)

GO TO 25 $

In these examples, it is not necessary for one to print the information as shown in the second case. The ATSPGM program does stop and restart the solution automatically at the exact root and the output is controlled by MPRINT.

The index NUMBER can be set at any positive (non-zero) integer value; however, obviously when NUMBER is very large the accuracy of the root wiI I suffer.

2.3.2 MSTIFF=20,21,22 - Stiff problems.

This version of ATOMCC contains a double-precision algorithm to solve stiff problems. To use It, one can either set MSTIFF=20, or 21, or 22. Other parameters that should be controlled are H,

ADJSTF, and NSTEPS. It is also desirable to set MPRINT to 7, at least initially, for observing the progress of the solution. If it should be evident that the problem is not really stiff, then it is most advisable to solve it as a normal problem.

BYTE LISTINGS SUPPLEMENT 275

- 19

(Internal page reference for manual.doc)

MSTIFF-20 is the more conservative of the three algorithms. In this case, LENSER is set to be 15. The default value for ADJSTF, the error-controI Iing parameter, is a rather large 1.E-2. The user should run the stiff solution at least one more time with a somewhat smaller ADJSTF, say 1.E-3, to check on its validity.

When MSTIFF-21. LENSER is set to only 10. So, this option should be used only if the user is absolutely certain that the problem under study is very stiff. The solution of stiff problems under this option is considerably faster than that for MSTIFF-20.

MSTIFF-22 is identical to MSTIFF-20 except for the fact that there is no attempt to identify steady-state solutions.

As mentioned above, the stiff precision. It is simply not cost using single-precision. There is problems. All such problems must

a Igorithm effective one other be stated

is written in doubleto solve such problems restriction on stiff as first-degree ODE’s.

276 BYTE LISTINGS SUPPLEMENT

(Interna I

- 20

page reference for manual.doc)

Chapter 3 How to Use

This Chapter is written for users who already have solved several problems using the ATOMCC system. It assumes familiarity with FORTRAN programming, with Chapter 2, and with the numerical solution of ODE’s. This Chapter is the heart of this User Manual. It attempts to show how to use each of the features available from ATOMCC and from ATSPGM. It is organized for reference, not for sequential reading. Consequently, some information found in other parts of this Manual are repeated here.

3.1 Solving your problem

The tasks which must be accomplished In order to run the ATOMCC system on your computer were discussed in Section 2.2. They are:

Edlt ODEINP (containing ODE’s)

Run ATOMCC.EXE (execute ATOMCC translator)

(This creates ATSPGM, the object FORTRAN program, which is treated like any FORTRAN program.

ATSPGM may be edited.)

Compile ATSPGM.

(This creates ATSPGM.OBJ, the object module.)

Link

ATSPGM.OBJ, with library (RDCV.OBJ DRDCV.OBJ CRDCV.OBJ CDRDCV.OBJ (This creates ATSPGM.EXE,

opt ions

for single precision for double precision for complex, and for complex double) the execution module.)

Edit DATA input-file if any is used.

Run ATSPGM.EXE

3.1.1 Translator file, ODEINP

The ODEINP file contains the ODE’s to be solved and information specifying how the initial conditions and the integration interval are determined in ATSPGM. It may contain commands to control (a)the operation of the ATOMCC translator, (b)the execution of the

BYTE LISTINGS SUPPLEMENT 277

(Internal page reference for manual.doc)

solution, and (c)the desired format of the output. The names ODEINP and ATSPGM are fixed within ATOMCC; you must have these files on your disc when you execute ATOMCC.

The data in ODEINP follows FORTRAN conventions. Columns 1-5 are used for line numbers, column 6 Is used for continuation characters, columns 7-72 contain statements, and columns 73-80 are ignored. As in FORTRAN, all blanks are ignored. A *C* in column 1 denotes a comment which is copied directly into the ATSPGM file.

The statements in ODEINP can be either upper-case or lower-case letters. We use upper-case in this manual for emphasis. (A word of caution, the tab character is not recognized by ATOMCC.)

The ODEINP file contains four blocks. Each block ends with the block terminator symbol ’$’ in columns 7-72. (A comment card must not contain a block terminator *$'.) Sections 3.2-3.4 discuss each of the blocks in detail. Here is an example of an input file which illustrates several of the features which will be discussed in Sections 3.2-3.5.

Example 3-1. ODEINP file.

C Block 1 C

C System with parameter.

C

DIFF(X,T,2) * - ALPHA*X*R DIFF(Y,T,2) = - ALPHA*Y*R R = (x*X + Y*Y)**(-1.5)

ALPHA =0.65 $

c

c Block 2 c

CHARACTER+80 LINE $

c

c Block 3 c

c Read:- heading line, print code, maximum number of integration c steps,

c Echo the above.

c Read:- heading line, integration interval, print interval, c parameter in equations, initial conditions,

c Echo the above, c

0PEN(5,FILE= , DATA’)

OPEN(7,FILE=•PLOTS’,STATUS-’NEW *)

READ(5,1010) LINE,MPRINT.NSTEPS 1010 FORMAT(A80/2I10)

WRITER, 1010) LINE.MPRINT,NSTEPS

READ(5,1020) LINE,START,END,DLTXPT,ALPHA,X(1),X(2),Y(1),Y(2) 1020 FORMAT(A80/8F10.3)

WRITE(*,1020) LINE,START,END,DLTXPT,ALPHA.X(1),X(2),Y(1),Y(2) c Assignment statements for the error control parameter ERRLIM = 1.0E-04 $

278 BYTE LISTINGS SUPPLEMENT

, - 22

(Internal page reference for manual.doc)

c

c Block 4 c

c Produce file of data for plotting, c

IF(KENDFG.EQ.3) WRITE(7,1030) 1030 FORMAT(15,1P5E14.5) $

KINTS,XPRINT,X(1),X(2),Y(1),Y(2)

If you have a simple problem which will be solved only once, the contents of the 'DATA* file may be entered directly as data into block 3. However, the compilation and linking of the ATSPGM file takes an appreciable amount of time and therefore should be avoided on problems that is solved more than once.

There are two ways to solve a given problem containing functions. Either they can be placed as FORTRAN statements in ODEINP to be copied directly into ATSPGM, or they can be inserted by editing ATSPGM. The choice depends on your personal style; the authors prefer to work with ODEINP, because it is short.

Therefore, it is easy to find the correct place to make changes. The cost of re-running the ATOMCC translator is well worth the convenience, because ATOMCC is very fast.

3.1.2 Translator file, the terminal

The translator messages contains the information which the ATOMCC expects you to inspect. It includes an echo of the input file and any error messages. The Appendix contains a list of the error messages which may be produced. The messages will appear on your terminal.

Example 3-2. Translator messages for Example 3-1.

ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang. Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved.

c Block 1

c System with parameter.

DIFF(X,T,2) * - ALPHA*X*R DIFF(Y,T,2) = - ALPHA*Y*R R = (X*X + Y*Y)**(-1.5) ALPHA = 0.65 $

equation 3 is in position 1

equation 4 is in position 2

equation 1 is in position 3

equation 2 is in position 4

c Block 2

CHARACTERS© LINE $

BYTE LISTINGS SUPPLEMENT 279

(Internal page reference for manual.doc)

c Block 3

c Read:- heading line, print code, maximum number of integration c steps,

c Echo the above.

c Read:- heading line, Integration interval, print interval, c parameter in equations, Initial conditions,

c Echo the above.

0PEN(5.FILE-’DATA’)

OPEN(7,FILE= ’ PLOTS *,STATUS-’NEW *)

READ(5,1010) LINE,MPRINT,NSTEPS 1010 FORMAT(A80/2I10)

WRITE(*,1010) LINE,MPRINT,NSTEPS

READ(5,1020) LINE,START.END,DLTXPT,ALPHA,X(1),X(2),Y(1),Y(2)

1020 FORMAT(A80/8F10.3)

WRITE(*,1020) LINE.START,END,DLTXPT,ALPHA,X(1),X(2),Y(1),Y(2) c Assignment statements for the error control parameter ERRLIM = 1.0E-04 $

c Block 4

c Produce file of data for plotting.

IF(KENDFG.EQ.3) WRITE(7.1030)KINTS.XPRINT,X(31),X(32).Y(31),Y(32) 1030 F0RMAT(I5,1P5E14.5) $

ATOMCC completed Stop - Program terminated.

3.1.3 Translator file, ATSPGM

The ATSPGM file contains the FORTRAN object program written by ATOMCC to solve the system of differential equations using long Taylor series. ATOMCC uses the variable names given in ODEINP, so that ATSPGM appears to have been custom written for the specific problem. Usually you do not need to inspect ATSPGM, but sometimes you may find it necessary to edit it like you would edit any other FORTRAN program to achieve some particular result. Section 3.6 contains an example for which editing of ATSPGM is necessary.

Example 3-3. ATSPGM for Example 3-1.

c*+*+*+*+*+*

c This program was produced by the ATOMCC translator version 7.10 c Copyright (C) 1985, Y. F. Chang

c*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ c Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved, c This program was written for the following inputs c

C BLOCK 1

C SYSTEM WITH PARAMETER.

C DIFF(X,T,2) = - ALPHA*X*R

C DIFF(Y,T,2) = - ALPHA*Y*R

C R = (X*X + Y*Y)**(-1.5)

C ALPHA =0.65

c

280 BYTE LISTINGS SUPPLEMENT

(Interna I

- 24

page reference for manual.doc)

c start of second input block

c Block 2 c

CHARACTER*80 LINE

c end of second input block

COMMON /IPASS/ LENSER,LENVAR,MPRINT,MSTIFF,LRUN,

+ KTRDCV,KNTSTP,KTSTIF,KXPNUM,KDIGS,KENDFG,NTERMS,NOPT A /RPASS/ RADIUS,ERRLIM,ADJSTF,RCREAL,RCIMAG,RDCERR B /CPASS/ START,END,ORDER C /DPASS/ H,HNEW,XPRINT,DLTXPT DIMENSION TMPS( 36, 2)

CHARACTER*6 NAMES

EQUIVALENCE (TMPS(1,1),X(1)),(TMPS(1.2),Y(1))

DIMENSION NAMES(2), T(2), Y(36), X(36), R(30). TMPAAH(30),

A TMPAAG(30), TMPAAF(30), TMPAAE(30), TMPAAD(30), TMPAAC(30),

B TMPAAB(30)

DATA NAMES(1 )/*X.7

DATA NAMES(2)/* Y.•/

X(33) =1.1 Y(33) = 2.1

10 FORMAT(72H ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang; S

Aolution results./9H ******)

11 FORMAT(/5X,11HStep number,16,13H at the point,1P1E12.4/1X,

A 9Hvalues of )

12 FORMAT(IX, A6,(IX,1P4E13. 5))

13 FORMAT(5X,21HStepsize adjusted to .1PE13.5)

14 F0RMAT(/5X,35HThe solution stopped normally after, I4.24H steps as a set by nsteps. )

16 F0RMAT(/5X,63HThe adjustment for stepsize seems to be in a loop. P Alease try a /5X,22Hshorter series length. )

WRITE(*,10)

c Initialize variables to default values.

NSTEPS = 40 H = 1.E0 ERRLIM = 1.E- 6 LENSER = 30 MPRINT = 4 NTERMS = 2 KTRDCV = 2

ADJSTF « 1.E-2 MSTIFF = 0

DLTXPT = 0.E0

c constant expressions

ALPHA = 6.5E-1

c start of third input block

c Block 3

BYTE LISTINGS SUPPLEMENT 281

(Internal page reference for monual.doc)

c Read:- heading line, print code, maximum number of integration c steps,

c Echo the above.

c Read:- heading line, integration interval, print interval, c parameter in equations, initial conditions,

c Echo the above, c

OPEN(5,FILE*’DATA’)

0PEN(7,FILE-’PLOTS *,STATUS®* NEW 1 )

READ(5,1010) LINE,MPRINT,NSTEPS 1010 FORMAT(A80/2I10)

WRITE(*,1010) LINE.MPRINT.NSTEPS

READ(5,1020) LINE,START,END,DLTXPT,ALPHA,X(1),X(2),Y(1),Y(2)

1020 FORMAT(A80/8F10.3)

WRITE(*,1020) LINE,START,END,DLTXPT,ALPHA,X(1),X(2),Y(1),Y(2) c Assignment statements for the error control parameter ERRLIM = 1.0E-04 c

c end of third input block

c

TMPAAA = -1.5E0 c

c constant expressions c

c More initializations c

DLTXPT = SIGN(DLTXPT,(END-START))

H = SIGN(H,(END-START))

KDIGS = 6

XPRINT » START + DLTXPT

KXPNUM = 35

LENVAR = 36

LRUN - 1

KTSTIF - 0

NUMEQS - 2

IF(LENSER.GT.(LENVAR- 6)) LENSER « LENVAR - 6

IF(MPRINT.LT.2) GO TO 17 WRITE(*,11) KTSTIF,START K = X(33)

WRITE(*,12) NAMES(K),X(1), X(2)

K = Y(33)

WRITE(*,12) NAMES(K),Y(1), Y(2)

c

c Loop for integration steps. Inside the loop, print the desired output

17 DO 27 KINTS=1,NSTEPS KOUNT = 0 KNTSTP = KINTS 19 CONTINUE

T(1) = START T(2) = H

c Preliminary series calculations c

TMPAAB(I) = X(1)*X(1) TMPAAC(1) = Y(1)*Y(1)

282 BYTE LISTINGS SUPPLEMENT

-26

(Internol poge reference for manual.doc)

TMPAAE(1) = AIPHA*X(1)

TMPAAG(1) = ALPHA*Y(1)

TMPAAD(l) = TMPAA8(1) + TMPAAC(l)

R(1) = TMPAAO(1) ** TMPAAA TMPAAF(1) = TMPAAE(1)*R(1)

TMPAAH(I) = TMPAAG(1)*R(1)

X(3) = (-TMPAAF(1))*(H*H/2.E0)

Y(3) = (-TMPAAH(1))*(H*H/2.E0)

TMPAAB(2) - X(1)*X(2) + X(2)*X(1)

TMPAAC(2j - Y(1)*Y(2) + Y(2)*Y(1)

TMPAAE(2) = ALPHA*X(2)

TMPAAG( 2) = ALPHA*Y(2)

TMPAAO(2) » TMPAAB(2) + TMPAAC(2)

R(2) = TMPAAA*R(1)*TMPAAD(2)/TMPAAD(1) TMPAAF(2) = TMPAAE(1)*R(2) + TMPAAE(2)*R(1) TMPAAH(2) = TMPAAG(1)*R(2) + TMPAAG(2)*R(1) X(4) = (-TMPAAF(2))*(H*H/6.E0)

Y(4) = (-TMPAAH(2))*(H*H/6.E0)

c Loop for series calculations

DO 23 K= 5.LENSER

KA = K - 1

KB = K - 2

KC = K - 3

TMPAAB(KB) - 0.E0 TMPAAC (KB) «= 0.E0 KZ = 1 + KB DO 30 N-1, KB L = KZ - N

TMPAAB(KB) « TMPAAB(KB) + X(N)*X(L) TMPAAC(KB) = TMPAAC(KB) + Y(N)*Y(L)

30 CONTINUE

TMPAAE(KB) = ALPHA*X(KB)

TMPAAG(KB) = ALPHA*Y(KB)

TMPAAD(KB) = TMPAAB(KB) + TMPAAC(KB)

R(KB) * R(1)*TMPAAD(KC+1)*(KC)*TMPAAA KY = 2 + KC DO 31 N-2, KC L = KY - N AL - (L - 1)

31 R(KB) « R(KB) + R(N)*TMPAAD(L)*AL A *TMPAAA - TMPAAD(N)*R(L)*AL

R(KB) = R(KB) /(KC)/TMPAAD(1)

TMPAAF(KB) « 0.E0 TMPAAH(KB) = 0.E0 KZ = 1 + KB DO 32 N-1, KB L = KZ - N

TMPAAF(KB) = TMPAAF(KB) + TMPAAE(N)*R(L) TMPAAH(KB) = TMPAAH(KB) + TMPAAG(N)*R(L)

32 CONTINUE

X(K) = (-TMPAAF(KB))*(H*H/(KB*KA))

Y(K) - (-TMPAAH(KB))*(H*H/(KB*KA))

c Test and adjust H to ovoid over/under flow.

IF(MSTIFF.GE.20 .AND. KTSTIF.GT.0) GO TO 23

BYTE LISTINGS SUPPLEMENT 283

284

(Interna I

- 27

page reference for manual.doc)

TMP - ABS(X(K))

IF(TMP.LE.1.E-35) GO TO 23

IF(tMP.LT.1.E20 .AND. TMP.GT.1.E-20) GO TO 23 IF(KTSTIF.NE.0 .AND. TMP.LT.1.0) GO TO 23 KOUNT « KOUNT + 1 IF(KOUNT.LT.9) GO TO 22 WRITE(*,16)

GO TO 28

22 CONTINUE

?ili: mj

H * H * TMP**(0.3/(1-K))

IF(MPRINT.GE.4) WRITE(*,13) H GO TO 19

23 LRUN = 1

c Calculate radius of convergence and take optimum step.

CALL RDCV(TMPS,LENVAR,NUMEQS,NAMES) 24 CALL RSET(TMPS,LENVAR,NUMEQS,NAMES)

c start of fourth input block

c Block 4 c

c Produce file of data for plotting, c

IF(KENDFG.EQ.3) WRITE(7,1030)KINTS,XPRINT,X(31),X(32),Y(31),Y(32) 1030 FORMAT(15,1P5E14.5)

c end of fourth input block

25 GO TO (26,28,24), KENDFG

26 H - SIGN(RADIUS.H)

START * START + HNEW

IF(MPRINT.LT.4) GO TO 27 WRITEf*,11) KNTSTP, START K = X(33)

WRITE(*,12) NAMES(K),X(1), X(2) K = Y(33)

WRITE(*,12) NAMES(K),Y(1), Y(2)

27 CONTINUE WRITE(*,14) NSTEPS

28 CONTINUE

29 STOP END

3.1.4 DATA input file

For most problems solved using the ATOMCC system, you should communicate the initial conditions, the integration interval, the coefficients in the differential equations, and the ATOMCC control parameters by reading them from a DATA input file.

BYTE LISTINGS SUPPLEMENT

- 28

(Internal page reference for manual.doc)

Example 3-4. DATA input file for Example 3-1.

MPRINT NSTEPS for example 3-1

4 80

START END DLTXPT ALPHA X(1) X(2) Y(1) Y(2)

1.0 10.0 0.25 0.58 -1.0 0.0 0.0 4.3

3.1.5 Solution file

ATSPGM writes all of Its messages and answers to your terminal. The format of the solution depends on the ATOMCC control parameters (see Section 3.4). If you should wish to have the solution written onto a disc file, you can use the execution statement (ATSPGM > PRTOUT). Then, all messages and answers will be written to the solution file PRTOUT. The solution file can also contain Informa- tion written by user supplied WRITE(*,xxx) statements. A portion of the solution file is given below.

Example 3-5. Solution file for Example 3-1.

ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chang; Solution results. ******

MPRINT NSTEPS for example 3-1

4 80

START END DLTXPT ALPHA X(1) X(2) Y(l) Y(2)

1.000 10.000 .250 .580 -1.000 .000 .000 4.300

Step number 0 at the point 1.0000E+00 values of

X. -1.00000E+00 .00000E+00

Y .00000E+00 4.30000E+00

Step number 1 at the point 1.1430E+00

values of

X. -9.94536E-01 7.08452E-02

Y . 6.13850E-01 4.27990E+00

Step number 2 at the point 1.2500E+00 values of

X. -9.85268E-01 9.92472E-02

Y . 1.07052E+00 4.25646E+00

Step number 2 at the point 1.3400E+00 values of

X. -9.75709E-01 1.11976E-01

Y . 1.45285E+00 4.24032E+00

Step number 3 at the point 1.5000E+00 values of

X. -9.56779E-01 1.23037E-01

Y . 2.12958E+00 4.22039E+00

BYTE LISTINGS SUPPLEMENT 285

- 29

(Internal page reference for monual.doc)

voiuel*of numb * r 3 ot th ® polnt

*. -9.39208E-01 1.27496E-01

Y . 2.71959E+00 4.20915E+00

voluerof nUmt><!,r 4 0t the P °' nt 1 - 75 00E+00

5. -9.25064E-01 1.29523E-01

Y . 3.18223E+00 4.20277E+00

vaIues*of nUmber 4 0t th * P °' nt 2 - 000( *+00 5. -8.92333E-01 1.31982E-01

Y . 4.23159E+00 4.19295E+00

values 6 ©/™"’ 6 ^ 4 0t th ® P ° int 2.1300E+00

*. -8.75128E-01 1.32677E-01

Y . 4.77644E+00 4.18942E+00

3.1.6 User files

stotemertts°to e produce'outDut*?n*o y f^ °7 n ? utput fll * s usln 9 WRITE

aaru~ ,,Jr: '“ s • '»• jas- g~ u

Example 3-6. User file for plotti

ng.

2

3

4

4

5

5

6 6 6 6 6 7

1.25000E+00 1.50000E+00 1.75000E+00 2.00000E+00 2.25000E+00 2.50000E+00 2.75000E+00 3.00000E+00 3.25000E+00 3.50000E+00 3.75000E+00 4.00000E+00

-9.85268E-01 -9.56779E-01 -9.25064E-01 -8.92333E-01 -8.59178E-01 -8.25810E-01 -7.92324E-01 -7.58765E-01 -7.25160E-01 -6.91524E-01 -6.57866E-01 -6.24192E-01

9.92472E-02 1.23037E-01 1.29523E-01 1.31982E-01 1.33133E-01 1.33750E-01 1.34112E-01 1.34340E-01 1.34490E-01 1.34594E-01 1.34667E-01 1.34720E-01

1.07052E+00 2.12958E+00 3.18223E+00 4.23159E+00 5.27900E+00 6.32514E+00 7.37039E+00 8.41497E+00 9.45904E+00 1.05027E+01 1.15461E+01 1.25891E+01

4.25646E+00 4.22039E+00 4.20277E+00 4.19295E+00 4.18678E+00 4.18258E+00 4.17953E+00 4.17723E+00 4.17542E+00 4.17398E+00 4.17279E+00 4.17179E+00

3.2 Using bIock 1

286 BYTE LISTINGS SUPPLEMENT

- 30

(Internal page reference for manual.doc)

The first block may also be used for ATOMCC options to control the operation of the translator. This Is done by placing a COPTION card at the beginning of ODEINP. Multiple translator options may be specified on the same line, i.e. COPTION DOUBLE, LENVAR=40. Multiple COPTION cards are also allowed, but they must precede all other cards.

3.2.1 Format for the system of equations

For the differential equations, DIFF(Y,X,N) is used to denote the n-th derivative of the dependent variable y with respect to the independent variable x. The value of the variable N may range from 1 to 6, inclusively. The DIFF(X,Y,N) function is used to specify ODE’s just as with other standard FORTRAN operators and functions. All functions supported by ATOMCC are listed in Section 4.2. The statements in ODEINP can be either upper- or lower-case letters.

We use upper-case in this manual for emphasis.

The input to ATOMCC follows FORTRAN conventions. Comment cards contain a *C’ In column 1. The entire comment card is reproduced in ATSPGM. A comment card must not contain a block terminator ’$*. Columns 1-5 are used to enter line numbers. Column 6 is used for continuation; there is a limit of 19 continuation lines in FORTRAN. Columns 7-72, where the block terminator ’$’ must appear, contain the statements of the equations. Columns 73-80 are ignored. As In FORTRAN, blanks are not significant. (A word of caution, the tab character is not recognized by ATOMCC.)

The equations In block 1 must be of the form

DIFF(X.Y.N) - expression, variable - DIFF(X.Y.N), or variable ■ expression.

An expression may contain operations on variables and DIFF(,,) functions. The highest order derivative of each dependent variable must be given explicitly by an equation of the form DIFF(,,) « expression, but DIFF(,,) functions of lower order may appear in expressions on the right hand side. A system of differential equations may be specified with more than one independent variable. But, each independent variable will have the same value as the solution is computed. Independent variables are implicitly defined by the DIFF(,,) function for that independent variable, so explicitly defining one in an assignment statement will cause an error message to be printed which indicates that the independent variable in question has already been defined.

Incidentally, ATOMCC transforms all constant Integer powers of a variable up to 4 into multiplications. This is done in order to avoid the problems raised by the initial value of that variable being equal to zero. For integer powers greater than 4, the user is responsible to see that a I’Hopital situation does not arise.

Except for integer powers, constant coefficients which appear in ODE’s are converted to real numbers by ATOMCC, so that it does not matter whether three Is written as 3, 3.0, 3.E0, or 3.D0.

BYTE LISTINGS SUPPLEMENT 287

(Interna I

- 31

page reference for manual.doc)

3.2.2 Parameters In the equations

Example 3-1 shows a system Involving parameters. It is often interesting to explore the dependence of the solution on parameters which appear in the differential equation. The ATOMCC system is especially well suited to this problem, because ATSPGM can be generated only once and then executed repeatedly for different values of the parameters.

You may enter the parameters as constants directly Into the statement of the equations. In that case, ATOMCC writes those constants directly into ATSPGM; this approach does not allow easy modification of the parameters. Note that all constants (except integer powers) are converted to real numbers by ATOMCC. so that it does not matter whether three is written os 3, 3.0, 3.E0, or 3.00.

If you wish to change the values of the parameters, moke each parameter in the equation to appear os a variable as shown in Example 3-1. Note that the variable parameters must be assigned dummy values in block 1, even though the actual values may be specified at solution time by statements In block 3.

If the values of the parameters ore to be supplied at solution time by reading from a data file or from a terminal, it moy be convenient to solve the problem repeatedly os shown by Example 3—14In Section 3.4.2.

3.2.3 COPTION DOUBLE - Double-precision ATSPGM

. T J"'? SS You specify differently, the ATSPGM program generated by ATOMCC is written in single-precision. A COPTION DOUBLE card, as the first card In ODEINP, signals ATOMCC to write ATSPGM in double-precision. No other changes should be made in block 1. In particular, if the ODE's have library functions such as SIN, EXP etc.. ATOMCC automatically inserts DSIN, DEXP, etc. into ATSPGm’ You should not make those substitutions yourself.

Example 3—7. Double precision object program.

COPTION DOUBLE

DIFF(Y,T,2) = 6*Y*Y + T $

$

C Read initial conditions and integration interval 0PEN(5,FILE=’DATA’)

READ(5,1010) START.END,Y(1),Y(2)

1010 FORMAT(4F10.3)

WRITE(*.1020) START,END.Y(1),Y(2)

1020 FORMAT( Solve the first Painleve transcendent + ’ Interval: •.2F10.3 /

+ * Initial conditions:’,2F10.3 /) $

$

/

288 BYTE LISTINGS SUPPLEMENT

April

- 32

(Internal page reference for manual.doc)

In a double-precision ATSPGM program:

real variables are declared as double precision;

double-precision FORTRAN functions (i.e. DLOG) are generated in ATSPGM; (The user must still use single-precision functions ?n the first block.)

call statements in ATSPGM reference the double-precision ATOMCC library routines DRSET, DSTEP, and DRDCV;

- FORMAT statements use D-format for real variables; constants are generated in double-precision form.

Some changes may be required in blocks 2, 3, and 4. ATOMCC copies them directly into ATSPGM, so you are responsible for any changes such as declarations or format modifications.

Be sure to link ATSPGM.OBJ with the double-precision ATOMCC subroutine library, DRDCV.OBJ. Incidentally, stiff problems are solved only in double-precision.

3.2.4 COPTION COMPLX - Complex ATSPGM

Including a COPTION COMPLX card as the first card In ODEINP signals ATOMCC to write a single-precision complex ATSPGM.

Example 3-8. Complex object program.

COPTION COMPLX

DIFF(Y,T,2) * 6*Y*Y + T $

$

0PEN(5,FILE*’DATA’)

READ(5,1010) MPRINT,NSTEPS,KPTS 1010 FORMAT(315)

WRITE(*,1010) MPRINT,NSTEPS,KPTS C

C Read initial conditions

READ(5,1020) Y(1),Y(2)

1020 FORMAT(8F10.3)

WRITER,1020) Y( 1) ,Y(2)

C

C Read piecewise linear path

READ(5,1020) (POINTS(I),1=1,KPTS)

WRITE(*.1020) (POINTS(I) , 1*1.KPTS) $

$

No other changes should be made in block 1. If the ODE’s have library functions like SIN, EXP, etc., ATOMCC automatically inserts CSIN, CEXP, etc. into ATSPGM. You should not write any complex functions yourself.

Some changes may be required in blocks 2, 3, and 4. ATOMCC copies them directly into ATSPGM, so you are responsible for any

BYTE LISTINGS SUPPLEMENT 289

* , - 33

(Internal page reference for monuol.doc)

lnden!nH!n* h °! <| ec 1 '<>"s or format modifications. The

c b hin\e% r ??om a ^a£e"!S"?^^^|i e 8 & •Jv"-'"*

zssfcx.'jr. iu.;; s r.*:=:;: i *’ 3

The other important change required for a comoIey AT qpru i* + k manner n which rtri + k ^ .. . u com P«©x AibrGM is the

:r,a5!s,s^ sr.s ssrj-,i«

is best to n keep'MPR?N?-4° f C0 " P ': X P '° ne f ° r It

10 Kee P mkkint=4. Higher va ues of MPRINT nniu i«„j„ l.

ever more confusing amounts of print outputs *

3.2.5 COPTION DOUBLE. COMPLX - Double-complex ATSPGM

Example 3-9. Double complex object program.

COPTION DOUBLE,COMPLX

DIFF(Y,T,2) - 6*Y*Y + T $

0PEN(5,FILE«’DATA’)

. 0,0 raSl?®’ ^'“T.NSTEPS.KPTS WRITE(*.1010) MPRINT.NSTEPS.KPTS

w

C Read initial conditions

READ(5,1020) Y(1),Y(2)

1020 FORMAT(8F10.3) '

WRITE(*.1020) Y(1).Y(2)

V

C Read piecewise linear path

READ(5,1020) (POINTS(I).I-I.KPTSl WRITE(*.1020) (POINTS(I),1=1,KPTS) $

sseIJ’';:,:’’ i?c par i;s5^ r - "

of atspom R-g^u S4r 0 por "“

Example 3-10. ATSPGM for Example 3-9

c*+*+*+*+*+*

c This program was produced by the c y

ATOMCC translator version 7 10 ^opyight (C) 1985, Y. F. Chong

V*+*+*+*+Hc+*+*+*+#+*^. # ^. + ^. # ^.

BYTE LISTINGS SUPPLEMENT

April

- 34

(Internal page reference for manuai.doc)

c Portions (c) Copyright, Microsoft Corp., 1981. All rights reserved, c This program was written for the following inputs c

COPTION DOUBLE,COMPLX C DIFF(Y,T,2) = 6*Y*Y + T

c no instructions in second input block

COMMON /IPASS/ LENSER,LENVAR,MPRINT,MSTIFF,LRUN,

+ KTRDCV,KNTSTP.KTSTIF,KXPNUM,KDIGS,KENDFG.NTERMS,NOPT A /RPASS/ RADIUS,ERRLIM,ADJSTF,RCREAL,RCIMAG,RDCERR B /CPASS/ START,END,ORDER C /DPASS/ H.HNEW

D /PATHCM/ POINTS,VECTOR,KPTS.KPAST COMPLEX*16 START,END,POINTS(10).VECTOR,CZRO.DCMPLX COMPLEX ORDER

DOUBLE PRECISION H.HNEW,AL COMPLEX*16 TMPS( 36, 1)

CHARACTER*6 NAMES EQUIVALENCE (TMPS(1,1),Y(1))

COMPLEX*16 Y(36), T(2), TMPAAB(30), TMPAAA(30)

COMPLEX*16 SHIFT DIMENSION NAMES(1)

DATA NAMES( 1)/'Y.*/

Y(33) =1.1

9 FORMAT(2X.11HAbove is at,1P2D12.4.9H step no.,14/)

10 FORMAT(72H ATOMCC Ver. 7.10, Copyright (C) 1985, Y. F. Chong; S Aolution results./9H ******)

CZRO = DCMPLX(0.D0.0.D0)

c start of third input block

0PEN(5,FILE«*DATA')

READ(5,1010) MPRINT,NSTEPS.KPTS 1010 FORMAT(315)

WRITE(*,1010) MPRINT,NSTEPS.KPTS C

C Read initial conditions

READ(5,1020) Y(1),Y(2)

1020 FORMAT(8F10.3)

WRITE(*,1020) Y(1),Y(2)

C

C Read piecewise linear path

READ(5,1020) (POINTS(I).1-1,KPTS) WRITE(*,1020) (POINTS(I),1-1.KPTS)

c end of third input block

BYTE LISTINGS SUPPLEMENT 291

(Internol poge reference for monuol.doc)

-

c--~!-l! te r ° d,U8 of mergence ond toke optimum step.

_ _CALL CDRDCV(TMPS, LENVAR, NUMEQS. NAMES )

c--~l-!l rUCtl0nS fourth '"Put block

GO TO (26.28). KENDFG 26 AL = RADIUS

H - DSIGN(AL.H)

„ 00 T0 24 24 START - START + HNEW*VECTOR

IF(MPRINT.LT.5) GO TO 27

K^Y&J 1 ) KNTSTP - START

27 CON?Kr' 3,2) "•“ESOO.V(I). 7(2)

WRITE(*,14) NSTEPS

28 CONTINUE

29 STOP END

copies m th^°2?re 8 ct^ ?nto*ATSw2 ' n o b ' 0Cks 2 > 3 - ATOMCC

changes such os decforotionl «r i S ° ? 0U ° r * r «spon S ible for ony Independent and depend^ CorToK r* 0 * mod * f 1 ^t ions. The * condition must hove both o reofin'd oVi^no"; 11'“" '' n ' U °'

monnIr e in m whi^ n !he h path llVnilt/aUan ? 0mplex A T SPGM the integrotion is o p i ecewi se I i nlor^ih • S t ! PeC ‘ f ied ’ The poth of independent vorioble. The path coEsilti of^PTsTitV 10 ?* ° f the the complex array POINTS as shown in r , points stared In

•< '• «.22.5 »<■>»

Is best to keep l MPRINTe4° f Hieher *!/ 1 plo " # for singularities. It

.— oenf;.^“. T ei„,. H :? h ;;,„ , j':;; P :;." pR, " T m,y , ~ <i * »•

3.2.6 COPTION LENVAR=n - Series length

LENvIS* S ihe vaIue*of ^ENVAR^may be^onoed'b S ^‘ e ? '* Stored in

expression "LENVAR=n" on a COPTIOtTcoJr® Thrill

used is controlled by the variable LENSER (see lecUon S^g)^’ 68

Example 3-12. COPTION LENVAR=n

COPTION LENVAR=100

DIFF(POWER.TIME,4) - 3*DP2 0P2 » DIFF(POWER.TIME.2) $

0PEN(5,FILE»’DATA’)

.«-o?a?(6?,'?! 3 r ART ’ END ’ (po " ER <'>s>'.*)

BYTE LISTINGS SUPPLEMENT

- 36

(Internal page reference for manual.doc)

WRITE(*,1010) START,END,(POWER(I),1-1,4) $

$

There are several circumstances under which you may wish to use a series length which differs from the 30-term series used by ATSPGM

- The system of ODE's contains no functions or products of dependent variables. The cost of generating the series is then proportional to the series length (instead of the length squared), so using longer series may result in a faster execution time.

- A series begins with many zero terms. Since ATSPGM requires series which have at least 8 nonzero terms, you must lengthen the series.

Section 3.4.9 contains a discussion of the effect of series length on the execution time of ATSPGM.

3.2.7 COPTION DUMP«n - Diagnostic messages

This feature involves the operation of the ATOMCC translator Itself and will rarely be used. It was used during the development of the software and is documented here only for completeness. The form is COPTION DUMP*n, where n indicates the amount of dump to be written (on your screen). The following is dumped for each n.

5 after lexical and syntactical analysis, and 4 after first optimization,

and 3 after equation sorting and variable type identification,

and 2 after implicit operator and operand analysis,

and 1 after second optimization.

It is suggested that users who wish to consult with the authors about a suspected bug in ATOMCC should have available the output from a run in which "DUMP-5" was specified and directed to a file for printing.

3.3 Using bIock 2

The second, third, and fourth blocks are not processed by ATOMCC in the same way as the first input block. ATOMCC merely copies the data from your ODEINP file directly into ATSPGM.

The second block is optional and is used to insert non-executable FORTRAN statements at the beginning of ATSPGM. This block gives the user the ability to insert 'SUBROUTINE*,

'FUNCTION', 'COMMON', 'DATA', and 'DIMENSION* into ATSPGM. Example 3-13 shows where statements supplied in block 2 are inserted into ATSPGM.

BYTE LISTINGS SUPPLEMENT 293

37

user

(Internal page reference for manual.doc)

3.3.1 Subroutine form of ATSPGM

ATSPGM is normally generated as a main program which can then t k-??J V V he spec ' f,ed problem. The ATOMCC translator has ATc^ ap b li ty L t0 9*? erate subroutine or function forms for ATSPGM. The subroutine or function can then be called from a supplied main program, or from another ATOMCC-generated main program, to obtain the solution of the problem.

A subroutine ATSPGM is specified by placing a SUBROUTINE statement In the second block. This statement is placed unchanged at the beginning of the generated code, so you have complete control of the name of the subroutine and Its parameter list. However, this also means that you have complete responsibility for passing values to and returning values from the generated program

inftend'nf I b Y AT0MCC " have a RETURN statement

instead of a STOP at Its end. Example 3-13 shows the ODEINP for a

*og(s'i l n(x) named DIFEQU, which solves the equation f* =

Example 3-13. Subroutine form of ATSPGM

DIFF(F,X,1) = A10G(SIN(X) + F) $

SUBROUTINE DIFEQU(COND) $

F(1) = COND $

$

with Its calling program C Driver program for Exomple 3-13.

c

C A very simple subroutine, START and END are passed through COMMON.

COMMON/CPASS/ START.END,ORDER 1010 FORMAT(6F10.3)

READ(5,1010) COND,START,END WRITE(*.1010) COND.START,END CALL DIFEQU(COND)

STOP

END

„,„ n M ? ny ° f the variables used in ATSPGM appear in COMMON, so they ??!! °! P ara, " e te r s • Values con be passed through the

COMMON d- tel "P orar y variables, or they con be passed in COMMON by including the appropriate COMMON block in the callina program as illustrated by Example 3-13. 9

3.3.2 User declarations

You may need to declare the type of the additional variables you introduce into ATSPGM, if you use the double-precision or

DOUBLF X OOMwnKi 0f nA^f PGM ; Y °V "'?? include appropriate DIMENSION, DOUBLE, COMMON, DATA, etc. in block 2. Any non-executable FORTRAN

statements inserted in the second block ore copied into the

294 BYTE LISTINGS SUPPLEMENT

- 38

(Internal page reference for manual.doc)

beginning of ATSPGM exactly as they are written, so you have total control over the statements entered. These statements must conform to FORTRAN specifications; ATOMCC does not check their syntax or the order of placement.

3.3.3 Common blocks for user

You may wish to use COMMON blocks. COMMON declarations may be included in block 2 like all non-executable FORTRAN statements discussed in Section 3.3.2.

Note that many of the variables used in ATSPGM appear in COMMON blocks and must not be assigned to other blocks.

3.4 Using block 3

The third block must be used to specify the interval of integration and the initial conditions. It may also be used to change the default values of method-control variables. Default values are changed by inserting statements which assign new values to these variables. If desired, other statements can be inserted into ATSPGM at this point. The user should have an understanding of the form of ATSPGM and the relative position of the third block in ATSPGM. Examples 2-1 and 2-3 and Examples 3-1 and 3-3 are a pair of ODEINP files with their respective ATSPGM programs, you can better understand how the method-control variables work by studying the statements in the neighborhood of block 3.

The assignment of values to each of the variables discussed in this Section may be done by:

1.

a READ statement (see Examples 2-1, 3-12),

2-2. 3-1,

3-7, 3-11,

2.

an assignment statement (see Example 2-6), or

3.

being passed as temporary variables (see Example 3-13), or

through a

parameter 1ist

4.

common block shared with a driving 3-13).

main program (see Example

BYTE LISTINGS SUPPLEMENT 295

. - 39

(Internal page reference for monuol.doc)

3.4.1 Initial conditions

T . In?J n ! ti0 ! cond ! t,ons »utt be specified in the third block.

wv ' '? 9 V S r ?? X ° = START 0f the de P«" d *"t variable, say

yyy. d its derivatives ore assigned to the array yyy as follows —

YYY(1) denotes yyy at xo,

YYY(2) denotes yyy’ at xo,

YYY(3) denotes yyy 1 ’ at xo, etc.

nu "l be ^ of J n '* ,al conditions which must be specified for !orinM^ en h? n K vor ' °b 1 e equa I s the highest derivative of that var able which appears in the system of equations If the svstem

!nc uded ? ^ 'nltiol^ondmons must

included for the dependent variable y. ATOMCC does not check

that h the'«M*I condi | ‘J on s h °ve been supplied, since it is possible that the series variable has been passed through a subroutine

the°r!nuirlH S -'•'* is your responsibility to see that the required Initial conditions are defined.

When ATSPGM is a subroutine, the series variable may be passed

staled ln r ?h« " 8t -, In ? his COse * the initio1 conditions may be exeeu terf 0 P ^? P * r elements of the series array before ATSPGi/is

*° P°ssing the series via the parameter fh o pass the initial conditions as temporary variables in

the parameter I 1st. Assignment statements in the third block then elements^** V *° the oppro P riote dependent variable ar?ay

th« ft?!,*? th0 *? * h0 ore familiar with the Taylor series methodise initial conditions should be entered as explained above; that

3.4.2 Parameters in the differential equations

It is often interest solution on parameters i showed how the system of parameter are assigned, in Example 3-14. Here, a the parameter. See the observe that statement purpose.

ing to explore the dependence of the n the ODE’s. Section 3.2.2 and Example 3-1 equations is entered and how values of the A refined version of Example 3-1 is shown loop is used to read successive values of ob j ect program listing in Example 3-3 and 28 CONTINUE * is provided by ATOMCC for this

Example 3-14. Read parameters repeatedly.

DIFFfX,T,2) = - ALPHA*X*R DIFF(Y,T,2) = - ALPHA*Y*R R = (X*X + Y*Y)**(-1.5)

ALPHA * 0.65 «

$

Read and echo print code, number 0PEN(5,FILE»’DATA')

of integration steps.

296 BYTE LISTINGS SUPPLEMENT

- 40

(Internal page reference for manual.doc)

READ(5,1010) MPRINT.NSTEPS

1010 FORMAT(2110)

WRITE(*,1010) MPRINT.NSTEPS

C

C Read and echo Interval and initial conditions to be used each time. READ(5,1020) OLDSTR.OLDEND,X1.X2.Y1,Y2 1020 FORMAT(6F10.3)

WRITE(*,1020) OLDSTR.OLDEND.XI.X2.Y1.Y2

C

C Loop for different values of the parameter. DO 28 IPR0B=1,20 READ(5,1020) ALPHA IF(ALPHA.EQ.0.0) STOP WRITE(*,1020) ALPHA START = OLDSTR END = OLDEND X(1) = XI

Y(2) = Y2 $

WRITE(7.1030) KINTS.START.X(1).X(2).Y(1).Y(2)

Y(2) = Y2

1030 FORMAT(15.1P5E14.5) $

3.4.3 Solve a problem repeatedly

In Example 3-14, the statement ’DO 28 IPROB*1,20’ is included in block 3 to solve the same system of differential equations as many as 20 times without restarting the program. The statement '28 CONTINUE* near the end of ATSPGM is written by ATOMCC for this purpose. Within this loop, you may vary values of parameters as in this example, you may vary the initial conditions, or you may vary the method-control variables.

3.4.4 START, END - Interval of integration

The integration interval must be specified in the third block using the two reserved words START and END. Their use is illustrated by all the examples.

If^a complex ATSPGM is being used, then the interval of integration is a piecewise linear path in the complex plane of the independent variable. The specification of complex paths of integration is discussed in Sections 3.4.13 and 3.4.14.

3.4.5 NSTEPS - Number of integration steps, default«40

The maximum number of integration steps taken during the solution is the variable NSTEPS. The default value (40) can be so small because the use of long series allows very large integration steps. You may change this value by inserting a statement In the third input block which assigns a new value to NSTEPS, or you may read in a value for NSTEPS from a data file.

For some stiff problems and in searching for singularities in the complex plane, it is best to set NSTEPS at a large value.

BYTE LISTINGS SUPPLEMENT 297

(Internal page reference for manual.doc)

3.4.6 H - Initial trial stepsize, default ■* 1.0

The default value of the suggested Initial stepslze can be changed by assigning the desired value to the variable H In the third block. The term "suggested initial stepsize" is used because this value may be adjusted by ATSPGM before the first step is taken. This adjustment Is made if Its need is indicated by an analysis of the Taylor series for underflow/overflow. The user can rarely make a better choice than ATOMCC.

For stiff problems, in addition to the adjustment of H in ATSPGM at the first integration step, the stepsize H is adjusted within DRDCV at every step. The adjustments at the first integration step may need some manual assistance. In such cases, observe the values generated by the ATSPGM program and project forward to the next reasonable value and enter it for H.

3.4.7 ERRLIM - Preset accuracy of the solution

The local error tolerance is the variable ERRLIM. ATSPGM will keep the maximum local error less than ERRLIM. The magnitude of ERRLIM is automatically set by ATOMCC to be close to the computer round-off error in both single- and double-precision. You may set ERRLIM to be much larger; however, your results will become inaccurate. You may not set ERRLIM to be much smaller.

The error analysis for normal problems is so precise that one can almost expect the global error to be under control. This is one numerical method where the global error is proportional to the local error. Therefore, to determine the magnitude of the global error, one only needs to run the solution a second time with an ERRLIM set one order of magnitude smaller than the first run and compare the two results.

3.4.8 ADJSTF - Error control for stiff problems

The error analysis for stiff problems is not nearly as well developed as the error analysis for normal problems. In solving stiff problems, it is necessary to make assumptions regarding both the exponential function and the polynomial that are used to fit the solution being sought. Therefore, an error-controlling parameter separate from ERRLIM is used. The default value for ADJSTF is 1.E-2. Also, the value of ERRLIM is fixed to 1.E-6 for stiff problems. The user is advised to change ADJSTF to lower values and make additional runs of the solution to be certain of its correctness.

There is absolutely no connection between a particular value of ADJSTF and the magnitude of the error in the computations. The most that is claimed is that as the value of ADJSTF is adjusted smaller, there is likely to be a lowering of the computational error. Since the nature of stiff solutions is an approximation, there can be no true error control. And so, none is attempted.

298 BYTE LISTINGS SUPPLEMENT

- 42

(Internal page reference for manual.doc)

3.4.9 LENSER - Length of series used, default-30

The length of the Taylor series is the variable LENSER. This value may be changed by assigning a new value to LENSER in the third block. However, there are some restrictions governing how this is done.

LENSER may be set to any integer between 15 and 30 without any other changes. Series of fewer than 15 terms should not be used.

If a series of more than 30 terms is desired, the size of all series variables (LENVAR) must be increased (see Section 3.2.6).

The user is reminded that the execution time is related to the length of the series. The default value of LENSER-30 have been found to be optmial for fast execution.

In stiff solutions, LENSER is automatically set to either 15 or 10 depending on the parameter MSTIFF. In these cases, the user cannot change these set values of LENSER without going into the subroutine DRDCV.

3.4.10 MPRINT - Amount of print produced, default-4

The amount of printout produced by ATSPGM during the solution of the problem is controlled by the variable MPRINT. Values of every dependent variable at each integration step is printed with an MPRINT-4. The user can change the default by assigning MPRINT a different value in the third block. The amount of printout produced for values of MPRINT is listed below.

0 Used for timing purposes; printout is produced only when a fatal error occurs.

1 No print is produced, but the loop controlled by RSET is activated to produce user controlled print (see Section 3.5.2).

2 Print is produced only at points selected by the user. The printout consists of the integration step number, the value of the independent variable and the initial conditions for each dependent variable.

4 (default) Print the information for 2 at every integration step. (In complex solutions, only the singularity locations are printed here.)

5 In addition to the output under 4, the actual stepsize used at each integration step is printed. In stiff problems, the exponential function and the length of the polynomial are printed. In stiff problems, the estimated HSTF and the relative goodness of the exponential fit are printed. (In complex solutions, MPRINT-5 is equivalent to 4)

6 In addition to the information for 5, print (a)the computed radius of convergence, (b)location of the singuIarIty(1es), and (c)whlch test was used to locate the poles.

BYTE LISTINGS SUPPLEMENT 299

- 43

(Internal page reference for manual.doc)

7 In stiff problems, the entire results for the exponential fit are printed.

8 All of MPRINT«6, plus (a)the estimated error in h/Rc, (b)the values of the elements of each series, and (c)messages for all tests used for the radius of convergence.

10 All diagnostic messages including all the series terms.

Users who will use ATOMCC often should try setting MPRINT-10 to become familiar with the Information available during the solution of a problem.

The value of MPRINT may be dynamically controlled during the computation of a solution by inserting statements in the fourth block which test the current value of START (or KINTS), and set the value of MPRINT accordingly.

3.4.11 DLTXPT - Print point increments, default - 0.0

ATSPGM uses variables XPRINT and DLTXPT to control values of the independent variable for which print is produced. We will discuss a variety of ways these variables can be used.

If DLTXPT*0.0, then print Is produced only at the integration steps chosen by the program. This is the default condition.

Print is produced at equally spaced points by specifying DLTXPT = xxx (the desired spacing) as shown in Example 2-8 in Section 2.3. A statement may be placed in the third block which assigns the desired value to DLTXPT. You should also specify MPRINT-2. Otherwise print is produced both at your selected points and also at the integration steps selected by ATSPGM. MPRINT is discussed in Sect ion 3.4.10.

The values of each dependent variable are printed at the equally spaced points by expanding a series which has already been computed. The integration does not step to the equally spaced points. Hence, requesting intermediate output has no effect on the number or size of integration steps taken.

More creative print points are possible by the use of block 4. See Example 3-15 in Section 3.5.3.

DLTXPT can be used in stiff solutions to generate output at desired values of the independent variable. DLTXPT cannot be used in conjuction with ZEROT, where the solution may be stopped for any value of any function.

3.4.12 KTRDCV - Dynamic suppression of CALL RDCV

KTRDCV can be used to speed up the execution of ATSPGM for systems of ODE’s for which some components of the solution do not constrain the integration stepsize. For KTRDCV=N, the series analysis is performed only for the first N components of the solution. You can generate ATSPGM once, run it to see the radii of

300 BYTE LISTINGS SUPPLEMENT

(Internal page reference for manual.doc)

convergence of each component, and use KTRDCV on subsequent runs to reduce the execution time of ATSPGM. You should order the Input ODE’s such that those with larger radii are listed last. Careful study of the ATSPGM program for a sample system of ODE’s will help you see how KTRDCV works.

3.4.13 KPTS - Number of points on complex path

In Section 3.4.4, we discussed the specification of the interval of integration using START and END. If ATOMCC has been directed to generate complex object code (COPTION COMPLX, Sections 3.2.4 or 3.4.5), then the path of integration is a piecewise linear path in the complex plane of the independent variable. See Example 3-8 in Section 3.2.4.

The variable KPTS is the number of vertices belonging to that piecewise linear path, including both of the endpoints. The complex array ’POINTS' holds the vertices. POINTS(I) becomes START, and POINTS(KPTS) becomes END. The value of the solution is printed at each element of POINTS. KPTS may be at most 10.

3.4.14 POINTS - Complex path of integration

The complex array 'POINTS' specifies the path of integration in the complex plane of the independent variable. Its use with KPTS is discussed in Section 3.4.13. There may be at most 10 points specified.

3.4.15 MSTIFF®10 - Solutions which are entire

Solutions which are entire (have no singularities in the finite plane), should not be solved using the ATOMCC system. It is a total waste of computing power to solve linear problems using ATOMCC. This is particularly true for linear 'stiff' problems.

It can be EASILY show that ALL solutions that are entire can be solved in quasi-closed forms. This INCLUDES two-point boundary value problems!

If ATOMCC recognizes that a system of ODE's involves no functions or products (an entire solution), it sets MSTIFF-10 in ATSPGM. Subroutine RDCV recognizes MSTIFF*10 as a flag for a special test for series that is entire.

3.4.16 MSTIFF=20,21,22 - Stiff problems.

This version of ATOMCC contains a double-precision algorithm to solve stiff problems. To use it, one can either set MSTIFF=20, or 21, or 22. Other parameters that should be controlled are H,

ADJSTF, and NSTEPS. It Is also desirable to set MPRINT to 7. at least initially, for observing the progress of the solution. If it should be evident that the problem is not really stiff, then it is most advisable to solve it as a normal problem.

BYTE LISTINGS SUPPLEMENT 301

- 45

(Internal page reference for manual.doc)

MSTIFF-20 is the more conservative of the three algorithms. In this case, LENSER is set to be 15. The default value for ADJSTF, the error-controlling parameter, is a rather large 1.E-2. The user should run the stiff solution at least one more time with a somewhat smaller ADJSTF, say 1.E-3, to check on its validity.

Since the default value for NSTEPS is 40, this should definitely be set at 500 or more, to be sure that the stiff solution can be completed. The initial stepsize H may need some adjustment by the user. He should study the H-adjustment messages from ATSPGM and take over control if and when the automatic adjustment is incapable of reaching a desirable value for H. When MSTIFF-20, those stiff problems that have steady-state solutions are identified. After which, one should perform some manual manipulations before re-submitting the problem to ATOMCC.

When MSTIFF-21, LENSER is set to only 10. So, this option should be used only if the user is absolutely certain that the problem under study is very stiff. The solution of stiff problems under this option is considerably faster than that for MSTIFF-20, because not only are the series shorter, the integration stepsizes are considerably larger. The same statements as above applies for the parameters H, ADJSTF, and NSTEPS. (One of the Enright-Hull set of stiff problems, E2, was solved by ATOMCC in one step!) There is no attempt to identify steady-state solutions when MSTIFF-21.

MSTIFF-22 is identical to MSTIFF-20 except for the fact that there is no attempt to identify steady-state solutions.

As mentioned above, the stiff algorithm is written in doubleprecision. It is simply not cost effective to solve such problems using single-precision. There is one other restriction on stiff problems. All such problems must be stated as first-degree ODE's.

The regular printing option, DLTXPT, functions properly in stiff solutions. So, it is possible to obtain uniformly spaced print points or IogarithmicaIy spaced print points.

3.4.16.1 Steady-State Stiff Problems

There are some stiff problems that approach steady-state solutions. Sometimes this occurs with all of the functions becoming constant simultaneously. In such a case, the ATOMCC solution will stop and points out the fact that every function seem to have reached constant values. The user can decrease ADJSTF and repeat the solution to verify the truth of this fact. He can also run the problem with MSTIFF-22 and observe the perpetual singleness of the resuIts.

In other instances, a particular function reaches constancy before any of the others. When this happens, the following message will be printed, with obvious meaning.

The function Y4.... is constant at 3.115283D-04

Look for a steady-state solution.

Set all derivatives to zero, use the value of Y4.... given above, and solve for the other functions in easy situations.

Then, re-submit to ATOMCC. Use MSTIFF-21 or 22, do not use MSTIFF-20.

302 BYTE LISTINGS SUPPLEMENT

- 46

(Internal page reference for manual.doc)

This example Is for the problem CHEM6 out of the Enright-Hull set of chemical stiff problems. This solution stopped at time = 0.0561, where the solution had hardly gotten started. After solving the easy cases as suggested, the ATOMCC solution of the re-submitted problem reached the final time of 1000 in 26 steps using MSTIFF=21!

The equational input for the first ATOMCC run is as follows.

DIFF(Y1,T,1) = 1.3*(Y3-Y1) + 10400*AK*Y2 DIFF(Y2,T,1) = 1880*(Y4 - Y2*(1+AK))

DIFF(Y3, T, 1) = 1752 - 269*Y3 + 267*Y1 DIFF(Y4,T,1) = 0.1 + 320*Y2 - 321*Y4 AK = EXP(20.7 - 1500/Y1)

The equational input for the second ATOMCC run, after encountering the constancy message is as follows.

DIFF(Y1,T,1) = 1.3*(Y3-Y1) + 10400*AK*Y2 DIFF(Y2,T,1) = 1880*(Y4 - Y2*(1+AK))

Y3 = 1752/269 + 267/269*Y1

Y4 = 3.115283E-04

AK = EXP(20.7 - 1500/Y1)

The differences between to two inputs are in the third and fourth equations.

3.5 Using bIock 4

ATOMCC copies the fourth block directly into ATSPGM near the end of the code for each integration step. Example 3-3 in Section 3.1.3 shows the location of block 4 in ATSPGM. The fourth block is used to tailor ATSPGM to your special requirements. Several examples are provided in Section 3.1.1, but many other creative uses are possible. Most applications require a good knowledge of the ATOMCC system for solving ODE’s.

3.5.1 Automatic printing of output points

The ATSPGM program automatically prints the values of each component of the solution at each integration step (see Example 2-7 in Section 2.2.6). It can print the same information at equally spaced points you select using DLTXPT (see Section 3.4.11). This technique for generating output at equally spaced points requires no use of block 4, but it will help you to understand subsequent sections if you understand how ATSPGM generates this equally spaced output. Please refer to the object code in Example 3-3 in Section 3.1.3 as you read.

The points selected for output do not affect the integration steps so that the local error remains proportional to the global error. For each output point within an integration step, the

BYTE LISTINGS SUPPLEMENT 303

(Internal page reference for manual.doc)

solution is computed by evaluating Its Taylor series. Inside the subroutine RSET, each output point within the the Integration step Is controlled by a loop which begins with the statement *24 IF (KENDFG.EQ.3) KENDFG*1* and ends with the statement *G0 TO (26.28,24), KENDFG*. KENDFG is a flag which controls the loop.

Subroutine RDCV sets KENDFG*2 if the current steps reaches END, otherwise KENDFG=1. Subroutine RSET determines whether the next output point (XPRINT) lies within the next step of integration. If not, RSET leaves KENDFG unchanged (1 or 2) and stores the initial conditions required by the next step. If there is a print point within the next integration step, RSET prints the solution at that output point (suppressed if MPRINT*0 or 1), stores values of the series and its derivatives as elements LENSER+1, LENSER+2,... in the series, and sets KENDFG*3. Then, the *G0 TO* in ATSPGM returns to label 24 to handle additional output points within the next integration step. Once all of the output points within the next step have been passed, RSET returns KENDFG to its original value (1 or 2), and the solution proceeds forward.

You can use DLTXPT to generate output at equally spaced points without understanding how that output is generated, but if you wish to produce some special output as discussed in the following Sections, this understanding is necessary.

3.5.2 User controlled printing of output points

The object program automatically prints the values of each component of the solution at each integration step (see Example 2-7 in Section 2.2.6). The method used to produce output at user selected points is discussed in Section 3.5.2. However, you may use block 4 as shown in Example 3-1 in Section 3.1.1 to produce output according to your particular needs.

The execution time for ATSPGM is sensitive to the amount of output produced. Unless you are interested in the automatically produced output, place MPRINT=1 in block 3. Then, RSET controls the necessary looping as discussed in Section 3.5.1, but it produces no output. This yields the solution at equally spaced points.

Unequal spacing can be achieved by changing DLTXPT within block 4. Example 3-15 in Section 3.5.3 shows how to obtain the solution at logarithmically spaced points.

Many variables are accessible for your use in block 4. The elements of the array for each dependent variable, [y(LENSER+1), y(LENSER+2), etc.], contain the values of that variable and its derivatives evaluated at XPRINT. The user can therefore print these values totally independent from the print produced by ATSPGM. Additional usable values are stored in the top three positions of the series; y(LENVAR-2) is the series length actually used for that particular variable, y(LENVAR-1) is the multiplying constant for the exponential function in stiff solutions, and y(LENVAR) is the exponential coefficient in stiff solutions.

304 BYTE LISTINGS SUPPLEMENT

- 48

(Internal page reference for manual.doc)

3.5.3 Logarithmic spacing of output points

The techniques discussed in Sections 3.5.1 and 3.5.2 produce values of the solution at equally spaced points. Output at non-uniformly spaced points is obtained by adjusting DLTXPT and XPRT3 within block 4 as shown by Example 3-15. The print points are at r = 100, 50, 20, 10, 5, 2, etc. This example also shows that problems can be integrated in the negative direction.

Example 3-15. Logarithmic print.

DIFF(F,R,2) = (F**3 - F)/R**2 $

$

START = 100.0 END = 1.0E-8 F(1) = 0.99 F(2) = 1.0E-4 DLTXPT * -50.0 NPTR = 1 $

IF(KENDFG .NE. 3) GO TO 25 MPRINT = 2

GO TO (501,503,502), NPTR

501 DLTXPT = - 0.6*XPRINT GO TO 504

502 NPTR = 0

503 DLTXPT = - 0.5*XPRINT

504 NPTR « NPTR + 1

XPRT3 « XPRINT + DLTXPT $

3.5.4 ZEROT - Stopping and printing at roots of variables

It is often of interest to locate points at which a component of the solution has a root or assumes some specified value. The subroutine ZEROT, in the ATOMCC subroutine library in singleprecision, do automatically solve such problems. DZEROT Is the double-precision version.

The form of the CALL is

CALL ZEROT(NUMBER,Y,ROOT.KEY,TMPS,LENVAR,NUMEQS)

where

NUMBER is the index of the Y series term whose root is sought,

Y is the variable whose root is desired,

ROOT is the value Y is to assume (= 0 for a root),

KEY is 1 if Y is a dependent variable, or

0 if Y is not a dependent variable.

The arguements TMPS, LENVAR, and NUMEQS must be exactly as written above.

BYTE LISTINGS SUPPLEMENT 305

r \

(Internol page reference for monual.doc)

Example 3-16. Rootffnding with ZEROT.

DIFF(Y,T,2) = 6 *Y*Y + T $

START = 0.0 END = 1.15 ROOT = 20.0

Y( 1 ) - 1.0 Y( 2 ) = 0.0 $

CALL ZEROT( 1 ,Y,ROOT, 1 )

When the variable whose rAA* * . *

rr*- ,h> ^r.r.v

c :n^%Z Y ilV )

TEMP . START * KNE.

ie, 0 • reMP ’ VARYC1 )• V *«XC2)

GO TO 25 $

information os shown*in *the*se 0t " ecessar Y for one to print the stop and restart the , 0 n SSKmo??*' (1 The / TSP ^ P?og?«doe. the output is controlled by MPRIN^ ° y at the 8X0ct root and

—j’ss'rss’ir.s-jn^sfi-.a.s: r ,obi - - —•-<

ser.es is not convergent over thl.If ,ze being used. If the possibly locate the Foot with 1 S# ' * hen ZER0T cannot two instances where this convergence ^.,V occ “ r « c y* There are IS where the prfntfna stan* k! 9 u requirement Is not met One OLTXPT. and the other fs Z^ a U " der the ^ntFol of

p T ?o e b^ e ’ ZER ° T us*d°for o # non-riro n^stiff

value; however^obv^ous ly^heJ^NUMBER* is°!' *' V ? (non_zero ) integer the root will suffer. NUMBER 18 V8r Y 'orge the accuracy of

3.5.5 Finding singularities in real solutions (This Information Is oniv *u

finding the conjugate pairs of s ingjtar m erS ? h ° are inter «sted in oxis. For a more detailed studv nf ° r ties closest to the real invoke COPTION COMPLX, Section^ 3 . 2 [ 4 ) lar * t' ®s, the user sho°u.d

-n-iJtK^nfoJSK: iLX%i:zv&'r ; s its abMity ** p™.*

RDCV estimates the location and oidlr ni /? r exam P ,e ' subroutine each integration step In order to rnmm°+ p '’' mar y singularities at Th.s information may be printed us ing^PRIN^fsirSeluon’ 2e '

3°6 BYTE LISTINGS SUPPLEMENT

- 50

(Internal page reference for manual.doc)

3.4.10). However, several steps are usually required to pass between a conjugate pair of singularities, so several different estimates for each location are written. Estimates made close to the singularities are more accurate than estimates made from further away.

Example 3-17 prints only one estimate for the location and order of each conjugate pair of singularities. That estimate is written on the step which has just begun to recede from the estimated location. Hence that step is one of the two steps closest to the singularity pair.

Example 3-17. Finding singularities in real solutions

COPTION DOUBLE C

C Test dynamic printing of singularity positions.

C

DIFF(Y1,T,1) - 2*(Y1 - Y1*Y2)

DIFF(Y2,T,1) = Y1*Y2 - Y2 $

$

ERRLIM = 1.0E-6 START =0.0 END = 20.0 Y1(1) = 1.0 Y2(1) = 3.0 MPRINT = 10 PRTSNG = START SNGTOL =0.1 WRITE(8,2010)

2010 FORMAT(///6H Step,9X,IHx,10X,2HRc,8X,4HReaI,

A 8X,4HImag,7X,5Horder,7X,5Herror/)

$

C

C Print locations of singularities.

C

WRITEf*,2010)

WRITE(*,2020) KINTS.START,RADIUS,RCREAL,RCIMAG,ORDER,RDCERR C

C If this is a user print step, then continue.

IF(KENDFG.EQ.3) GO TO 25 IF(KINTS.EQ.NSTEPS) GO t0 102 C If this is a normal step, then jump.

IF(KENDFG.EQ.I) GO TO 105

C Handle the last step - we might be approaching a singularity C if we have already printed this primary singularity, then continue.

102 IF(ABS(RCREAL-PRTSNG).LT.SNGTOL) GO TO 25 C If RDCV was uncertain, then continue.

IF(RDCERR.GE.1.0) GO TO 25

WRITE(8,2020) KINTS,START,RADIUS,RCREAL,RCIMAG,ORDER,RDCERR 2020 FORMAT(14,1P6E12.3)

GO TO 25 C

C Handle a normal step.

C

C If confused, then continue.

105 IF(RDCERR.GE.1.0) GO TO 25

BYTE LISTINGS SUPPLEMENT 307

- 51

(Internal poge reference for monual.doc)

C If °PProaching the primary singularity, then continue IF((START-RCREAL)*H.LE.0.0) GO TO 25 conxmue C If already printed, then continue.

IF(ABS(RCREAL-PRTSNG).LT.SNGTOL) GO TO 25

prtsngVrcre al 1 NT $ ’ START ' RAD1US * RCREAL1RCIMAG • 0RDER • RDCERR

Example 3—18. Printed locations

Step x

1 0.000E+00

9 5.180E+00

19 1.083E+01

28 1.627E+01

Rc

5.978E-01 4.954E-01 5.297E-01 5.145E-01

Rea I

-3.364E-01 5.151E+00 1.063E+01 1.612E+01

Imag

4.941E-01 4.945E-01 4.943E-01 4.943E-01

order

9.457E-01

9.784E-01

9.595E-01

9.662E-01

error

5.588E-04 7.08IE-04 2.888E-04 2.660E-04

3.5.6 Stopping short of a singularity

If one component of the solution has a singularity inside the

on ^ that Ini ,nt *9 r otion, then the problem does not have a solution on that interval, so the integration process should stop. ATSPGM stops when NSTEPS steps have been taken (see Section 345) or it stops when the integration stepsize is so small relative to the current point of expansion that the solution would not advance

3.6 Editing of ATSPGM

direct Iv* into AT 9 Pru b | 0cks 2> 3 ‘ and 4 to In»«rt FORTRAN code directly Into ATSPGM gives you a very powerful and flexible tool

you may have needs which can only be met by editing ATSPGM

oroduo f * Section 3.6.1 uses the relatively common problem of

approach? eff ' C,ent output at specified points to Illustrate the

3.6.1 TERM - Fast generation of printing at output points

The printing of solution values at equally spaced points has already been discussed in Sections 2 . 3 , 3 . 4 . 11 , 35?. and 3 52 The technique discussed in Section 3.5.2 can be used to generate’

select ° Th° f the ab °ut solution at any Joints^ou

select. The execution time is much faster using MPRINT =1 to suppress printing by RSET, than with MPRINT -2 or 4

? X#C “ U °? *'?• of ATSPGM can b ® further reduced by ?ntearitinn k° P n ?,f 0r COCh print point witb in the current

seMes fir thl ? 9 subrout ine TERM to evaluate the

2 eiSp” s^'s? ony p °""- ii,i! i*

308 BYTE LISTINGS SUPPLEMENT

April

-52

(Internol page reference for manual.doc)

Example 3-19. TERM source listing

C SUBROUTINE TERM (SERIES,NTERMS,T,WORKAR)

C

C ATOMCC-LIBRARY, COPYRIGHT (C) 1983.

C

C EVALUATES SERIES AND ITS DERIVATIVES AT T C

C AT ENTRY. 'SERIES ‘ CONTAINS A SERIES EXPANDED AT SOME POINT C ’START’ WITH A STEP OF ’H’.

C

C AT EXIT, WORKAR(I) = FUNCTION EVALUATED AT T C WORKAR(2) - DERIVATIVE OF FUNCTION EVALUATED AT T

C ...

C WORKAR(NTERMS) - NTERMS - 1 DERIVATIVE EVALUATED AT T

C

C PARAMETERS:

C SERIES - SERIES BEING SUMMED

C NTERMS - NUMBER OF INITIAL CONDITIONS NEEDED

C T - POINT AT WHICH SERIES IS TO BE EVALUATED

C WORKAR - WORK AREA. SAME TYPE AS SERIES. DIMENSION NTERMS

C

SUBROUTINE TERM (SERIES, NTERMS. T. WORKAR)

C******** DATA DECLARATIONS

DIMENSION SERIES(I). WORKAR(I)

COMMON /CPASS/START,END.ORDER A /DPASS/H,HNEW,XPRINT,DLTXPT

+ /IPASS/LENSER.LENVAR.MPRINT,MSTIFF,LRUN.KTRDCV,

+ INTSTP,KTSTIF.KXPNUM.KDIGS.KENDFG,NTERMS

C******** COMPUTE INITIAL CONDITIONS ANO STORE THEM IN WORK AREA RATIO = (T-START)/H DUMMY = H/FLOAT(LENSER)

DO 40 1-1,NTERMS ILEN = LENSER - I - 1 DUMMY - DUMMY*FLOAT(LENSER - I + 1)/H DLOOP - DUMMY

SUM = SERIES(LENSER)*RATIO*DLOOP DO 30 J-1.ILEN LMJ - LENSER - J

DLOOP - DLOOP*FLOAT(LMJ-I+1)/FLOAT(LMJ)

SUM = (SUM + DLOOP*SERIES(LMJ))*RATIO 30 CONTINUE

WORKAR(I) - SUM + DLOOP*SERIES(I)/FLOAT(I)

40 CONTINUE c******** RETURN 9999 RETURN END

To illustrate the use of subroutine TERM as an example of editing ATSPGM, Example 3—20 shows the ODEINP file which was used to generate ATSPGM listed as Example 3-21. Three arrays have been dimensioned to hold the results computed by TERM, and new variables DXP and FIRSTX have been defined to fill roles analogous to DLTXPT and XPRINT.

BYTE LISTINGS SUPPLEMENT 309

- 53

(Internal page reference for manual.doc)

Example 3-20. ODEINP for TERM example

S = 10.0

DIFFfX.T,31 = Y - E*S*X 0IFF(Y.T,3) = - X*Z + X - E*Y DIFF(Z,T,3) = X*Y - E*B*Z E = 0.02 B = 8 .0/3.0 $

DIMENSKIN USER 1 (3),USER2(3),USER3(3) $

OPEN(7,FILE- 1 DATA’) K J

openCs.file-’fast 1 .STATUS- 1 NEW 1 )

READ(7, * 1 X(1),Y(l).Z(1)

READ(7, *) X(2).Y(2),Z(2)

READf7, *) X(3).Y(3).Z(3)

READ(7,») START,ENO.DLTXPT READ(7,*) DXP FIRSTX = START

1 01 oTorSaT(3 F J? } 4) 1 11 } Kh U111 START1END1DLTXPT1FIR STX. END. DXP NSTEPS = 5 WRITE(8, 1020 )

1020 F0RMAT(3X,IHt,5X,1Hx,7X,2Hx’,6X,3Hx ’ 1

+^5X,1Hy,7X,2Hy 1 ,6X,3Hy' 1 ,5X,1Hz,7X,2Hz 1 ,6X,3Hz 1 ’/) $

with doto file

1.0.3.0,5.0 0 . 0 , 0 . 0 , 0.0 - 1 . 0 , 0 . 0 , 1.0 0 . 0 ,5. 0 , 0 .5 0.5

CALL T RDrv°l!nt ing l' 1 ? 68 .®' code must be Inserted just below the

ZITe xXTr5l 2 i n8ide ATSPGM - A P ° rti0n ^ resJVor*

Example 3-21. Object program for Example 3-20 CALL RDCV(TMPS,LENVAR,NUMEQS)

C= 1 ! 00 = If(fIrst^GeTsTART+HNEW)^GO*TO*24* S *

CALL TERM(X,3,FIRSTX,USER 1 )

CALL TERM(Y,3,FIRSTX.USER 2 )

CALL TERM(Z,3,FIRSTX,USER3)

WRITE(8,1030) FIRSTX,USER1.USER2 USER 3 1030 FORMAT(1X.F3.1.1P9E8.1) lUatRZlUSER3 FIRSTX = FIRSTX + DXP GO TO 100

C== ^T =,!=!= r = / end of user inserted lines.

24 IF(KENDFG.EQ.3) KENDFG = 1

BYTE LISTINGS SUPPLEMENT

(Interna I

- 54

page reference for manual.doc)

Example 3-22. Output for Example 3-20

t x

x* x*• y

y* y* * z

z *

z

» •

0.0 1.0E+00 0.0E+00-1.0E+00 0.5 9.3E-01-1.5E-01 3.9E-01 1.0 9.6E-01 3.7E-01 1.6E+00 1.5 1.4E+00 1.4E+00 2.3E+00

3.0E+00 0.0E+00 0.0E+00 2.9E+00-5.0E-01-2.0E+00 2.3E+00-2.0E+00-4.1E+00 6 .9E-01-4.8E+00-7.4E+00

5.0E+00 0.0E+00 1.0E+0 5.1E+00 8.3E-01 2.3E+0 5.9E+00 2.3E+00 3.4E+0 7.5E+00 4.2E+00 4.1E+0

3.7 Large systems

As supplied to you, the ATOMCC translator can handle up to 900 equations. If you should have a need to increase this limit, a special program can be easily prepared.

3.8 Solving ODE’s in the complex domain

The ATOMCC compiler allows for the solution of ODE’s in the complex domain. This unique capability can be used to explore the structure of the singularities in the complex domain of non-linear problems. Linear problems, of course, have entire solution functions and therefore do not have any singularities of interest in the finite complex plane. Non-linear problems may have singularities which cover the entire complex plane.

There are essentially two types of non-linear problems; those with definite limit cycles, and those with strange attractors. For the former, the singularities form a regular lattice in the complex plane. For the latter, the singularities form structures that defy simple descriptions. The purpose of solving ODE’s in the complex domain is to study the structures formed by the singularities. The ATOMCC compiler is well suited for this task, and it is the only method extant that is capable of calculating the precise location and order of all the singularities in a finite region of the complex plane of an ODE solution.

It is simple to use the ATOMCC compiler to search for the singularities. First, you must insert a COPTION COMPLX card as the first card in ODEINP. This will cause the ATOMCC compiler to generate ATSPGM that will solve the ODE using paths into the complex domain. Secondly, you must specify the path to be taken by the solution. This path is fixed by specifying the vertices of straight-line segments in the path. The path taken must be composed of straight-line segments. The first vertex is of course the starting point of the solution. A maximum of ten vertices may be specified. These vertices are to be placed into an array called POINTS, and the number of vertices used is stored in the variable

BYTE LISTINGS SUPPLEMENT 311

- 55

(Internal page reference for manual.doc)

KPTS. The ATOMCC solution will follow the path thus specified and locate all the singularities near this path.

Since the ATOMCC solution will find all the singularities near the path specified by the user, certain problems may occur. First, the user may have by accident specified a path exactly midway between two singularities. In this event, there will be no information output from ATOMCC. The path must be slightly closer to one singularity than another; otherwise, ATOMCC cannot find the nearest singularity. Secondly, the user may have by accident specified a path that is too close to a singularity, or perhaps even a path that is directly pointed at a singularity. In this event, the ATOMCC solution will grind away and take very small steps. The information from ATOMCC beyond any such close encounter will be unreliable. In all cases, the user is well advised to change the path in the complex plane ever so slightly and make a second run to double check his results. In our experience, it is best to perform the complex integrations using double precision. Insert a COPTION DOUBLE,COMPLX card as the first card In your input. With just minimal experience, the user will find the use of ATOMCC in the complex plane to be fast and easy.

For good results, the first leg of the path into the complex domain should be directed straight up in the imaginary direction.

Do not make the first leg of the path coincident with the real axis. This introduces subtraction errors into the complex solution.

When there are complex constants In the equations, the user is entirely responsible for seeing to it that those constants are properly specified with TYPE declarations in block 2, and the values are properly entered as CMPLX(—,—) or DCMPLX(—,—) in block 3. The reason for this requirement on the part of the user is because if the facts are otherwise, the user may then be required to use an editor to delete some possibly incorrect specification written by ATOMCC. It is better to be a bit short and correct than to be long and in error.

312 BYTE LISTINGS SUPPLEMENT

dragon.doc TEXT

Programming Insight: "DRAGON" Bruce R. Land. ApriI page 137.

Screen #1

( begin Dragon curve )

CREATE CURVE ( a FORGETabIe name)

CARTESIAN OFF

: RECURS SMUDGE ; IMMEDIATE ( trick verb for recursion)

VARIABLE ANGLE VARIABLE XCOOD VARIABLE YCOOD VARIABLE STEPSIZE

: TURN ( deltangle— | turn sign*delta)

ANGLE +! ;

2 4 THRU

Screen #2

: MOVE ( — | takes a step in present turtle direction) STEPSIZE @ DUP

ANGLE @ COS * 10000 / ( r* cos of theta) XCOOD @ +

DUP ( newX) XCOOD ! ( update X)

SWAP

ANGLE @ SIN * 10000 / ( r* sine theta ) YCOOD @ +

DUP ( newY) YCOOD ! ( update Y)

DRAW.TO ;

Screen #3

: DRAGON ( sign level— | )

DUP ( level) 0=

IF ( at bottom of recursion)

DROP ( level) DROP ( sign) MOVE ( by stepsize) ELSE

OVER 45 * TURN ( getsign and turn)

1 ( newsign)

OVER 1- ( I eve 1*1 eve 1-1)

RECURS DRAGON RECURS

OVER -90 * TURN ( getsign & turn)

-1 ( newsign) ( edit to +1 for diff curve)

OVER 1- ( I eve I * I eve 1-1)

RECURS DRAGON RECURS

DROP ( input level) 45 * TURN ( getsign and turn) THEN ;

Screen #4

: DCURVE (level —| )

( init pen position)

PAGE 100 XCOOD ! 90 YCOOD ! 360 6 * ANGLE !

WHITE PENPAT XCOOD @ YCOOD @ MOVE.TO

PEN.NORMAL 1 STEPSIZE 1 1 SWAP ( level) DRAGON

WHITE PENPAT 4 10 MOVE.TO PEN.NORMAL ;

{continued)

BYTE LISTINGS SUPPLEMENT 313

matinv.bas TEXT

"The Inversion of Large Matrices" Thomas E. Phipps Jr. April, page 181.

10 REM Real-entry matrix inversion (Pan-Reif method)

20 REM Program by Thomas E. Phipps, Jr.

30 REM Ref= Proc. 17th Annual ACM Sympos. on Theory 40 REM of Computing, Providence, RI, May 1985 50 REM Random-entry matrices, single precision 60 REM Quartic modification of Newton’s iteration 70 INPUT "Run number * ";RN

80 REM N data is in line 640, D1 data in line 660 90 READ N, D1:RANDOMIZE RN:OPTION BASE 1

100 REM Can optionally insert DEFDBL A,B,E,X instruction here 110 REM A is the matrix to invert, B is the approximate inverse of A, E is the error matrix for the inverse, and X is a temporary storage matrix as explained in the BYTE article.

120 DIM A(N,N),B(N,N),E(N,N),X(N,N)

130 REM Generate random-entry A-matrix. For real data, replace 140 by an INPUT statement and input normalized data (each element of A is divided by the largest element, L). Delete line 150. B and D1 must be multiplied by L Iater.

140 FOR 1-1 TO N:FOR J-1 TO N:A(I,J)-RND(1):NEXT :NEXT

150 FOR 1-1 TO N:FOR J-1 TO N:IF RND(1)<.5 THEN A(I,J)—A(I,J)

160 NEXT :NEXT

170 CLS:TIME$-"00" ’Start clock

180 REM Eva I. t by Pan-Reif eq 8 in BYTE article

190 FOR 1-1 TO N:R0-0:S0=0:FOR J-1 TO N

200 R0=R0+ABS(A(I,J)):S0=S0+ABS(A(J,I)):NEXT J

210 X(1,I)-R0:E(1,I)-S0:NEXT I:T1«0:T2=0

220 FOR 1-1 TO N:IF X(1,I)>T1 THEN T1»X(1,I)

230 IF E(1,I)>T2 THEN T2-E(1,I)

240 NEXT I:T«1/(T1*T2)

250 REM Eva I. initial B-matrix

260 FOR 1-1 TO N:FOR J-1 TO N:B(I,J)»T*A(J,I):NEXT :NEXT :H=0 270 PRINT

"ITER."TAB(10);"E(1,1)"TAB(28);"E(1,N)"TAB(46);"B(1,1)"TAB(64);"B(1,N)"

280 REM Eva I. error matrix E

290 FOR 1-1 TO N:FOR K-1 TO N:Z=0:FOR J-1 TO N

300 Z=Z+B(I,J)*A(J,K):NEXT J:E(I,K)«-Z:NEXT K:NEXT I

310 FOR 1=1 TO N:E(I,I)-1+E(I,I):NEXT I

320 BEEP:PRINT H;TAB(6);E(1,1);TAB(24);E(1,N);TAB(42);B(1,1);TAB(60);B(1,N)

330 IF H>50 THEN PRINT "STUCK!":BEEP:BEEP:GOTO 620 340 REM Test for escape from loop

350 FOR 1-1 TO N:FOR J-1 TO N:IF ABS(E(I,J))>D1 THEN 370 360 NEXT :NEXT :GOTO 440

370 H-H+1 ’Newton’s iteration (quartic modification)

380 FOR 1=1 TO N:X(1,I)«1+(1+(1+(1+E(I,I))*E(I,I))*E(I,I))*E(I,I):NEXT

390 FOR 1=1 TO N:FOR J-1 TO N:E(I,J)=X(1,I)*E(I,J):NEXT :E(I.I)=1+E(I,I):NEXT

400 FOR 1=1 TO N:FOR K«1 TO N:W=0:FOR J-1 TO N

410 W=W+E(I,J)*B(J,K):NEXT J:X(I,K)=W:NEXT K:NEXT I

420 FOR 1=1 TO N:FOR J=1 TO N:B(I,J)=X(I,J):NEXT :NEXT

430 GOTO 280

440 REM output follows

450 T$=TIME$:BEEP:BEEP:BEEP:PRINT "Run number";RN,"Duration = ";T$

460 PRINT "No. iter.=";H,"Matrix dim.="N,"Max. error=";D1 470 INPUT "Another iteration (y,n)";C$:IF C$="Y" OR C$="y" THEN TIME$-"00":GOTO 370

480 PRINT "The maximum error was calculated by multiplying A^-1*A."

490 PRINT "As a check on the true error In the approximated inverse matrix"

500 PRINT "the maximum error in A*A^-1 will now be determined."

510 ERASE X 'recycle the temporary storage matrix for errors in A*A~-1

520 DIM X(N,N)

530 FOR 1=1 TO N:FOR J=1 TO N:FOR K-1 TO N 540 X(I,K)-X(I,K)+A(I,J)*B(J,K)

550 NEXT :NEXT :NEXT

560 REM You may print out the matrix and its inverse by placing a PRINT command for A and B in the following loop.

570 FOR 1-1 TO N:FOR J-1 TO N

580 TEST.VAL=ABS(X(I,J)):IF I-J THEN TEST.VAL-ABS(1-TEST.VAL)

590 IF TEST.VAL>MAX.ERROR THEN MAX.ERROR-TEST.VAL 600 NEXT :NEXT

314 BYTE LISTINGS SUPPLEMENT

April

610 PRINT "The max. error found this way is ";MAX.ERROR 620 END

630 REM Matrix dim. N 640 DATA 10

650 REM Error criterion D1 *

660 DATA 3E-6

BYTE LISTINGS SUPPLEMENT 315

316 BYTE LISTINGS SUPPLEMENT

mainprog.bas TEXT

Programming Insight: "Subroutine Overlays in GW-BASIC," Mike Carmichael. May, page 151. Also download routine.sub.

1000

1005

1010

1020

1030

1040

1060

1070

2000

2001

2002

2003

2020

2030

2040

2050

2060

2070

2080

2100

8000

8001

8002

8003

8010

8020

8030

8040

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

Note 8

Note 9

Note 10

Note 11

Note 12

GOSUB 10000 * * set I load switch

ON ERROR GOTO 11000

GOSUB 19900 * position currpos

IF LLOAD THEN BLOAD FL$, CURRPOS ELSE BSAVE FL$,

Note 13

Note 14

Note 15

Note 16

Note 17

Note 18

Note 19

Note 20

Note 21

Note 22

Note 23

Note 24

Note 25

Note 26

Note 27

Note 28

Note 29

Note 30

Note 31

Note 32

Note 33

Note 34

Note 35

(continued)

BYTE LISTINGS SUPPLEMENT 317

9800 ***********************************

9801 * calculate offset — length

9802 * of rem statement ( 8 bytes )

9803 * In the first line of

9804 • subroutine

9810 GOSUB 8700 * next address 9820 OFFSET = CURRPOS + 8 - NADDRESS 9830 RETURN

9900 ***********************************

9901 * split 'varrble' address or

9902 * number for storage

9903 ' 'variables expected* varrble

9904 * 'variables returned* high, low

9910 HIGH » INT(VARRBLE / 256)

9920 LOW * VARRBLE - (256 * HIGH)

9930 RETURN

10000 **********************************

10001 * BLOAD 'routine.sub’

10002 ' — file found —

10003 ' proceed to load It

10004 *

10010 ON ERROR GOTO 10500 ’error in open 10020 FL$ - D$ + FLNME$

10030 OPEN "l\ 1, FL$

10040 CLOSE 10050 RETURN

10100 '*********************************

10101 * BSAVE 'routIne.sub'

10102 ' — file not found —

10103 ' proceed to save It

10104 '

10110 LLOAO - 0 10120 RETURN

10500 ' error in opening 'routine.sub'

10510 IF ERR « 53 THEN RESUME 10100

10520 PRINT "*** error in opening FL$; M ***";: • fatal 10530 STOP

11000 **********************************

11001 ' error in BSAVE or BLOAD process

11002 '

11003 '

11020 PRINT "*** error in processing F$; " ***'•;: • fata 11030 STOP 11050 RETURN

12000 '*********************************

12001 * explanation of 'mainprog*

12002 ' and 'routine.sub *

12003 '

12010 CLS 12020 LOCATE 1,1 12030 COLOR 0,7 12040 '

12050 LOCATE 1,57

12060 PRINT "Date DATE$; " TIME$;

12070 LOCATE 2,15

12080 PRINT "A sample of a BASIC program calling a BASIC subroutine"

12090 COLOR 7,0 12110 LOCATE 5,1

12120 PRINT"'mainprog' has been written to demonstrate a method we have devised

12130 PRINT"to facilitate calling BASIC subroutines using Microsoft BASIC.

12140 PRINT ""

12150 PRINT"the modules starting at line 8000 either load or save a subroutine

12160 PRINT"consisting of two modules — starting at lines 30000 and 31000 —

12170 PRINT"in binary, and then update consecutive line pointers to agree with

12180 PRINT"the correct positions in memory "

12190 PRINT ""

12200 PRINT"subroutines at lines 30000 and 31000 are executed after they have

12210 PRINT"been loaded into memory from thei r binary file 'routine.bin*

318 BYTE LISTINGS SUPPLEMENT

May

12220 FOR I « 1 TO 2000: NEXT 12310 RETURN

19900 **********************************

19901 * position currpos to the first

19902 * pointer to be modified prior

19903 * to loading *routine.sub *

19905 IF LLOAD THEN GOSUB 19985 ELSE GOSUB 29985 19910 CURRPOS = VARPTR(F$)

19915 LOW = PEEK(CURRP0S+1)

19920 HIGH - PEEK(CURRPOS+2)

19925 CURRPOS = HIGH * 256 + LOW 19930 LOW ■ PEEK(CURRP0S+3)

19935 HIGH = PEEK(CURRP0S+4)

19940 CURRPOS = HIGH * 256 + LOW 19945 RETURN

19985 ’ set variable at end of main

19986 • program when loading subroutine 19990 F$ = "*"

*********************variabIe explanation and fill area *** ************

20002 •

20004 * CURRPOS - points to the

20005 * starting position of each

20006 * interpreted BASIC line

20007 * number in memory

20008 ' LLOAD - switch to determine

20009 • whether the subroutine is to

20010 # be loaded into memory ( 1 )

20011 * or saved onto disk ( 2 )

20012 * OFFSET - difference in decimal

20013 * between present subroutine

20014 * loading position and the

20015 # original position in memory

20016 * when its binary version was

20017 * saved

20018 * NADDRESS - next line address

20019 * to be adjusted by OFFSET

20020 * F$ - variable used to set a

20021 * flag in memory where the

20022 * subroutine will be loaded 20024 • VARRBLE - temporary storage 20026 * FLNME$ - name of subroutine

20028 * D$ - drive specification for

20029 * subroutine

20030 •

20032 *

20034 •

20036 ***************************************************** *********************

20040 *****************************************************

{ | | *******

*********************************************************** *********************************************************** **********'

20045 *****************************************************

i I I *

***********************************************************

***********

20050 ***************************************************** ******************************************************fiI I*

***********************************************************

***********************************************************

**********'

20055 'it***************************************************

***********************************************************

***********************************************************

**********'

20060 *****************************************************

***********************************************************

***********************************************************

**********' ( continued)

BYTE LISTINGS SUPPLEMENT 319

20065

•**********+*+*+ m m m m

**********

20070 ********** ***************

******************* r i 11*

***************** ********************

** i II*

******************* ****************

********************** J|{J|cl(t<M **********•

29985 * sat variable at end of routine on disk 29990 F$ - "*"

29995 RETURN

********

********************* ***********************

main program when saving

TEXT

Programming Project: "Data Compression May, page 98. Also download hufreod.me

with Huffman Coding,"

Jonathan Amsterdam.

Editor’s note: Remember to break the before attempting to compile them.

folowing modules into their Delete "======" and comments

own files inside them

Start Bitstream.DEF

DEFINITION MODULE Bitstream;

(* Used for bit-oriented I/O. Minimal facilities. *)

EXPORT QUALIFIED connect, disconnect, EOS, read readChar, wrlteChar, readCard. writeCard

write,

bitStream,

TYPE bitstream;

uses the default drive. *)

On a Mac, this procedure

PROCEDURE disconnect(bs:bitStream);

(* Disconnects stream from file. *)

PROCEDURE EOS(bs:bitstream):BOOLEAN;

(* TRUE at end of stream; for read streams onlyl *)

PROCEDURE read(bs:bitStream):BOOLEAN;

(* Reads a bit from the stream. TRUE = 1, FALSE = 0 *)

PROCEDURE write(bs:bitStreom; b:BOOLEAN)•

(* Writes a bit to the stream. *)

PROCEDURE readChar(bs:bitSt ream):CHAR;

( * ,h ~ '" ,o ° char - Th, « '•

PROCEDURE writeChar(bs:bitSt ream (* Writes the character as eight impIementation—dependent• *)

c:CHAR); consecutive

bits.

This is somewhat

PROCEDURE readCard(bs:bitSt ream):CARDINAL:

(* Reads 16 consecutive bits and translates them

f*°wr?t RE '?T iteCa !^ bs:bitStream: c: CARD INAL l Writes the cardinal as 16 consecutive bit:

Into a CARDINAL.

*)

320 BYTE LISTINGS SUPPLEMENT

END Bitstream.

Start BitStream.MOD

IMPLEMENTATION MODULE Bitstream;

(* Note: because St reams.WriteWord and St reams.ReadWord don't appear to work in MacModula-2, I do I/O with the character operations. A character code occupies bits 8-15 of a word. *)

FROM Streams IMPORT STREAM, StreamType, Connect, Disconnect, ReadChar,

WriteChar;

IMPORT Streams;

FROM Storage IMPORT ALLOCATE. DEALLOCATE;

FROM MyTerminal IMPORT fatal;

CONST maxBit = 15; (* highest numbered bit in a BITSET *)

IowCharBit = 8; (* first bit of a character *)

TYPE wordRange = [0..maxBit];

charRange = [IowCharBit..maxBit]; bitstream = POINTER TO bsRec; bsRec = RECORD

stream:STREAM; read:BOOLEAN; curWord:BITSET; curBit rcharRange;

END;

PROCEDURE connect(fiIeName:ARRAY OF CHAR; read:BOOLEAN):bitStream;

VAR bs:bitStream;

nulIVol:ARRAY[0..0] OF CHAR; done:BOOLEAN;

BEGIN

nulIVol[0] :- 0C;

NEW(bs);

bs^.read :« read;

IF read THEN

Connect(bs^.stream, streamread, (* open stream for reading *)

fileName, nullVol, 1, (* use drive #1 *)

FALSE, (* don't create if nonexistent *)

done);

IF NOT done THEN

fata I('cannot open file');

END;

bs^.curBit :* maxBit;

ELSE

Connect(bs^.stream, streamwrlte, fileName, nulIVol, 1, TRUE, done); IF NOT done THEN

fata I('cannot open file’);

END;

bs^.curBit :■ lowCharBit; bs A .curWord := {};

END;

RETURN bs;

END connect;

PROCEDURE disconnects :bi tStream);

BEGIN

WITH bs* DO

IF (NOT read) AND (curBlt <> lowCharBit) THEN (* flush the last word *) WriteChar(stream, CHAR(curWord));

END;

Disconnect(stream);

DISPOSE(bs);

END;

END disconnect;

BYTE LISTINGS SUPPLEMENT 321

PROCEDURE EOS(bs:bitStreom):BOOLEAN:

BEGIN

WITH bs~ DO IF read THEN

RETURN (curBit - maxBIt) AND Streams.EOS(stream):

ELSE

fataI(’EOS called on write bit stream'):

END; '

END;

END EOS;

PROCEDURE read(bs:bItStream):BOOLEAN;

wto In, Xi.Ao UrBit maxBit - curBit - "all bits to curBIt have been read" *) VAR c*CHAR{

BEGIN

IF NOT bs*.read THEN

fatal(’attempt to read a write bit stream’):

ELSE WITH bs* DO

IF curBit = maxBit THEN

IF NOT Streams.EOS(stream) THEN ReadChar(stream, c); curWord :* BITSET(c); curBit := lowCharBit;

END;

ELSE

INC(curBit);

END;

RETURN curBit IN curWord;

END; END;

END read;

PROCEDURE write(bs:bitStream; b:BOOLEAN);

(* init: curBit :« lowCharBit, curWord :■

curBit = "bit curBit is next to be written" *) BEGIN

WITH bs* DO IF read THEN

fata I(’attempt to write a read bit stream’);

END;

IF b THEN

INCL(curWord, curBit);

END;

IF curBit = maxBit THEN

WriteChar(stream, CHAR(curWord)); curWord := {}; curBit := lowCharBit;

ELSE

INC(curBit);

END;

END;

END write;

PROCEDURE readChar(bs:bitStream):CHAR;

(* Read 8 bits and make them into a character. In MacModula-2,

a CHAR variable is a word with bits 8-15 containing the ASCII code. *) VAR i:charRange;

char:BITSET;

BEGIN

char := \\;

FOR i := lowCharBit TO maxBit DO IF read(bs) THEN INCL(char, i);

END;

END;

RETURN CHAR(char);

END readChar;

PROCEDURE writeChar(bs:bitStream; c:CHAR);

(* see readChar for implementation details *)

VAR i:charRange;

322 BYTE LISTINGS SUPPLEMENT

BEGIN

FOR i := lowCharBlt TO maxBit DO write(bs, i IN BITSET(c));

END;

END wrlteChar;

PROCEDURE readCard(bs:bitStrearn):CARDINAL;

VAR iiwordRange;

card:BITSET;

BEGIN

FOR i := 0 TO maxBit DO IF read(bs) THEN INCL(card, i);

ELSE

EXCL(card, i);

END;

END;

RETURN CARDINAL(card);

END readCard;

PROCEDURE writeCard(bs:bItStream; c:CARDINAL); VAR i:wordRange;

BEGIN

FOR I := 0 TO maxBit DO

write(bs, i IN BITSET(c));

END;

END writeCard; BEGIN

END BitStream.

Start CharStream.DEF DEFINITION MODULE CharStream;

EXPORT QUALIFIED charStream, connect, disconnect, read, write, EOS; TYPE

charStream;

PROCEDURE connect(f1 IeName:ARRAY OF CHAR; read:BOOLEAN):charStream; PROCEDURE disconnect(cs:charStream);

PROCEDURE read(cs:charStream):CHAR;

PROCEDURE write(cs:charStream; crCHAR);

PROCEDURE EOS(cs:charStrearn):BOOLEAN;

END CharStream.

Start CharStream.MOD

IMPLEMENTATION MODULE CharStream;

(* This module supports character I/O from files. Its facilities are minimal. I wrote it using MacModuIa-2*s Streams module; it should be easy to duplicate Its behavior with whatever file system you have. *)

FROM Streams IMPORT STREAM, StreamType, Connect, Disconnect,

ReadChar, WrlteChar;

IMPORT Streams;

FROM MyTerminal IMPORT fatal;

FROM Storage IMPORT ALLOCATE, DEALLOCATE;

TYPE

charStream ■ POINTER TO STREAM;

( continued )

BYTE LISTINGS SUPPLEMENT 323

PROCEDURE connect(fiIeName:ARRAY OF CHAR; read:BOOLEAN):chorStream;

VAR cs:charStream;

nullVol: ARRAY[0..0] OF CHAR; done;BOOLEAN;

BEGIN

nuII Vo I[0] 0C;

NEW(cs);

IF read THEN

Connect(cs^, streamread, (* open stream for reading *)

fileName, nullVol, 1, use drive jjh *)

FALSE, (* don’t create if nonexistent *)

done);

IF NOT done THEN

fata I('cannot open file');

END;

ELSE

Connect(cs~, streamwrite. fileName, nullVol, 1, TRUE, done);

IF NOT done THEN

fatal('cannot open file’);

END;

END;

RETURN cs;

END connect;

PROCEDURE disconnect(cs;charStream);

BEGIN

Disconnect(cs~);

DISPOSE(cs);

END disconnect;

PROCEDURE read(cs;charStream);CHAR;

VAR c:CHAR;

BEGIN

ReadChar(cs*, c);

RETURN c;

END read;

PROCEDURE write(cs:charStream; crCHAR);

BEGIN

Wr iteChar(cs~, c);

END write;

PROCEDURE EOS(cs:charStream);BOOLEAN;

BEGIN

RETURN St reams.EOS(cs^);

END EOS;

BEGIN

END CharStream.

Start Compress.MOD

MODULE Compress;

(* File compression algorithm using Huffman coding.

Based on "Data Compression with Huffman Coding," BYTE March 1986. Copyright 1986 by Jonathan Amsterdam. All Rights Reserved.

*)

FROM CharStream IMPORT CharStream;

IMPORT CharStream;

FROM Bitstream IMPORT bitstream;

IMPORT Bitstream;

FROM MyTerminaI IMPORT ClearScreen, pause, WriteCard, WriteLn, WriteString, WriteLnString, Write;

FROM InOut IMPORT ReadString;

FROM Huffman IMPORT huffTree, huffman, readCode, writeCode, readTree, writeTree, codeSize;

FROM StringStuff IMPORT stringLen, stringCopy;

FROM Rea IInOut IMPORT FWriteReal;

(* FWriteReal writes real numbers in decimal format. If your implementation doesn't have it, substitute WriteReal. *)

324 BYTE LISTINGS SUPPLEMENT

CONST stringlen = 60;

VAR frequency:ARRAY CHAR OF CARDINAL; fiIeSize:CARDINAL;

InFileName. outFileName: ARRAY[0..stringIen] OF CHAR; hTree:huffTree;

PROCEDURE doFreq;

(* Obtain frequency count from file *)

VAR csicharStream;

BEGIN

cs :* CharStream.connect(inFileName, TRUE); freqCount(cs);

CharStrearn.disconnect(cs);

END doFreq;

PROCEDURE freqCount(cs:charSt ream); VAR c:CHAR;

BEGIN

FOR c :« 0C TO CHR(HIGH(frequency)) DO frequency[c] :* 0;

END;

c := CharStream.read(cs);

WHILE NOT CharStream.EOS(cs) DO INC(f requency[c]);

INC(fileSize); c :■ CharStream.read(cs);

END;

END freqCount;

(* read file *)

PROCEDURE doOutput;

(* Output encoded file *) VAR inStrearn:charStream; outSt ream:bitStrearn; c:CHAR;

InStream : = CharStream.connect(inFiIeName, TRUE); outStream :« BitStream.connect(outFiIeName, FALSE); BitStream.wr1teCard(outStream, fileSize); wr iteTree(outStream, hTree); c :* CharStream.read(inStream);

WHILE NOT CharStream.EOS(inStream} DO wr iteCode(outStream, hTree, c); c :* CharStream.read(inStream);

END;

CharStream.disconnect(inStream};

BitStream.disconnect(outStream);

END doOutput;

PROCEDURE computeStats;

(* Compute statistics on how much space was saved *)

VAR c:CHAR;

origBits, compBits. nChars -.CARDINAL; savings:REAL;

BEGIN

origBits :« fileSize * 8; compBits :■ 0;

nChars :■ 0;

FOR c :- 0C TO CHR(HIGH(frequency)) DO IF frequency[cl <> 0 THEN INC(nChars);

compBits :• compBits + codeSize(hTree, c) * frequency[cJ;

END;

END;

WriteStr1ng("number of different characters: ");

WriteCard(nChars, 0); WrlteLn;

WriteString("originaI file size (bits): ");

WrlteCard(origBits, 0); WrlteLn;

(continued)

BYTE LISTINGS SUPPLEMENT 325

WriteStrIng("compressed f. size (bits): ");

Wr1teCord(compB1ts, 0); WrlteLn;

Wr1teStr1ng("percent savings: ");

savings 1.0 - (FLOAT(compBits) / FLOAT(or1gBIts));

FWriteReal(savings * 100.0, 5); WriteLn;

Wr1teString("compressed size, Including bookkeeping: ");

(* add 16 bits for character, count, 10n-1 bits for tree *)

INC(compBits, 16 + 10*nChars -1);

WriteCard(compBits, 0); WrlteLn;

Wr1teString("true percent savings: ");

savings :- 1.0 - (FLOAT(compBits) / FLOAT(origBits));

FWr1teReaI(savIngs * 100.0, 5); WrlteLn;

END computeStats;

PROCEDURE doOu t f1 IeName;

(* Make the name of the output file by appending M .P" to the input file’s name *)

VAR Ien:CARDINAL;

BEGIN

len :■ str ingLen(inFiIeName); str jngCopy(outFiIeName, inFiIeName); len] :« len+1] :■ 'P*

outFiIeName outFiIeName outFiIeName

END doOut f1 IeName;

len+2J :« 0C;

BEGIN

CIearScreen;

WriteLnString("File Compression using Huffman Coding"); WriteString("Input file: ");

ReadString(InFIleName);

doOut flIeName; doFreq;

hTree :■ huffman(frequency); doOutput; computeStats; pause(’done—’);

END Compress.

Start Huffman.DEF

DEFINITION MODULE Huffman;

(* Implements the Huffman coding scheme and procedures for manipulating the code tree. *)

FROM Bitstream IMPORT bitstream;

EXPORT QUALIFIED huffTree, huffman, writeCode, readCode, writeTree, readTree codeSize;

TYPE huffTree;

PROCEDURE huffman(VAR frequency:ARRAY OF CARDINAL):huffTree;

(* construct a Huffman coding tree from the given character frequencies *)

PROCEDURE writeCode(bs:bitStream; ht:huffTree; c:CHAR);

(* Write the code for c onto bs, using ht. *)

PROCEDURE readCode(bs:bitStream; ht:huffTree):CHAR;

(* Read bits from bs until a full code is read; return the character *)

PROCEDURE writeTree(bs:bitStream; ht:huffTree);

(* Write the tree onto the stream *)

PROCEDURE readTree(bs:bitStream):huffTree;

(* Read a huffTree from the stream *)

PROCEDURE codeSize(ht:huffTree; c:CHAR):CARDINAL;

(* returns the length of the code for c *)

END Huffman.

326 BYTE LISTINGS SUPPLEMENT

Stort Huffman.MOO

IMPLEMENTATION MODULE Huffman;

(* Huffman coding algorithm, as described in "Data Compression With Huffman Coding," BYTE, March 1986.

Copyright Jonathan Amsterdam 1986, All Rights Reserved. *)

FROM Storage IMPORT ALLOCATE, DEALLOCATE;

FROM Bitstream IMPORT bitstream;

IMPORT Bitstream;

FROM MyTerminol IMPORT WriteString, WriteCard, WriteLn, fatal;

CONST maxChors = 256;

TYPE

node = POINTER TO nodeRec; nodeRec = RECORD

char:CHAR; freq:CARDINAL;

chi Id:ARRAY BOOLEAN OF node;

parent:node; (* used for encoding *)

END;

huffTree = POINTER TO htRec; htRec - RECORD

tree:node; (* the tree itself *)

leaf:ARRAY CHAR OF node; (* index by character, for encoding

*)

END;

VAR tree:ARRAY[1..maxChors] OF node; (* temporary list of trees *) nTrees -.CARDINAL;

(*** constructing the tree ***)

PROCEDURE Huffman(VAR frequency:ARRAY OF CARDINAL):huffTree;

VAR ht:huffTree;

BEGIN

ht :* initHuffTree(frequency); initTrees(ht*.leaf);

WHILE nTrees > 1 DO

insert(combineNodes(removeSmaIlest(). removeSmallest()));

END;

ht*.tree tree[1]; RETURN ht;

END Huffman;

PROCEDURE initHuffTree(VAR freq;ARRAY OF CARDINAL):huffTree; VAR i:CARDINAL;

ht :huf fTree;

BEGIN

ht :■ newHuffTree();

FOR i 0 TO HIGH(freq) DO IF freq[i] <> 0 THEN ht*.Ieaf[CHR(i)] :«

END;

END;

RETURN ht;

END initHuffTree;

newNode(CHR(i),

freq[i], NIL. NIL);

PROCEDURE in1tTrees(VAR Ieaf:ARRAY OF node);

VAR i:CARDINAL;

BEGIN

nTrees := 0;

FOR i 0 TO HIGH(leaf) DO IF Ieaf[i] <> NIL THEN Insert(Ieaf[i]);

END;

END;

END initTrees;

[continued]

BYTE LISTINGS SUPPLEMENT 327

PROCEDURE removeSmaI Iest()mode;

VAR i, smaI lest:CARDINAL;

sma I I estNode mode;

BEGIN

smaI Iest :■ 1;

FOR i 2 TO nTrees DO

IF tree[i]".freq < tree[smallest]".freq THEN smaI Iest :* I;

END;

END;

smallestNode :® tree[smaI Iest1; tree[smaI Iest] ;■ treefnTrees];

DEC(nTrees);

RETURN smallestNode;

END removeSmaI Iest;

PROCEDURE Insert(nmode);

BEGIN

INC(nTrees);

tree[nTrees] := n;

END insert;

(*** code I/O ***)

PROCEDURE writeCode(bs:bitStream; ht:huffTree; c:CHAR);

(* Write the code for c onto bs, using ht. By using recursion, we can avoid explicitly retracing the path from the root to the leaf. *)

PROCEDURE wrCode(nmode);

BEGIN

IF n".parent <> NIL THEN wrCode(n".parent);

BitStream.write(bs, n ■ n".parent",chiId[TRUEl);

END;

END wrCode;

BEGIN

IF ht".leaf[c] - NIL THEN

WriteString("no code for "); WriteCard(CARDINAL(c), 0); WriteLn; fatal('dying*);

END;

wrCode(ht".leaf[c]);

END wr1teCode;

PROCEDURE readCode(bs:bitStream; ht:huffTree):CHAR;

(* Read bits from bs until a full code is read; return the character *)

PROCEDURE rdCode(n:node):CHAR;

BEGIN

IF leaf(n) THEN

RETURN n".char;

ELSE

RETURN rdCode(n".chiId[BItStream.read(bs)1);

END;

END rdCode;

BEGIN

RETURN rdCode(ht".tree);

END readCode;

PROCEDURE writeTree(bs:bitStream; ht:huffTree);

(* Write the tree onto the stream. It is encoded as follows:

A 1 bit indicates an internal node.

A 0 bit indicates a leaf; the next 8 bits are the character code.

The tree is traversed by preorder traversal: first the root, then the left (FALSE) subtree, then the right (TRUE). *)

PROCEDURE wrTree(nmode);

BEGIN

IF leaf(n) THEN

Bitstream.write(bs, FALSE);

BitStream.writeChar(bs, n".char);

328 BYTE LISTINGS SUPPLEMENT

ELSE

BitStream.write(bs, TRUE); wrTree(n*.child[FALSEl); wrTree(n*.child[TRUE]);

END;

END wrTree;

BEGIN

wrTree(ht*.tree);

END writeTree;

PROCEDURE readTree(bs:bitStream):huffTree;

(* Read a huffTree from the stream. See writeTree for the encoding used.

Frequency information is NOT preserved. *)

VAR ht:huffTree;

PROCEDURE rdTree()inode;

VAR false, true, n:node;

BEGIN

IF Bitstream.read(bs) THEN (* an internal node *) false := rdTree(); true := rdTree(); n := newNode(0C, 0, false, true); fa Ise A .parent :* n; true*.parent ;■ n;

RETURN n;

ELSE (* a leaf *)

n := newNode(BitStream.readChar(bs), 0, NIL, NIL); ht*.Ieaf[n*.char] := n;

RETURN n;

END;

END rdTree;

BEGIN

ht :* newHuffTree(); ht*.tree :■ rdTree();

RETURN ht;

END readTree;

(*** huffTree allocation ***)

PROCEDURE newHuffTree():huffTree;

VAR c:CHAR;

ht ;huffTree;

BEGIN

NEW(ht);

FOR c := 0C TO CHR(HIGH(ht^.leaf)) DO ht*.Ieaf[c] := NIL;

END;

RETURN ht;

END newHuffTree;

(*** node stuff ***)

PROCEDURE combineNodes(n1, n2:node):node;

(* used to combine nodes when constructing the coding tree *)

VAR ninode;

BEGIN

n newNode(0C, n1*.freq + n2*.freq, nl, n2); nl*.parent :* n; n2*.parent :>= n;

RETURN n;

END combineNodes;

PROCEDURE newNode(c:CHAR; f:CARDINAL; false, true:node):node;

VAR ninode;

BEGIN

NEW(n);

WITH n* DO

char :« c; freq :» f;

chi Id[FALSE] :» false;

[continued)

BYTE LISTINGS SUPPLEMENT 329

ch1I d[TRUE] true; parent :* NIL;

END;

RETURN n;

END newNode;

PROCEDURE freeNode(nmode);

(* In the current implementation, this is never used *) BEGIN

IF n <> NIL THEN

freeNode(n^.chIld[FALSEl); freeNode(n*.child[TRUE]);

DISPOSE(n);

END;

END freeNode;

PROCEDURE Ieaf(n:node):BOOLEAN;

BEGIN

IF n = NIL THEN

fatal(* Ieaf: n NIL*);

END;

RETURN n^.child[FALSE] - NIL;

END leaf;

PROCEDURE codeSize(ht:huffTree; c:CHAR):CARDINAL;

(* returns the length of the code for c *)

VAR i:CARDINAL;

nrnode;

BEGIN

i :« 0;

n :** ht~. I eaf [c] ;

WHILE n <> NIL DO INC(i);

n :» n~.parent;

END;

RETURN 1-1;

END codeSize;

BEGIN

END Huffman.

Start MyTerminaI.DEF

DEFINITION MODULE MyTerminal;

(* Some small but useful additions to the Terminal module. *)

EXPORT QUALIFIED WriteString, WriteLn, Write, Read, ClearScreen, Beep,

WriteLnString, Writelnt, WriteCard, pause, fatal;

PROCEDURE WriteString(s:ARRAY OF CHAR);

PROCEDURE WriteLn;

PROCEDURE W rit e(c:CHAR);

PROCEDURE Read(VAR c:CHAR);

PROCEDURE ClearScreen;

PROCEDURE Beep;

PROCEDURE WriteLnString(s:ARRAY OF CHAR);

PROCEDURE Writelnt(l:INTEGER; spacesrCARDINAL);

PROCEDURE WriteCard(c, spaces CARDINAL);

PROCEDURE pause(msg:ARRAY OF CHAR);

(* Prevents the screen from blanking and returning to the Finder until the user hits a key. msg is typed out. *)

PROCEDURE fatal(msg:ARRAY OF CHAR);

(* Prints the message, does a pause, and HALTs. *)

END MyTerminaI.

330 BYTE LISTINGS SUPPLEMENT

Start MyTerminaI.MOD IMPLEMENTATION MODULE MyTerminal;

(* Some small but useful additions to the Terminal module. *) IMPORT TerminaI;

VAR powerOfTen: ARRAY[0..4] OF CARDINAL;

PROCEDURE WriteLnString(s:ARRAY OF CHAR);

BEGIN

Terminal.WriteString(s);

TerminaI.WriteLn;

END WriteLnString;

PROCEDURE Wr i telnt ( i : INTEGER; spaces -.CARDINAL) ;

BEGIN

IF i < 0 THEN

writeNum(CARDINAL(-i), spaces-1, TRUE);

ELSE

writeNum(CARDINAL(i), spaces, FALSE);

END;

END Writelnt;

PROCEDURE WriteCard(c, spaces:CARDINAL);

BEGIN

writeNum(c, spaces, FALSE);

END WriteCard;

PROCEDURE writeNum(c, spaces:CARDINAL; neg:BOOLEAN);

VAR p:CARDINAL;

i:INTEGER;

BEGIN

p := places(c);

FOR i 1 TO INTEGER(spaces) - INTEGER(p) DO TerminaI.Write(* *) ;

END;

IF neg THEN

TerminaI.Write();

END;

FOR i p-1 TO 0 BY -1 DO

Terminal.Write(CHR((c DIV powerOfTen[i]) + ORD( , 0 , )))l c :* c MOD powerOfTen[i];

END;

END writeNum;

PROCEDURE pI aces(c:CARDINAL):CARDINAL;

(* Returns the number of places c takes to print; i.e. trunc(1+log10(c)). *) VAR i:CARDINAL;

BEGIN

FOR i :*= 4 TO 0 BY -1 DO

IF (c DIV powerOfTen[i]) > 0 THEN RETURN i+1;

END;

END;

RETURN 1;

END places;

PROCEDURE pause(msg:ARRAY OF CHAR);

(* Prevents the screen from blanking and returning to the Finder until the user hits a key. msg is typed out. *)

VAR ch:CHAR;

BEGIN

Terminal.WriteString(msg);

TerminaI.Read(ch);

END pause;

PROCEDURE fatal(msg:ARRAY OF CHAR);

(continued)

BYTE LISTINGS SUPPLEMENT 331

BEGIN

Wr I teLnStrIng(msg); pause(’Hlt any key to die—*); HALT;

END fatal;

(*** Copies of Terminal procedures ***)

PROCEDURE WrlteString(s:ARRAY OF CHAR);

BEGIN

Terminal.WrlteString(s);

END WriteString;

PROCEDURE WriteLn;

BEGIN

Term!naI.WriteLn;

END WriteLn;

PROCEDURE Wrlte(c:CHAR);

BEGIN

TerminaI.Write(c);

END Write;

PROCEDURE Read(VAR c:CHAR);

BEGIN

TerminaI.Read(c);

END Read;

PROCEDURE ClearScreen;

BEGIN

TerminaI.Cl earScreen;

END ClearScreen;

PROCEDURE Beep;

BEGIN

TerminaI.Beep;

END Beep;

BEGIN

powerOfTen

’0'

:* 1;

powerOfTen

Y

:« 10;

powerOfTen

2'

100;

powerOfTen

3

1000;

powerOfTen

V

;« 10000;

Table captionEND MyTerminaI.

Start StringStuff.DEF DEFINITION MODULE StringStuff;

EXPORT QUALIFIED stringCap, charCap, stringLen, stringCopy, stringEqual PROCEDURE charCap(ch:CHAR):CHAR;

PROCEDURE stringCap(VAR s:ARRAY OF CHAR);

PROCEDURE str i ngLen(VAR s ; ARRAY OF CHAR)-.CARDINAL;

PROCEDURE stringCopy(VAR s1:ARRAY OF CHAR; s2:ARRAY OF CHAR);

PROCEDURE stringEqual(si, s2;ARRAY OF CHAR):BOOLEAN;

END StringStuff.

Start StringStuff.MOD

IMPLEMENTATION MODULE StringStuff;

332 BYTE LISTINGS SUPPLEMENT

PROCEDURE chorCop(ch:CHAR):CHAR;

BEGIN

IF (ch >- 'o’) AND (ch <- 'z') THEN RETURN CAP(ch);

ELSE

RETURN ch;

END;

END charCap;

PROCEDURE strIngCap(VAR s:ARRAY OF CHAR);

VAR I:CARDINAL;

BEGIN

FOR i :« 0 TO stringLen(s) DO s[I] charCap(s[i]);

END;

END stringCap;

PROCEDURE stringLen(VAR s:ARRAY OF CHAR):CARDINAL;

VAR i:CARDINAL;

BEGIN

FOR i := 0 TO HIGH(s) DO IF s[i] = 0C THEN RETURN i;

END;

END;

RETURN HIGH(s)+1;

END stringLen;

PROCEDURE stringCopy(VAR s1:ARRAY OF CHAR; s2:ARRAY OF CHAR); VAR i:CARDINAL;

BEGIN

i 0;

LOOP

IF i > HIGH(sl) THEN EXIT;

ELSIF i > HIGH(s2) THEN sl[i] :« 0C;

EXIT;

ELSE

s 1 [ i ] s2[i];

END;

INC(i);

END;

END stringCopy;

PROCEDURE strIngEqual(si, s2:ARRAY OF CHAR):BOOLEAN;

VAR I;CARDINAL;

BEGIN

FOR I 0 TO HIGH(sl) DO IF i > HIGH(s2) THEN RETURN s1[i] - 0C;

ELSIF s 1 [ 1 ] <> s2[i] THEN RETURN FALSE;

ELSIF sl[i] = 0C THEN RETURN TRUE;

END;

END;

RETURN TRUE;

END strIngEqua I ;

BEGIN

END StringStuff.

Start Uncompress.MOD

MODULE Uncompress;

(* Takes files encoded by Compress and restores them to their original state.

Copyright 1986 by Jonathan Amsterdam. All Rights Reserved. *)

( continued )

BYTE LISTINGS SUPPLEMENT 333

FROM CharStream IMPORT charStream;

IMPORT CharStream;

FROM Bitstream IMPORT bitstream;

IMPORT Bitstream;

FROM MyTerminaI IMPORT ClearScreen, pause, WriteCard, WriteLn, WriteString, WrIteLnString, Write;

FROM InOut IMPORT ReadString;

FROM Huffman IMPORT huffTree, huffman, readCode, readTree;

FROM StringStuff IMPORT strlngLen, stringCopy;

CONST stringlen - 60;

VAR inFileName, outFileName: ARRAY[0..stringIen] OF CHAR;

PROCEDURE doUncompress;

VAR InStreamibitStream; outStrearn;charStream;

fileSize, i;CARDINAL; (* number of characters in file *) hTreeihuffTree;

BEGIN

inStream :* BitStream.connect(inFiieName, TRUE); outStream := CharStream.connect(outFiIeName, FALSE); fileSize :■ BitStream.readCard(inStream); hTree :■ readTree(inStream);

FOR i := 1 TO fileSize DO

CharStream.write(outStream, readCode(inStream, hTree));

END;

CharStream.disconnect(outStream);

Bi tStream.disconnect(inStream);

END doUncompress;

PROCEDURE doFileNames;

VAR Ien;CARDINAL;

BEGIN

len := stringLen(inFiIeName); strIngCopy(outFiIeName, inFiIeName);

END

inFiIeName InFiIeName inFiIeName outFiIeName outFiIeName outFiIeName doFiIeNames

I en] len+ll : len+2] : “len] :■ len+1] len+2J

*P*; 0C;

» * •

= 'U’; = 0C;

BEGIN

ClearScreen;

WriteLnString("Uncompress ion program");

WriteString(' Input file (omit ".P"): ');

ReadSt ring(inFiIeName);

doFiIeNames;

doUncompress;

pause('done—•);

END Uncompress.

hufread.me TEXT

Programming Project; "Data Compression with Huffman Coding," Jonathan Amsterdam. May, page 98. Also download huffman.bix.

This is the Modula-2 source code accompanying Jonathan Amsterdam's article "Data Compression with Huffman Coding" in May BYTE 1986. This code was developed under MacModula-2 for the Mac but should be easy to convert to other Modula-2 compilers. Because the Mac allows character names longer than eight, the modules have been concatenated into one file with comments separating the different modules. You should break these modules out into their own file before attempting to compile them.

334 BYTE LISTINGS SUPPLEMENT

opticdb.c TEXT

"The Application Interface of Optical Drives," by Jeffrey R. Dulude. May, page 193.

A Write Once Corporate Personnel Database

Purpose

The purpose of this database is to provide an example of how a write once application could be developed. Code is provided only to the point of being followable for concept explanation and development. Some of the functions are available from the Optotech "C" interface library which runs on the Optotech 200 Megabyte/side write once optical disk.

Concepts

Several concepts are used here:

space is cheap — there’s no need to throw old data away. In fact, it is required to be kept in this application records occupy one or more full sectors — the write once aspect of

optical disks requires that every sector used is a full sector, partial sectors cannot be written to and then added to at a later time. So we use full sector records, even if it means adding filler at the end of our data fields, post fields — allow us to update with write once media post fields — allow us an "audit trail" back to previous revisions of data

struct

keytag j

A

char value[20J;

A

struct *keytag left;

A

struct *keytag right;

I ;

A

struct

uptag {

A

long recnum;

A

long dateti

i ;

me;

A

struct

curtag {

A

long recnum;

A

int updates;

A

char *recbody;

)

A

char *prevrec;

A

char ^search;

A

struct uptag[MAXVERS];

A

long Totrecs;

A

long Curecnm;

A

struct

Currec;

A

int Ofd;

A

int Ufd;

A

int Kfd;

A

struct

emplytag \

A

long date;

char Iname

20

»

A

char fname

‘20

»

A

char mname

‘20

»

A

char socsec[8

•

A

char addressl

201;

A

char address2

.20];

A

char city[20] char state[2]

»

9

A

A

Table captionstructure describing the self-so the key word */

Table captionthe left child of the tree */ the right child of the tree */

Table captionstucture describing each level o record number */

Table captiondate and time */

Table captionstucture describing the current

record number */

number of updates made */

pointer to the latest data */

pointer to a previous version current search criteria */

list of updates */

total records in database */

current record being worked on current record being worked on

Table captionthe original data records file

the updates

file

V

the keyword

file

*/

date of this

entry

*/

last name

*/

first name

*/

middle name

*/

Table captionsocial security number */

Table captionaddress Iine 1 */

Table captionaddress I Ine 2 */

Table captioncity */

Table captionstate */

ting key list */

update */

ecord */

*/

*/

*/

*/

(continued)

BYTE LISTINGS SUPPLEMENT 335

*/

char zip[9]; /* zip code */

char teIephone[12];

char birthpl[40]; char sex; char spousnm[40]; char beneficl[401; char benefIc2[40]; char t i 11e[15J;

Int I eve I;

Int dept; long salary;

long hiredate; char f i I Ier[to make

/* place of birth */

/* name of spouse */

/* primary beneficiary */

/* secondary beneficiary */

/* job title / position */

/* pay level / job grade */

/* department */

/* current salary */

/* employment progression history /* hiring date */

512 bytes];

*/

/* assumed functions */

/* oopen, oclose, oread, owrite, and olseek work just like their magnetic */

/* stdio counterparts */

/* available from the Optotech Optical Drive Toolkit for PC-DOS */

/* Optotech, 303-570-7500 */

int oopen(fname, mode)

int oclose(fd)

int oread(fd, buf, len)

int owrlte(fd, buf, len)

long olseek(fd, pos, mode)

long curdttmQ; int getentryfbuffer) int chgentry(buffer)

Int owrltep(fd, record, value)

int oreadp(fd, record, &value)

updtree(root, record, number)

long keymatch(root, string)

int getkey(keystr) int displayf)

Int disprec(record) int abort(msg) int menu()

report()

/* opens file "fname" in mode on optical disk */ /* returns file descriptor */

/* valid mode are 0, 1, and append (2) */

/* closes file fd previously oopened */

/* reads len bytes into buf from fd, returns */ /* number of bytes read */

/* writes len bytes into buf from fd, returns */ /* number of bytes written */

/* seeks to pos in file fd based on mode */

/* mode ** 0, from beginning */

/* mode == 1, from current position */

/* mode == 2, from end */

/* returns current date and time */

/* gets a record and puts it in buffer */

/* takes the record in buffer, collects changes */ /* to it, then returns the modified buffer */

/* writes the post field of record of file fd */ /* with the location stored in value */

/* reads the post field of record of file fd */ /* and fills value with the location*/

/* adds values to the binary key tree starting */ /* node root, uses number as the reference */

/* location back into the data files */

/* tries to find a match in the key tree for */

/* string, returning the record number if */

/* successful */

/* gets a search key and puts it into keystr */ /* an error display routine */

/* displays a record */

/* displays msg then exits to OS */

/* displays a list of choices and returns with */ /* selection number */

/* runs a report generator */

addentry()

char record[RECSIZE];

rtn = getentry(record); if(lrtn)

return 0;

else {

add(record); return 1;

updateQ

336 BYTE LISTINGS SUPPLEMENT

M ay

/* get the data */

rtn ■ chgentry(Currec.recbody);

/* set up the new data fields */ newrec » (struct *empltag) Currec.recbody; newrec->date = curdttm();

/* new find out where this record will go in the update file */ recnum = olseek(Ufd, 0L, 2)/RECSIZE;

/* put it there */ owrite(Ufd, newrec, RECSIZE);

/* now, write the previous "latest record's" postfield with */ /* the location (record number) of our recent update */

/* write it in the original file if it's the first update */

if(Currec.updates > 0)

owritep(Ufd, recnum, Currec.uptagfupdates].recnum);

e I se

owritep(Ofd, recnum, Currec.recnum);

/* now, update the Currec structure */

Currec.updates++;

Currec.updata[Currec.updates].recnum = recnum;

Currec.updata[Currec.updates].datetime * curdttm(); return 1;

getrecr(recnum) /* gets a relative record */

long recnum;

Currec.updates ■ 0;

/* seek to and get the original record */ olseek(Ofd, recnum*RECSIZE, 0); oread(Ofd, Currec.recbody, RECSIZE);

/* now follow the update chain */ postfld * oreadp(Ofd, recnum, &postval); whiIe(postfId) j

/* go to the new data and read it in */ oI seek(Ufd, postfId*RECSIZE, 0); oread(Ufd, Currec.recbody, RECSIZE);

/* now update Currec's update list */

Currec.updata[Currec.updates].recnum = postval; temp * (struct *empltag) Currec.recbody;

Currec.updata[Currec.updates].datetime * temp.date; Currec.updates++;

/* now, see if there’s another one */

postfld * oreadp(Ufd, postvaI*RECSIZE, fcpostval);

Curecnm - recnum; return 1;

getoId(I eve I) int level;

i

/* gets a previous revision of the current record */

/* and puts It In Currec.prevrec */

oI seek(Ufd, Currec.updata[I eve I].recnum * RECSIZE, 0); oread(Ufd, Currec.prevrec, RECSIZE);

\

getrevs()

/* returns the number of revisions of current record */

[continued)

BYTE LISTINGS SUPPLEMENT 337

|ozero()

/* position at the first record */

getrecr(0L);

i

aoend() /* position at the last record */

getrecr(Totrecs - 1L);

I

aetnext()

/* get the next relative record */

if(Curecnm + 1L < Totrecs) {

getrecr(Curecnm + 1L); return 1;

! else

return 0;

\

etprevQ

/* get the previous relative record

if(Curecnm - 1L >■ 0) {

getrecr(Curecnm - 1L); return 1;

\ else

return 0;

\

add(record) /* add a record to the database */

char ^record;

I

/* go to th end of the data base /*

recnum - olseek(Ofd, 0L, 2);

/* now write the data */ owrite(Ofd, record, RECSIZE);

/* now update the binary key tree with keywords and record number */

updtree(Treeroot, record, recnum);

Totrecs++;

I

long findkey(keystr) /* do a key search and return record */

char *keystr;

i

matchrec = keymatch(Treeroot, keystr);

if(matchrec «« -1L) return -1L;

else {

/* get the record and return its value */ getrecr(matchrec); return(matchrec);

I

search() /* search the database for a key match */

\

338 BYTE LISTINGS SUPPLEMENT

/

M ay

getkey(keystr);

rtn « findkey(keystr);

/* depending on result, display error or record */ i f(rtn == -1L)

display( M No match found");

e I se

disprec(rtn);

*

startup() /* perform database initialization */

/* open the database files to allow for additions Ofd « oopen("1:original.dat", OAPPEND); if (Ofd == -1) \

abort("CouIdn't open data file");

Ufd * oopen("1rupdate.dat", OAPPEND); if (Ufd =* -1) {

oclose(Ofd);

abort("CouIdn't open update file");

Kfd = oopen("1:keyfIle.dat", OAPPEND); if (Kfd == -1) {

oclose(Ofd); oclose(Ufd);

abort("Couldn*t open key file");

/★ set total record number */

Totrecs = olseek(Ofd, 0L, 2)/RECSI2E;

/* and ao to the first record */ gozero();

I

quit()

oclosefOfdh oclose(Ufd); oclose(Kfd);

*/

mainmenu()

startup();

while(l) {

switch(menu()) j case 1:

addentry(); break;

case 2:

updote(); break;

case 3:

search(); break;

case 4:

r«port(); break;

case 5:

quitQ; break;

{continued)

BYTE LISTINGS SUPPLEMENT 339

default:

M ay

error("Not a valid entry, try again"); break;

pell.bas TEXT

Mathematical Recreations: "The Pel I Ian Equation," Robert T. Kurosaka. May, page 379.

10 ****************************************

20 ’* PELLIAN EQUATION *

30 X"2 - D*Y~2 - 1 *

40 § * BY BOB KUROSAKA *

50 ****************************************

60 REM ENTER A NONSQUARE INTEGER D. THE PROGRAM 70 REM DETERMINES THE FIRST (LEAST) SOLUTION, THE 80 REM RECURSIVE FORMULAS, AND THE 2ND SOLUTION.

90 REM 100 REM 110 CLS

120 DIM P(100),Q(100),A(100) 'Hope 100 is enough!

130 INPUT "D = ";D 140 D=ABS(INT(D))

150 RD=VAL(STR$(SQR(D))) ’Remove guard digits from SQR(D)

160 IF RDoINT(RD) THEN 180

170 PRINT “D must not be a square!":GOTO 130

180 ’

19 0 ’-FIRST HALF: FIND As

200 *

210 P(1)=0:Q(1)=1:A(1)«INT(SQR(D)):N=1 ’1ST COLUMN VALUES 220 N-N+1

230 P(N)»A(N-1)*Q(N-1)-P(N-1)

240 Q(N)=(D-P(N)*P(N))/Q(N-1)

250 A(N)=INT((A(1)+P(N))/Q(N))

260 IF A(N)=2*A(1) THEN 290 270 GOTO 220

280 ’

290 *-SECOND HALF: FIND X0 AND Y0

300 *

310 CL-N-1 ’CL-CYCLE LENGTH

312 FOR I=N+1 TO 2*CL ’REPEAT CYCLE

314 A(I)=A(I-CL): "(I)=P(I-CL): Q(I)=Q(I-CL)

316 NEXT I

320 IF CL/2<>INT(.JL/2) THEN CL=2*CL 330 DIM X(CL), Y(CL)

340 *

350 •-FIND Xs AND Ys

360 ’

370 X(1)-A(1):Y(1)«1 'SET UP 1ST 2 COLUMNS

380 X(2)=A(1)*A(2)+1:Y(2)=A(2) * OF Xs AND Ys

390 IF CL<3 THEN 450

400 FOR 1=3 TO CL

410 X(I)=A(I)*X(I-1)+X(I-2)

420 Y(I)=A(I)*Y(I-1)+Y(I-2)

430 NEXT I 440 *

450 •-FIRST SOLUTION

460 *

470 X0=X(CL):Y0=Y(CL):C=2*X0 ’(X0,Y0) = LEAST SOLUTION

480 PRINT:PRINT "LEAST SOLUTION: "

490 PRINT “X = ”;X0 500 PRINT "Y = ”:Y0 510 ’

520 •-PRINT RECURSIVE FORMULAS

530 *

540 PRINT:PRINT "FORMULAS: "

550 PRINT ”X(N) = ";C;"* X(N-1) - X(N-2)"

560 PRINT ”Y(N) = ";C;"* Y(N-1) - Y(N-2)"

340 BYTE LISTINGS SUPPLEMENT

.

M ay

570 •

580 * *-CHECK X0 AND Y0

590 ’

600 PRINT:PRINT "CHECK:”

610 L-LEN(STR$(D))

620 PRINT TA8(L+3)"X~2 . ";X0*X0 630 PRINT D;"* Y A 2 - ";D*Y0*Y0 640 ’

650 ’-PRINT 2ND SOLUTION

660 *

670 PRINT:PRINT "SECOND SOLUTION; »

680 PRINT "X - ";C*X0-1;" Y - ";C*Y0 690 END

rout me.sub TEXT

Programming Insight: "Subroutine Overlays in GW-BASIC," Mike Carmichael. May, page 151. Also download mainprog.bas.

30000

30001

30002

30003

30004

30005

30006

30008

30009

30010 30020 30030 30040

31000

31001

31002

31003

31004 31010 31020 31030

Note 36

Note 37

Note 38

Note 39

Note 40

Note 41

Note 42

Note 43

Note 44

Note 45

/

/

\

Note 46

342 BYTE LISTINGS SUPPLEMENT

Chapter Notes

main program demo module MAINPROG

COMMON

DEFINT H,I,J,K,L LLOAD - 1

FLNME$ - "routine.bin": D$ - M c:"

*********************************** • main driver

GOSUB 12000 * explanation GOSUB 8000 * load * rout 1ne.sub * GOSUB 30000 • using ...

GOSUB 31000 • _ ’routine.sub*

***********************************

• normal program ending

STOP

'A*********************************

* load / save routine.sub

CURRPOS, 1000

8050 IF LLOAD THEN GOSUB 8100 8060 RETURN

8100 '**********************************

8101 * adjust binary line

8102 * pointers when loading binary

8103 * subroutines

8120 GOSUB 9800 ’ calculate offset 8130 IF OFFSET - 0 THEN RETURN 8140 WHILE PEEK(CURRPOS*1) > 0 8150 VARRBLE - NADDRESS + OFFSET 8160 GOSUB 9900 * split varrble

8170 GOSUB 8600 * store varrble

8180 CURRPOS * VARRBLE

8190 GOSUB 8700 * get next address

8200 WEND 8210 RETURN

8600 ***********************************

8601 * store next program line address

8602 * at currpos and increment

8603 * currpos

8640 POKE CURRPOS. LOW 8650 POKE CURRPOS*1, HIGH 8670 RETURN

8700 ***********************************

8701 * get next line address from

8702 * memory

8703 *

8710 LOW - PEEK(CURRPOS)

8720 HIGH - PEEK(CURRPOS*1)

8730 NADDRESS - HIGH * 256 + LOW 8740 RETURN

**************************************************************************

* routine.sub

* subroutine #1

Note: first line must consist of only line # and one * REM* statement Also, when saving or loading the binary version, * routine.sub* must be placed at the end of ’mainprog’

■ ************************************************************************* CLS

GOSUB 12000: * heading again for the fun of It LOCATE 16,20: PRINT "subroutine #1";

RETURN

* ************************************************************************* ' subroutine #2

LOCATE 17,20: PRINT "subroutine #2";

LOCATE 18,20: PRINT "returning to main program"; RETURN

BYTE LISTINGS SUPPLEMENT J4I

June

indexbpp.1st TEXT

Programming Project: "A Simple File-Indexing System," by Bruce Webster. June, page 92. Also download indexbpp.pas.

const

IndexMax

= 1000;

RecCountErr

- -2;

NewF11eCreated

■ -1;

NoError

= 0;

RecordNotFound

- 1;

NoMoreRoom

* 2;

AlreadyExists

= 3;

OutOfRange

= 4;

type

Keytype =

string[40l;

FileStr

str ing[80J;

DataRec « record

case Boolean

of

True :

(NumRecs : Integer);

False :

(Key : Keytype;

theRest : Whatever;

{ this represents the rest of your data f

end;

IndexRec ■ record

Key ;

Keytype;

Num :

Integer

end;

IndexList

array[1..IndexMax] of IndexRec

var

KList :

IndexList;

DFMe

file of DataRec;

MaxRec :

Integer;

Table captionLISTING 1. Global definitions and declarations.

compiler-specific file I/O routines }

| these procedures are specific to TURBO Pascal. If you

are using another Pascal compiler, you will need to modify them appropriately. Note that TURBO Pascal does not support the standard routines GET and PUT, but instead uses READ and WRITE. (

{$I-f { turn off I/O error checking \

procedure FRead(RNum : Integer; var Rec ; DataRec; var Error : Integer); reads record #RNum Into Rec

beg i n

If (RNum < 0) or (RNum > MaxRec) then Error OutOfRange else begin

Seek(DFIle.RNum);

Error :■ IOResult;

If Error ■ NoError then begin Read(DFile.Rec);

Error IOResult

( continued )

BYTE LISTINGS SUPPLEMENT 343

j une

end;

If Error > 0

then Error 100 + Error

end

end; j of proc FRead }

procedure FWrlt«(RNum : Integer; Rec : DatoRec; var Error : Integer

j writes record #RNum into Rec

begin

if (RNum < 0) or (RNum > MaxRec) then Error :* OutOfRange eIse begin

Seek(DFI Ie,RNum);

Error :« IOResult; if Error =» NoError then begin Write(DFile.Rec);

Error :* IOResult end;

I f Error > 0

then Error :*= 100 + Error end

end; | of proc FRead }

procedure FOpen(FIIeNome : FlleStr; vor Error : Integer);

*° ° pen F,leNom ®: it doesn't exist, creates

it with the appropriate header record

const

TurboNoFIIe - 1; J "no file" error code for TURBO Pascal

var

IOCode ; Integer;

TRec ; DatoRec;

beg i n

Assign(DFile.FileName);

Reset(DFlie);

IOCode :* IOResult; if IOCode * TurboNoFile then begin FiII Char(TRec,S1zeOf(TRec), 0 ); RewrIte(DFile);

TRec.NumRecs ;■ 0;

FWrite(0,TRec,Error); Close(DFile);

Assign(DF1 Ie,F \ Iename);

Reset(DFile);

IOCode := IOResult; if IOCode * NoError then Error := NewFiIeCreated

end;

If IOCode <> NoError then Error := 100 + IOCode; end; j of proc FOpen \

file doesn*t exist }

\

procedure FCIose(var Error :

^ cIoses file

beg i n

Close(DFile);

Error := IOResult;

I f Error > 0

then Error := Error + 100 end; { of proc FCIose |

Integer);

|$I+j | turn on I/O error checking }

LISTING 2a. File I/O routines specific to TURBO Pascal.

compiler-specific file I/O routines i these procedures are specific to UCSD Pascal. If you

are using another Pascal compiler, you will need to modify them appropriately.

344 BYTE LISTINGS SUPPLEMENT

{$1-} { turn off I/O error checking \

procedure FRead(RNum : Integer; var Rec : DataRec; var Error ; Integer); reads record #RNum into Rec

begin

if (RNum < 0) or (RNum > MaxRec) then Error :« OutOfRange else begin

Seek(DFiIe,RNum);

Error IOResult; if Error * NoError then begin Get(DFiIe);

Error := IOResult; if Error = NoError then Rec := DFiIe~

end;

if Error <> NoError

then Error := 100 + Error

end

end; { of proc FRead \

procedure FWrite(RNum ; Integer; Rec : DataRec; var Error : Integer); writes record #RNum into Rec

beg i n

if (RNum < 0) or (RNum > MaxRec) then Error := OutOfRange else begin

Seek(DF?le.RNum);

Error :■ IOResult; if Error ■ NoError then begin DFi Ie~ Rec;

Put(DFlie);

Error :■ IOResult end;

if Error > 0

then Error := 100 + Error

end

end; { of proc FRead }

procedure FOpen(F1 IeName : FileStr; var Error : Integer);

tries to open FileName; if it doesn’t exist, creates it with the appropriate header record

\

const

UCSDNoFile - 1; { “no file" error code for UCSD Pascal \

var

IOCode : Integer;

TRec : DataRec;

beg i n

Reset(DF1 Ie,FiIeName);

IOCode :« IOResult;

if IOCode = UCSDNoFile then begin \ file doesn’t exist }

FiI IChar(TRec,SizeOf(TRec),Chr(0));

Rewr1te(DFiIe,F1 IeName);

TRec.NumRecs 0;

FWrite(0,TRec,Error);

CIose(DFiIe,Lock);

Reset(DFile,FileName);

IOCode :■ IOResult;

If IOCode - NoError

then Error :■ NewFiIeCreated

end;

if IOCode <> NoError then Error 100 + IOCode; end; { of proc FOpen }

procedure FCIose(var Error : Integer);

closes file

[continued)

BYTE LISTINGS SUPPLEMENT 345

beg i n

Close(DFile.Lock);

Error :■ IOResult; if Error > 0

then Error :« Error + 100 end; j of proc FCIose (

{$I+| { turn on I/O error checking \

LISTING 2b. File I/O routines specific to UCSD Pascal.

procedure SortIndexList;

sorts the array KLlst using a selection sort technique var

I.J.MIn : Integer;

Temp ; IndexRec;

beg l n

for I :« 1 to MaxRec-1 do begin Min :« I;

for J :* 1+1 to MaxRec do

if KList[J].Key < KList[Min].Key then Min :» J;

Temp KList[I] ;

KLlst[I] :« KLIst[Min];

KLlst[Min] :• Temp end

end; { of proc SortIndexList }

procedure InitStuff(FIleName

FileStr; var Error : Integer);

sets everything up for indexing system. This assumes that there are no more than IndexMax (-1000) records, and that the records are numbered 1..IndexMax. Record #0 is the header record and is used to store the current number of records actively being used In the file

var

Indx,TErr : Integer;

TRec : DataRec;

begin

Error := NoError;

FOpen(FlIeName,Error); if Error <* NoError then begin MaxRec := 0;

FRead(0,TRec,TErr);

Error :» TErr;

MaxRec :* TRec.NumRecs; for Indx :* 1 to MaxRec do begin FRead(Indx,TRec.TErr); if TErr > 0 then Error :« TErr;

KList[Indxl.Key :■ TRec.Key; KList[indx].Num :■ Indx end;

SortlndexList

end

end; { of proc InitStuff {

procedure CleanUpStuff(var Error ; Integer);

this just does an orderly shutdown and should be called before you leave your program (or open another data file)

var

TRec : DataRec;

begin

TRec.NumRecs :» MaxRec; { save out # of records \

FWrite(0,TRec.Error);

FCIose(Error)

end; { of proc CleanUpStuff \

LISTING 3. Initialization and cleanup routines.

346 BYTE LISTINGS SUPPLEMENT

function FindKey(Key : Keytype) : Integer;

looks for Key in KList; returns location in KList if found; otherwise returns - 1

\

var

L,R,Mid : Integer;

beg i n

L :« 1; R :« MaxRec; repeat

Mid (L+R) div 2; if Key < KList[Mid].Key then R :« Mid-1 else L :* Mid+1

until (Key * KList[Mid].Key) or (L > R);

If Key « KList[MidJ.Key then FindKey := Mid else FindKey :* -1

end; j of proc FindKey }

procedure GetRecord(Key ; Keytype; var Rec ; DataRec;

^ var Error : Integer);

looks through KList for Key; if found, returns in Rec.

It and the routines that follow assume the procedure Seek for random access of the file of records.

}

var

Item : Integer;

beg i n

Error := NoError;

Item FindKey(Key);

1f Item > 0

then FRead(KList[Item].Num,Rec,Error) else Error :* RecordNotFound end; j of proc GetRecord j

procedure PutRecord(Rec : DataRec; var Error : Integer);

writes Rec out to the file. If a record with that key already exists, then overwrites that record; otherwise, adds the record to the end of the file.

If there's no more room for records, exits with an error code

\

var

Item : Integer;

begin

Error :■ NoError;

Item :■ F1ndKey(Rec.Key);

If I tern >■ 0

then FWrite(KList[I tern].Num,Rec,Error) else if MaxRec < IndexMax then begin MaxRec :■ MaxRec + 1;

FWrite(MaxRec,Rec,Error);

KListTMaxRecl.Key :■ Rec.Key;

KList[MaxRecJ.Num ;- MaxRec;

SortlndexList

end

else Error ;■ NoMoreRoom end; j of proc PutRecord \

LISTING 4. Basic record access routines.

procedure AddRecord(Rec ; DataRec; var Error : Integer);

adds a record to the file. If a record with the same ^ key already exists, then exits with an error code

var

Item ; Integer;

begin

Error NoError;

( continued)

BYTE LISTINGS SUPPLEMENT 347

June

Item :■ FIndKey(Rec.Key);

If Item > 0

then Error :■ AlreadyExIsts else PutRecord(Rec.Error) end; { of proc AddRecord \

procedure DeIeteRecord(Key : Keytype; var Error : Integer);

deletes the record with 'Key* by copying the last record In the file to that slot, then modifies KLIst by shuffling a I I the key entrles up

}

var

Item,Last.Max,MVal : Integer;

TRec ; DataRec;

begin

Error :* NoError;

Item ;■ FIndKey(Key);

If Item - -1

then Error :■ RecordNotFound else begin

Max 1; MVal :■ KList[Max].Num; for Last :■ 2 to MaxRec do

If KLIst[Last].Num > MVal then beain Max :■ Last; MVal :■ KList[Last].Num end;

If Max <> Item then begin

FRead(MVal,TRec,Error); } get last record In file }

FWrIte(KList[Item].Num,TRec,Error); { write over it \

KLIst[Max].Num :« KList[Item].Num end;

for Last Item to MaxRec -1 do \ delete KLIstfltem] *

KLIst[Last] :« KLIst[Last+1];

MaxRec :» MaxRec - 1 { adjust § of records }

end

end; j of proc DeleteRecord }

LISTING 5. Higher-level record access routines.

hI Ibert.bas TEXT

Programming Insight: "Hilbert Curves Made Simple," by Michael Ackerman. June, page 137.

1 GOTO 1000

2 REM *************************

3 REM * HILBERT *

4 REM * *

5 REM * BY MICHAEL ACKERMAN *

6 REM * *

7 REM * 8/27/85 *

8 REM *************************

100 RDER * RDER - 1

110 TURN - - TURN

120 TEMP » DY:DY - - TURN * DX:DX - TURN * TEMP

130 IF RDER > 0 THEN GOSUB 100

140 X - X + DX:Y « Y + DY: HPLOT TO X,Y

150 TURN - - TURN

160 TEMP « DY:DY = - TURN * DX:DX - TURN * TEMP

170 IF RDER > 0 THEN GOSUB 100

180 X = X + DX:Y « Y + DY: HPLOT TO X,Y

190 IF RDER > 0 THEN GOSUB 100

200 TEMP - DY:DY - - TURN * DX:DX « TURN * TEMP

210 TURN * - TURN

220 X = X + DX:Y « Y + DY: HPLOT TO X,Y

230 IF RDER > 0 THEN GOSUB 100

240 TEMP « DY:DY - - TURN * DX:DX « TURN * TEMP

250 TURN * - TURN

260 RDER = RDER + 1

270 RETURN

1000 TEXT : HGR : HCOLOR* 3: INPUT"ORDER <1-7>";RDER

348 BYTE LISTINGS SUPPLEMENT

J me

1010 POKE 49234,1

1020 DY « 192 / 2 * RDER

1030 TURN «= - 1

1040 DX * X - Y - 0

1050 HPLOT X,Y

1060 GOSUB 100

1070 END

froctol.lib TEXT

"Musical Fractals," Charles Dodge ond Curtis R. Bahn.

June, page 185. All the programs mentioned in one TEXT file.

1 REM WHITE.BAS is in MSX BASIC with MUSIC MACRO

2 REM commands for the Yamaha CX5-M music computer

10 _INIT:_INST(1)

20 X-RNO(-TIME)

30 FOR X - 1 TO 25

35 REM notes in range of 25 to 120

40 N - INT(RND(1)*95)+25

45 REM lengths In range of 1 to 4

50 L - INT(RND(1)*4)+1

60 _PHRASE(1,"L-L;","N-N;")

70 NEXT X

80 JPLAY(I.I)

90 _WAIT(1)

100 INPUT"AGAIN";DD:GOTO 80

1 REM BROWN.BAS is in MSX BASIC with MUSIC MACRO

2 REM commands for the Yamaha CX5-M music computer

10 _INIT: _INST (1)

20 X-RND(-TIME)

30 N-60:L-2

40 FOR X - 1 TO 25

45 REM R varies the range of the distribution

50 R-3:GOSUB 130:N=N+D

60 IF N>120 or N<25 THEN N«N-2*D

70 R-.667:GOSUB 130:L-L+D

80 IF L<1 OR L>4 THEN L-L-2*D

90 _PHRASE(1."L-L;".N»N;")

100 NEXT X

110 _PLAY(1,1):_WAIT(1)

120 INPUT"AGAIN";DD:GOTO 110

130 REM BROWNIAN ROUTINE

140 S-0:REM S is Sum

150 FOR I - 1 TO 12

160 S-S+RND(1)

170 NEXT I

180 D-INT(R*(S-6))

190 RETURN

1 REM 10VERF.BAS is in MSX BASIC with MUSIC MACRO

2 REM commands for the Yamaha CX5-M music computer

10 _I NIT: _I NST (1): IL-8: LN-16: S-60: X=RND ( -TIME )

20 FOR X - 1 TO 25

30 D-N:GOSUB 130

40 N-D:SN-N+S

50 D-L:GOSUB 130

60 l-D:SL-LL+1

70 _PHRASE(1,"L«SL;","N*SN;“)

80 NEXT X

90 _PLAY(1,1)

100 _WAIT(1)

110 INPUT"AGAIN";DD

120 GOTO 90

130 REM 1/F ROUTINE

135 REM L Is last value. K Is 1/2 poss values. PR0BIT-1/K

140 L-D:D-0:K-16:PROBIT-.03125

150 J-INT(L/K)

(continued)

BYTE LISTINGS SUPPLEMENT 349

]une

160 IF J-1 THEN L-l-K 170 U-RND(I)

180 IF U < PROBIT THEN J-1-J

190 D-D+J*K

200 K-K/2

210 PR0BIT-PR08IT*2

220 IF K>1 THEN GOTO 150

230 RETURN

1 REM VARIATN.BAS is in MSX BASIC with MUSIC MACRO

2 REM commands for the Yamaho CX5-M music computer

4 REM

5 REM*************************************************************

6 REM Copyright 198$ Curtis Bohn, Creative Associates Inc.

7 REM*************************************************************

8 REM

10 CLS

20 DIM P(6):DIM AP(6):DIM BP(36):DIM CP(216)

30 DIM D(6):DIM AD(6):DIM BD(36):DIM CD(216)

40 DT-0:CC-0:BC-0:AC-0:GP=0: R-0:HP-100

50 _INIT:_INST(1):_INST(2):_INST(3)

100 INPUT"HOW MANY NOTES IN SET?"; PN:IF PN>6 OR PN<1 THEN GOTO 100

110 PRINT"INPUT";PN;"PITCH RELATIONSHIPS"

120 FOR LOOP-1 TO PN

130 INPUT P(LOOP):IF ABS(P(LOOP))>12 THEN PRINT"TOO BIG":GOTO 130

135 IF GP<P(LOOP)THEN GP-P(LOOP):IF BP>P(LOOP)THEN BP-P(LOOP)

140 NEXT LOOP

150 PRINT "INPUT";PN;"TIME RELATIONSHIPS"

160 FOR LOOP-1 TO PN

170 INPUT D(LOOP)

180 NEXT

185 INPUT"BROWNIAN RANDOMIZER APPLIED TO PITCH (1 OR 0)";R:IF R>2 GOTO 185

190 PP-ABS(BP)+ABS(GP)

195 LP-HP-(3*GP):SK»100/(3*PP)

200 REM FRACTAL ROUTINE

205 PRINT"COMPUTING FRACTAL"

210 FOR A-1 TO PN

220 AP(A)-P(A)+RC:AD(A)-D(A)

230 FOR B-1 TO PN

240 BC-BC+1:IF R -1 THEN GOSUB 700

245 BP(BC)-AP(A)+P(8)+RC:BD(BC)-D(B)*D(A)

250 FOR C-1 TO PN

260 CC-CC+1;IF R-1 THEN GOSUB 700

270 CP(CC)=BP(BC)+P(C)+RC:CD(CC)=D(C)*BD(BC):DT»DT+CD(CC)

280 NEXT C: NEXT B: NEXT A

290 TS-255/DT

300 REM PLAYING ROUTINE

310 BC-0:CC-0

320 FOR A-1 TO PN

330 _SOUND(1.1.AP(A)+LP):CIRCLE(TC.90-(AP(A)*SK)).6

340 FOR B= 1 TO PN

345 BC=BC+1

350 _S0UND(2,1,BP(BC)+LP):CIRCLE(TC,90-(BP(BC)*SK)),3

360 FOR C- 1 TO PN

370 _SOUND(3,1.CP(CC)+LP):CIRCLE(TC.90-(CP(CC)*SK)).1

380 FOR LOOP-1 TO CD(CC):TC-TC+TS

385 REM all ploy statements here for mono playback

390 _SOUND(3,0,CP(CC)+LP)

400 NEXT LOOP

410 NEXT C: NEXT B: NEXT A

420 _STOP(1): _STOP(2): _ST0P(3)

430 INKEY$=DD$: IF DD$="" THEN GOTO 430

440 GOTO 300

500 REM BROWNIAN ROUTINE

510 S=0

520 FOR I- 1 TO 12

530 S«S+RND(1)

540 NEXT I

550 RC»INT(2*(S-6))

560 RETURN

1 REM RANDOM.BAS is in MSX BASIC with MUSIC MACRO

2 REM commands for the Yamaha CX5-M music computer

4 REM

350 BYTE LISTINGS SUPPLEMENT

•^o<k)-ac»(ooonio>c^>-*o (DCovjo>ui^oifo-*0(Da)Nio)Oi>oiio-»o©oovio)cn^O(ro^O(DCa>40)Oi-M^N)^0(oa)Nio>mA04is)-*ooooooooo 000)0000000000 oooooooooooooooooooooooooooooooooooooooooooooooooo

June

REM*******************************************************

REM Copyright 1986 Charles Dodge, North Cape Music REM*******************************************************

REM

CLS

DIM AP(10):DIM BP(100):DIM CP(255):DIM DP(2,255):TC«20 DIM BD(10):DIM CD(100):DIM DD(255)

DT-0:DC=0:CC=0:BC=0:AC=0:DIM CT(4)

DIM CF(4,12):DIM LAST(4):KN=50 X-RND(-TIME):LAST(1)«INT(RND(1)*32)

_INIT:_INST(1):_INST(2):_INST(3):_INST(4)

_MODI(1,5)MODI(2,40):_MODI(3,15):_MODI(4,16)

FOR LOOP = 1 TO 4

PRINT"ENTER PITCH CLASS LIMIT OF LEVEL #**;LOOP INPUT PL(LOOP)

IF PL(L00P)>6 THEN PRINT"TOO BIG":GOTO 120 IF PL(L00P)<1 THEN PRINT"TOO SMALL*' :GOTO 120 NEXT LOOP L-1

FOR A * 1 TO 10 GOSUB 820

IF CT(L)>PL(L) THEN GOTO 230

AC-AC+1

AP(A)*LAST(L)

NEXT

REM FRACTAL ROUTINE

SCREEN 2

FOR A = 1 TO AC

CIRCLE(DI/2.197-(AP(A)*5+20)),9 LAST(2)-AP(A)

FOR B = 1 TO 10 L-2

GOSUB 820

IF CT(L)>PL(L) THEN GOTO 570 BI«BI+1:BP(BI)*LAST(L)

CIRCLE(DI/2,197-(BP(BI)*5+20)),6 LAST(3)*BP(BI)

FOR C * 1 TO 10 L-3

GOSUB 820

IF CT(L)>PL(L) THEN GOTO 550

CI-CI+1:CP(CI)-LAST(L):IF CI-255 THEN AC«A:GOTO 590

CIRCLE(DI/2,197-(CP(CI)*5+20)),3

LAST(4)-CP(CI)

FOR D - 1 TO 10 L-4

GOSUB 820

IF CT(L)>PL(L) THEN GOTO 530 DI-DI+1

CIRCLE(DI/2,197-(LAST(L)*5+20)),.5 IF DI>255 THEN GOTO 500 DP(1,DI)*LAST(L):GOTO 520 DP(2,DI-255)«LAST(L)

IF DI*510 THEN AC - A: GOTO 590 DC*DC+1:NEXT D

DD(CI)«DC:DC«0:CT(L)*0:GOSUB 1020 CC-CC+1:NEXT C

CD(BI)-CC:CC-0:CT(L)-0:GOSUB 1020

i • kiry t p

BD(A)*»BC:BC=0:CT(L)=0: GOSUB 1020 NEXT A

LINE (0,0)-(255,0):LINE (255,0)-(255,197):

LINE(255,197)-(0,197):LINE(0,197)-(0,0)

DD$»INKEY$:IF DD$»"" GOTO 600 REM PLAY LOOPS FOR A - 1 TO AC _SOUND(1,1,AP(A)+KN)

FOR B - 1 TO B0(A):BC-BC+1 _S0UND(2,1,BD(BC)+KN)

FOR C - 1 TO CD(B):CC*CC+1 IF CC>255 GOTO 770 _S0UND(3,1,(CP(CC)+KN)

FOR D - 1 TO DD(C):DC-DC+1

IF DC>255 GOTO 740

_S0UND(4,1,DP(1,DC)+KN):GOTO 760

.SOUND(4,1,DP(2,DC-255)+KN)

(i continued )

BYTE LISTINGS SUPPLEMENT 351

750 IF DC-510 THEN GOTO 770

760 NEXT D:NEXT C:NEXT 8:NEXT A

770 _STOP(1):_ST0P(2):_ST0P(3):_ST0P(4)

780 DD$-INKEY$:IF DD$-"" GOTO 780

790 BC-0:CC-0:DC-0

800 GOTO 610

820 REM 1/F ROUTINE

830 LL-LAST(L):NP-0:K-16:PROBIT-.03125

840 J-INT(LL/K)

850 IF J-1 THEN LL-LL-K

860 U-RND(I)

870 IF U<PROBIT THEN J-1-J

880 NP«NP+J* *K

890 K-K/2

900 PROBIT - PROBIT*2

910 IF K>-1 GOTO 840

920 LAST(L)»NP:TEST-NP

930 REM PITCH CLASS TEST

940 FOR I - 0 TO 11

950 IF INT((TEST+I)/12)-(TEST+I)/12

THEN CF(L,I)-1:GOTO 920 960 NEXT I

970 CT(L)-0

980 FOR I - 0 TO 11

990 CT(L)»CF(L,I)+CT(L)

1000 NEXT I

1010 RETURN

midi.arc BINARY

"MIDI Programming" by Donald Swearingen.

June, page 211. All the programs from the article. Requires ARC.

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

TIMEBASE = 120.0; TEMPO = 100.0;

Note 8

MIN_MIDI_DATA = 0; MAX_MIDI.DATA =127;

Note 9

Note 10

Note 11

Note 12

Note 13

Note 14

Note 15

Note 16

Note 17

Note 18

Note 19

Note 20

Note 21

Note 22

Note 23

Note 24

Note 25

Note 26

Note 27

Note 28

Note 29

Note 30

TRACK_DATAF11E_SIZE = 4096; { MPU-401 track data file \

FILENAMEJ.EN = 14; \ MSDOS filename length \

RECORD_LEN = 128; \ MSDOS record length }

DIGITS : j Hex conversion digits }

array[0..15] of char =

'0123456789ABCDEF';

LIST2.pas

type

hex_str = string[2]; track_event_type =

(

OVFL,

MARK,

MIDI,

MIDI.RS,

UNKNOWN

);

Result of byte—>hex conversion { MPU-401 Track event type

{ Timing Overflow I MPU mark

MIDI using curr. running status MIDI setting new running status { Undefined track event

track_event = { Single track event

record

time : byte; { Event relative time

mess : array[1..3] of byte; \ Event directive

end;

track_event_bIock = { Track event access environment

record

running_status : byte;} Current track running status event_len : 1..4;{Event Iength,incIuding timing byte event_type ; track_event_type; event : track_event; end;

track_data_stream = { In memory track data stream file

array[1..TRACKJDATAFILE.SIZE] of byte; track_data_bIock ={ track data stream access environment record

tds : track_data_stream; { track data

{ track data read pointer tds_ptr : 1..TRACK_DATAFILE_SIZE;

edat ; boolean; { indicates end of track data

curr : track_event_block; { current track event

end;

const

{ Track overflow event constant OVFl_EVENT : track_event_bIock =

( { used to insert timing spacers

running_status:0; { into Track Data Stream

event_len:1; event_type:OVFL; event:

(

time:MAX_TIMING_COUNT; mess:(0,0,0)

\

}

I

\

{

\

\

i

\

\

I

I

LIST3.PAS

{ Return true if input is a MIDI status byte

function midi_status(midi_doto_byte:byte):boo I eon; begin

if (midi_doto_byte > MAX_MIDI_DATA) then midi_stotus:*true e I se

(WMtiMMCdl

BYTE LISTINGS SUPPLEMENT 351

midi.status:«false;

end;

| Return the channel # from a MIDI status byte

function midi_chan(running_status:byte):byte; begin

mldI.chan:«runnIng.status and 15; end;

| Return the command portion of a MIDI status byte

function midi.cmnd(running.status:byte):byte; begin

midi.cmnd:*(running.status shr 4) and 7; end;

{ Return # of data bytes associated ^ with a given MIDI status byte

function nmdat(running.status:byte):byte; beg i n

if (midi.cmnd(running.status) In

[PROGRAM.CHANGE, AFTER.TOUCH.P]) then nmdat:*1 e I se

nmdat:«2; end;

| Limit input to valid MIDI data range

function mldi.data.limit(midi.data.byte:integer):byte; beg i n

if midi.data.byte < MIN.MIDI.DATA then midi.data.limit:-MIN.MIDI.DATA else If midi.data.byte > MAX_MIDI DATA then midi.data.limit:-MAX.MIDI.DATA e I se

midi.data.Iimit:=mIdi.data.byte; end;

LIST4.PAS

| Reset status and pointer variables In track data block

procedure reset.track.data(var tdt:track.data block); beg i n

with tdt do beg i n

tds.ptr:*1; edat:«fa Ise; cur r . runn i ng.status :*=0; cu r r.event.type:-UNKNOWN; end; end;

j Load track data stream from user ^ specified file into track data block

procedure Ioad.track.data(var tdt;track.data.bIock); var

tdf : File;

tdfn : string[FILENAME.LEN]; begin

reset.track_data(tdt); write(*Track data filename: *); readIn(tdfn); assign(tdf,tdfn); reset(tdf);

bIockread(tdf,tdt.tds.TRACK.DATAFILE.SIZE div RECORD LEN); c lose(tdf);

354 BYTE LISTINGS SUPPLEMENT

end;

{ Save track data stream from track data block to user specified file

procedure save_track_data(tdt:track_data_bIock); var

tdf : File;

tdfn : string[FILENAME_LEN]; beg i n

write(’Track data filename: '); readIn(tdfn); assign(tdf,tdfn); rewrite(tdf);

bIockwrite(tdf,tdt.tds,TRACK_DATAFILE_SIZE div RECORD_LEN);

c lose(tdf);

end;

\ Return current track data byte from track data block

\

function this_byte(tdt:track_data_bIock):byte; begin

this_byte:*tdt. tds[tdt.tds_ptr]; end;

{ Advance pointer to next track data byte in track data block

\

procedure advance(var tdt:track__data_bIock); beg i n

tdt. tds_pt r :=tdt. tds_.pt r+1; end;

{ Convert byte to hexadecimal ASCII string

Table captionfunction itox(i:byte): hex_str; beg i n

i tox

■0'

:=chr(2);

itox

Y

:=DIGITS[i

div

16 ]

itox

2'

:“DIGITS[i

mod

16]

Table captionend;

{ Dump track data stream in hexadecimal format

procedure dump_track_data(var tdt: track__data_b lock) ; label return; var

n,st,off : integer; begin

wr i teIn('Track Data Stream Dump...'); wr I teIn; write(' ');

for n:=0 to 15 do wr i te(itox(n):4); wr i teIn; n :-0;

while (n < TRACK_DATAFILE__SIZE div 16) do beg i n st:*n*16;

wr ite(itox(st div 256):2,itox(st mod 256):2,' '); for off:«0 to 15 do beg i n

wr i te(itox(ord(tdt.tds[st+off+ 1])):4); if (tdt.tds[st+off+1] - DATA_END) then goto return; end;

wr I teIn; n :«n+1; end; return: wr iteIn; end;

( continued )

BYTE LISTINGS SUPPLEMENT 355

Chapter Notes

LIST1.PAS

const

TIMING.OVERFLOW * 248; { MPU-401 Constants \

NOP = 248;

MEASURE.END = 249;

DATA_END = 252;

MAX_TIMING — COUNT = 240;

\ MPU-401 Default Timebase \ | MPU-401 Default Tempo j

{ Minimum MIDI Data Value f | Maximum MIDI Data Value \

NOTE_OFF =0; { MIDI Commands }

NOTE_ON = 1;

AFTER_TOUCH_K = 2;

CONTROL_CHANGE = 3;

PROGRAM_CHANGE = 4;

AFTER_TOUCH_P = 5;

PITCH_WHEEL = 6;

SYSTEM.EXCLUSIVE = 7;

MIDI_MESS_TEXT : { MIDI Command Text Strings }

array[0..7] of string[20] =

('Note Off*,

’Note On *,

’After Touch (key)’,

*Cont roI Change *,

’Program Change’,

’After Touch (poly)',

’Pitch Wheel’,

'System ExcI usive’);

ERR - -1; { Function error flags \

NOERR =0; 5

352 BYTE LISTINGS SUPPLEMENT

June

LIST5.PAS

{Fill in the message bytes of the current Track Event in a Track Data Block

I

procedure track.event.message(var tdt:track.data.block); var

I : byte; { index counter } label return; beg i n

with tdt.curr do beg I n

case this.byte(tdt) of

NOP, MEASURE.END, DATA.END: begin

event_type:-MARK;

If (thls_byte(tdt) - DATA_END) then tdt.edat:-true;

event.mess[event.Ien]:«this_byte(tdt);

event.l en :-event.l en+1;

advance(tdt);

goto return;

end;

128..239: { MIDI status byte \ beg I n

runningstatus:-this_byte(tdt); event_type:-MIDI_RS; event.mess[event.Ien]:-this_byte(tdt); event.len:-event.Ien+1; advance(tdt); end; e I se

event_type:-MIDI; end; { case }

{ fill in MIDI data bytes }

for i:«1 to nmdat(tdt.curr.running.status) do beg i n

event.mess[event.Ien]:-this_byte(tdt); event.I en:-event.Ien+1; advance(tdt); end;

end; { with tdt.curr } return: end;

{ Advance to the next Track Event in a Track Data Block

}

procedure next.track.event(var tdt:track.data.bIock); label return; beg i n

If (tdt.edat) then { end of data { goto return; with tdt.curr do beg i n

event.len:*1; { count event time } case this.byte(tdt) of TIMING.OVERFLOW: beg i n

event.type:=OVFL;

e v e n t.tim e:-MAX.TIMING.COUNT;

advance(tdt);

goto return;

end;

0..239: { timing byte } begin

event.time:»this.byte(tdt); advance(tdt); track.event.message(tdt); end;

end; { case ( end; { with tdt.curr }

356 BYTE LISTINGS SUPPLEMENT

return:

end;

I me

{ Store a Track Event In a designated Track Data Block \

procedure store.track.event(var tdo:track.data.bIock;

ebIk:track.event.block);

var

I : byte; { index counter } beg i n

case eblk.event.time of MAX.TIMING.COUNT: beg i n

tdo.tds[tdo.tds.pt r]:«TIMING.OVERFLOW;

advancedtdo);

end;

0..239:

beg I n

tdo.tds[tdo.tds.ptr]:*ebIk.event.time; advance(tdo);

for I:*1 to ebIk.event.len - 1 do beg I n

tdo.tds[tdo.tds.ptr]:=ebIk.event.mess[i]; advance(tdo); end; end;

end; { case \ end;

{ Display a track event on the user console

procedure dIsp.event(ebIk:track.event.block); var

I : byte; { index counter } label return; beg i n

with eblk do begin

wr i te(event.time:4); if (event.len * 1) then beg i n

write(' Timing Overflow*:16);

goto return;

end;

if (event.mess[1] in [NOP,MEASURE.END,DATA.END]) then beg I n

case event.mess[1] of NOP : beg i n

wr i te(’NOP*:16); goto return; end;

MEASURE.END: beg i n

write(’Measure End':16);

goto return;

end;

DATA.END: beg i n

wr i te(’Data End’:16);

goto return;

end;

end; {case} end; |if{ i :-1;

If (midl.status(event.mess[1])) then beg I n

write(MIDI.MESS.TEXT[midi.cmnd(event.mess[1])]:16);

I:*I+1;

end

e I se

wr 1te(* *:16);

while (i <■ (event.len - 1)) do begin

wr1te(event.mess[i]:4); i:-l+1;

(continued)

BYTE LISTINGS SUPPLEMENT 357

end;

end; j with eblk } return: wrIteIn; end;

| Display all of the Track Events In a Track Data Block

procedure dIsp_track_data(var tdt:track_data_bIock); var

time ; real; { Actual time of current track event j beg i n

time:=0.0;

reset_track_data(tdt); while not(tdt.edat) do begin

next_track_event(tdt); tlme:*tIme+tdt.curr.event.time; wr Ite( ((time*60)/(TIMEBASE*TEMPO)):8:3 ); disp_event(tdt.curr); end; end;

LIST6.PAS

j Return offset of MIDI key data In Track Event message, If present

function midi_key_offset(var ebIk:track_event_bIock;

chan rbyte):integer;

begin

midijkey_offset:»ERR; { default return value \ with eblk do begin

if ((event_type In [MIDI, MIDI_RS]) and (midi_cmnd(running_status)

In [NOTE.OFF, NOTE_ON, AFTER_TOUCHJ<]) and (midi_chan(running_status) * chan)) then begin

midi_k ey_of f s e t:*1; if (event_type = MIDI_RS) then midi_key_of fset:*2; end;

end; { with eblk \ end;

} Return MIDI key data from Track Event, if present

function get_midi_key(var ebIk:track_event_bIock;

chambyte): integer;

var

key_offset : integer; begin

get_midij<ey:=ERR; { default return value } key_offset:=midI_key_offset(ebIk,chan); if (key_offset <> ERR) then get_midi_key:«ebIk.event.mess[key_offset]; end;

{ Set MIDI key value in a Track Event, if Track Event is of appropriate type

procedure set_midi_key(var eblk:track_event_bIock;

chan.keyrbyte);

var

key_offset : integer; begin

key_offset:*midi_key_offset(ebIk,chan); if (key_offset <> ERR) then eblk.event.mess[key_of fset]:=key; end;

358 BYTE LISTINGS SUPPLEMENT

j Transpose all MIDI pitch (key) data for a channel in a Track Data block

i

procedure transpose_pitch(var tdi,tdo:track_data_block;

chan,trans:integer);

var

curr_key : integer; j MIDI key value from

current track event }

beg i n

reset_track_data(tdi); reset_track_data(tdo); while not(tdi.edat) do beg i n

next_track_event(tdi);

curr_key:=get_midi_key(tdi.curr,chan);

If (curr_key <> ERR) then set_midi_key(tdi.curr,chan,

midi_data_limit(curr_key+trans)); store_track_event(tdo,tdi.curr); end; end;

LIST7.PAS

{ Return offset of MIDI velocity data in Track Event message, if present

function midi_vel_offset(ebIk:track_event_bIock;

chan:byte):integer; var

offset : integer; beg i n

midi_vel_offset:«ERR; { default return value \

j only MIDI key events have velocity \ offset:«midi_key_offset(ebIk,chan); if (offset <> ERR) then

midi_vel_offset:«offset+1; end;

{ Return MIDI velocity data from Track Event, if present

function get_midl_vel(eblk:track_event_block;

chan:byte):Integer;

var

vel_offset : integer; begin

get_mi di_ve I :*ERR; \ def-ault return value } vel_offset:*midi_vel_offset(ebIk,chan); if (vel_offset <> ERR) then get_midi_veI:=ebIk.event.mess[vel_offset]; end;

{ Set MIDI velocity value in Track Event, if Track Event is of appropriate type

procedure set_midi_veI(var ebIk;track_event_block;

chan,veI;integer);

var

vel_offset : integer; beg i n

vel_offset;«midl_vel_offset(ebIk,chan); if (vel_offset <> ERR) then ebIk.event.messfvel_of fset]:*veI; end;

{ Scale all MIDI velocity data for a channel in a Track Data block

i

procedure sea Ie_veI(var tdI,tdo:track_data_bIock;

chan:Integer; vel_fact:reaI);

var

curr_vel : Integer;

(continued)

BYTE LISTINGS SUPPLEMENT 359

June

begin

reset_track_data(tdi ); reset_track_data(tdo); while not(tdI.edat) do begin

next_track_event(tdi);

curr_vel:»get_midi_veI(tdi.curr,chan);

If (curr_vel <> ERR) then

set_midi_veI(tdi.curr, chan,trune(curr_veI*vel_fact)); store_track_event(tdo,tdi.curr); end; end;

LIST8.PAS

j Redirect MIDI channel data In a Track Data Block to a new channel

\

procedure change_chan(var tdi,tdo:track_data_bIock;

oId_chan,new_chan;byte);

begin

reset_track.dataftdi}; reset_track_data(tdo); while not(tdi.edat) do beg i n

next_track_event(tdi); wl th tdi.curr do begin

if (event_type * MIDI_RS) and

(midi_chan(running_status) *= old_chan) then event.mess[1]:«((event.mess[1] and $F0) or new.chan); store_track_event(tdo,tdI.curr); end; end; end;

j Extract a single MIDI channel from a Track Data Block

procedure extract_chan(var tdi,tdo:track_data_block;

chan:byte);

begin

reset_track_dataftdi); reset_track_data(tdo); while not(tdi.edat) do beg i n

next_track_event(tdl); with tdi.curr do beg i n

If (event_type in [MIDI_RS,MIDI]) and (midi_chan(running_status) <> chan) then begin j convert to NOP j event_type:«MARK; event_len:*2; event.mess[l]:*NOP; end; end;

store_track_event(tdo,tdi.curr); end; end;

| Filter a MIDI channel from a Track Data Block

procedure fiIter_chan(var tdi,tdo:track_data_block; chan:byte); begin

reset_track_data(tdi); reset_track_data(tdo); while not(tdi.edat) do beg i n

next_track_event(tdi); wi th tdi.curr do begin

If (event_type in [MIDI_RS, MIDI])

360 BYTE LISTINGS SUPPLEMENT

and (midi_chan(running_status) = chan) then begin { convert to NOP } event_type:=MARK; event_len:=2; event.mess[1]:=NOP; end;

end;

store_track_event(tdo,tdi.curr); end; end;

LIST9.PAS

procedure quantize(var tdi,tdo:track_data_b lock ;

quantum:integer);

var

in_time

rea I

out_time : reaI ;

et ime

integer; integer;

i

Actual elapsed time, input track data block Actual elapsed time, output track data block Temporary storage for adjustment of event time Rounding term

qround begin

reset_track_dataftdi); reset_track_data(tdo); qround:=quantum div 2; in_time:«0.0; out_time:=0.0; while not(tdi.edat) do beg i n

next_track_event(tdi ) ; with tdi.curr do beg i n

etime:=event.time; j Adjust in/out time variance } etime:-etime - trunc(out_time-ln_tIme); j quantize \

etime:-trunc(quantum * ((etime + qround) div quantum)) in_t1 me:*in_time+event.time; out_time:«out_time+etime; event.time:»etime;

while event.time > MAX_TIMING_COUNT do beg i n

s to r e_tr ack_even t(tdo,OVFL_EVENT); event.time:»event.time-MAX_TIMING_COUNT; end;

store_track_event(tdo,tdi.curr); end; end; end;

LIST10.PAS

var

tdt1,tdt2 : track_data_bIock;

begin j main } load_track_data(tdt1); disp_track_data(tdt1); read In;

wr IteIn(’Transposing pitch for channel 0’); transpose_pItchftdt1,tdt2,0,6); dump_track.dataftdt2); save_track_data(tdt2);

June

wrlteln(’extractlng channel 0'); extract_chan(tdt1,tdt2,0); disp_track_data(tdt2); save_track_dato(tdt2);

wr i teIn(*fiI terIng channel 0’); fiIter_chan(tdt1,tdt2,0); disp_track_data(tdt2); save_track_dota(tdt2);

end. { main }

Iist1.txt

TEXT

"Sorting ProDOS Directories," by Antonio C. Silvestri. June, page 117. Also download Iist2.txt.

10 REM PRODOS CATALOG SORT ROUTINE

20 REM ANTONIO C. SILVESTRI

30 REM SYSTEMS CONSULTANTS INC.

40 CLEAR: TEXT: HOME: DB - PEEK(115) + 256*PEEK(116)

50 FOR 1=768 TO 792: READ H: POKE I,H: NEXT

60 DIM DIM NA$(55), ST(30), ST$(30), DL(10): N = 0: V = 2:

V$ = GOSUB 460

70 VTAB 2: HTAB 6: PRINT "PRODOS FILENAME SORT UTILITY":

VTAB 9: HTAB 10: PRINT "INSERT DISK IN FLASH: PRINT "DRIVE 1";: NORMAL: PRINT:

HTAB 9: PRINT "HIT ANY KEY TO CONTINUE"

80 POKE - 16368,0: WAIT - 16384,128: POKE - 16368,0

90 HOME: PRINT "SEARCHING FOR VALID FILENAMES": PRINT

100 IF N <= 0 THEN 450

110 GOSUB 480: BL = V: HE = V: HE$ = V$: CO = 0: BC = 0 120 POKE 791,BL - 256*INT(BL/256): POKE 792,INT(BL/256):

POKE 776,128: CALL 768: IF PEEK(786) <> 0 THEN PRINT "ERROR IN READING BLOCK NO. ";BL: STOP 130 BC = BC + 1: DL(BC) = BL 140 FOR J=0 TO 12: IF J <> 0 THEN 180 150 IF BL-HE THEN DR$ = "":

FOR 1=0 TO 38: DR$ = DR$ + CHR$(PEEK(DB + 4 + I)): NEXT:

HE$ = HE$+"/"+MID$(DR$,2,PEEK(DB+4)-16*INT(PEEK(DB+4)/16)): PRINT "READING DIRECTORY: ";HE$

160 PRINT "BLOCK NO. ";BL;" READ"

170 IF BL = HE THEN 210

180 IF PEEK (DB + 4 + J * 39) = 0 THEN PRINT "D";: GOTO 210 190 PRINT CO = CO + 1: NA$(CO) = "":

FOR 1=0 TO 38: NA$(C0)=NA$(C0)+CHR$(PEEK(DB+4+J*39+I)): NEXT 200 IF ASC(MID$(NA$(CO),17,1))=15 THEN

V = ASC(MID$(NA$(CO),18,1)) + 256*ASC(MID$(NA$(CO).19.1)): V$ = HE$: G0SU8 460

210 NEXT J: PRINT: PRINT: X = FRE (0):

BL = PEEK(DB+2) + 256*PEEK(DB+3): IF BL <> 0 THEN 120

220 IF CO=0 THEN HOME: VTAB 10: FLASH:

PRINT "**WARNING**"; CHR$ (7);: NORMAL:

PRINT "NO FILENAMES CAN BE FOUND": GOTO 290 230 IF CO=1 THEN 290

240 HOME: VTAB 10: PRINT CO:" FILENAMES FOUND";: HTAB 29:

PRINT "NOW ";: FLASH: PRINT "SORTING": NORMAL: NX = CO 250 VTAB 17: HTAB 8: PRINT "FILENAMES HAVE BEEN PLACED"

260 VTA8 17: HTAB 7 - LEN(STR$(CO - NX)): PRINT CO - NX 270 FLAG = 0: FOR I = 2 TO NX:

IF MID$(NA$(I),2,15) < MID$(NA$(I-1).2.15) THEN H$ = NA$(I): NA$(I) = NA$(I-1): NA$(I - 1) = H$:

FLAG = 1

280 NEXT: X = FRE(0): NX = NX - 1:

IF FLAG = 1 AND NX <> 1 THEN 260

362

BYTE LISTINGS SUPPLEMENT

290 HOME: PRINT "STORING PURGED AND SORTED DIRECTORY": PRINT

300 A = 1: B = 0: FOR J = 1 TO BC

310 PRINT "NOW FORMING BLOCK NO. "; DL(J)

320 IF J = 1 THEN AX = 0: GOTO 340 330 AX = DL(J - 1)

340 IF J * BC THEN BX = 0: GOTO 360 350 BX = DL(J + 1)

360 POKE DB.AX-256*INT(AX/256): POKE DB+1, INT(AX/256):

POKE DB+2,BX-256*INT(8X/256): POKE DB+3, INT(BX/256):

POKE DB+511,0 370 IF J = 1 THEN

FOR K=1 TO 39: POKE DB+3+B*39+K,ASC(MID$(DR$,K,1)): NEXT: PRINT ".";:B = B + 1 380 IF A <- CO THEN

FOR K-1 TO 39: POKE DB+3+B*39+K,ASC(MID$(NA$(A),K,1)): NEXT PRINT GOTO 400

390 FOR K=1 TO 39: POKE DB+3+B*39+K,0: NEXT: PRINT "2";

400 A - A+1: B - B+1: IF B < 13 THEN 380

410 PRINT: PRINT: B = 0: POKE 791,DL(J)-256*INT(DL(J)/256):

POKE 792, INT(DL(J)/256): POKE 776,129: CALL 768 420 IF PEEK(786) <> 0 THEN

PRINT "ERROR IN WRITING BLOCK NO.”;DL(J): STOP 430 NEXT J: GOTO 90

440 DATA 169, 0, 141, 18. 3. 32, 0, 191, 0, 19, 3. 176, 1,

96, 238, 18, 3, 96 . 0, 3, 96, 0. 150, 0, 0

450 END

460 IF N >= 30 THEN

PRINT "STACK OVERFLOW": STOP 470 N = N+1: ST(N)-V: ST$(N)-V$: RETURN 480 IF N <- 0 THEN

PRINT "STACK UNDERFLOW": STOP 490 V - ST(N): V$ - ST$(N): N - N-1: RETURN

The PRODOS Diskette Sorting Utility Listing #1

J une

IIst2.txt TEXT

“Sorting ProDOS Directories," by Antonio C. Silvestri. June, page 117. Also download Iist1.txt.

10 DATA •■/SCRATCH". "/SCRATCH/MASS". "/SCRATCH/RHODE". "/SCRATCH/VERMONT". "/SCRATCH/MASS/NY". "/SCRATCH/MASS/NJ". "/SCRATCH/RHODE/PA", "/SCRATCH/VERMONT/MAINE"

20 DIM A$(40): D$-CHR$ (4): ONERR GOTO 100

30 READ H$: PRINT D$;"PREFIX ";H$: PRINT D$;"SAVE TESTFILE"

40 J=0: L»INT(40*RND(1))+1: PRINT: PRINT:

PRINT L;" FILES TO BE CREATED": PRINT 50 FOR K-1 TO L: TY$-"“: FOR 1-1 TO INT(10*RND(1))+1:

TY$-TY$+CHR$(65+26*RND(1)): NEXT: X-FRE (0)

60 PRINT K;" ";H$+'7"+TY$: PRINT D$;"OPEN "+TY$:

PRINT D$;"CLOSE "+TY$: IF RND(1) < .30 THEN J-J+1: A$(J)-TY$ 70 NEXT K

80 PRINT J;" FILES TO DELETE": IF J-0 THEN 30 90 FOR 1-1 TO J: PRINT D$;"DELETE "+A$(I):

PRINT I;" ";H$+"/"+A$(I): NEXT: GOTO 30

100 END

A Program to Create a Testing Diskette for the ProDOS Sorting Utility

Listing #2

indexbpp.pas TEXT

Programming Project: "A Simple File-Indexing System," by Bruce Webster. June, page 92. Also download Indexbpp.Ist.

i$V-|

program FI I©Index;

const

IndexMax = 1000 RecCountErr *= -2 NewFiIeCreated * -1 NoError * 0 RecordNotFound « 1 NoMoreRoom * 2 AlreadyExists * 3 OutOfRange * 4

type

Keytype FileStr Whatever

string

string

string

40

80

12

DataRec » record case Boolean of

True : (NumRecs False : (Key

theRest

end;

IndexRec ■ record

Key : Keytype;

Num : Integer

end;

Integer); Keytype; Whatever);

364 BYTE LISTINGS SUPPLEMENT

IndexList ■ array[1..IndexMax] of IndexRec;

var

KList

DFile

MaxRec

IndexList; file of DataRec; Integer;

| compiler-specific file I/O routines \

i these procedures are specific to TURBO Pascal. If you

are using another Pascal compiler, you will need to modify them appropriately. Note that TURBO Pascal does not support the standard routines GET and PUT, but instead uses READ and WRITE. \

{$!-} j turn off I/O error checking \

procedure FRead(RNum : Integer; var Rec : DataRec; var Error : Integer); reads record #RNum into Rec

\

beg i n

if (RNum < 0) or (RNum > MaxRec) then Error := OutOfRange else begin

Seek(DFiIe.RNum);

Read(DFiIe,Rec);

Error :« IOResult; if Error > 0

then Error := 100 + Error

end

end; j of proc FRead }

procedure FWrlte(RNum ; Integer; Rec : DataRec; var Error : Integer); writes record #RNum into Rec

begin

If (RNum < 0) or (RNum > MaxRec) then Error :■ OutOfRange else begin

Seek(DFile,RNum);

Wr1te(DFiIe,Rec);

Error :■ IOResult; if Error > 0

then Error :■ 100 + Error

end

end; j of proc FRead }

procedure FOpen(FiIeName : FileStr; var Error : Integer);

tries to open FIleName; if it doesn't exist, creates . it with the appropriate header record

} "no file" error code for TURBO Pascal

const

TurboNoFlIe « 1;

NoIOError - 0;

var

IOCode : Integer;

TRec : DataRec;

beg i n

Assign(DFlle,FileName);

Reset(DFiIe);

IOCode :* IOResult;

if IOCode * TurboNoFile then begin \ file doesn't exist } FiI IChar(TRec,SizeOf(TRec),0);

Rewrite(DF1le);

TRec.NumRecs :» 0;

Wrlte(DFile.TRec);

Close(DFile);

AssIgn(DFiIe,FIlename);

Reset(DFile);

IOCode :•* IOResult; if IOCode - NoIOError

then Error :* NewFiIeCreated

end;

if IOCode <> NoIOError

\

then Error :■ 100 + IOCode; end; j of proc FOpen \

procedure FCIose(vor Error : Integer);

closes file

\

begin

Close(DFIIe);

Error ;■ IOResult;

If Error > 0

then Error :« Error + 100 end; { of proc FCIose \

{$1 + } j turn on I/O error checking \

{ Initialization and cleanup routines (

procedure SortIndexList;

\

sorts the array KList using a selection sort technique

var

I.J.Min : Integer;

Temp : IndexRec;

begin

for I :» 1 to MaxRec-1 do begin Min := I;

for J :* 1+1 to MaxRec do

if Kllst[J].Key < KList[Min].Key then Min J;

Temp :» KList[I];

KList[I] KList[Min];

KList[Min] Temp end

end; { of proc SortIndexList \

procedure InitStuff(FileName : FlleStr; var Error : Integer);

sets everything up for indexing system. This assumes that there are no more than IndexMax (=1000) records, and that the records are numbered 1..IndexMax. Record #0 is the header record and is used to store the current number of records actively being used in the file

var

Indx,TErr : Integer;

TRec : DataRec;

begin

Error := NoError;

FOpen(FiIeName,Error); if Error <* NoError then begin MaxRec :* 0;

FRead(0,TRec,TErr);

Error := TErr;

MaxRec :* TRec.NumRecs; for Indx :» 1 to MaxRec do begin FRead(Indx,TRec,TErr); if TErr > 0 then Error ;» TErr;

KLIst[Indx].Key := TRec.Key;

KList[Indx].Num := Indx end;

SortlndexList

end

end; | of proc InltStuff \

procedure CleanUpStuff(var Error : Integer);

this just does an orderly shutdown and should be called before you leave your program (or open another data file)

var

TRec : DataRec;

beg i n

TRec.NumRecs := MaxRec; { save out # of records }

366 BYTE LISTINGS SUPPLEMENT

June

FWrite(0,TRec,Error);

FCIose(Error)

end; { of proc CleanUpStuff \

function FlndKey(Key : Keytype) : Integer;

looks for Key in KList; returns location in KList if found; otherwise returns - 1

i

var

L.R.Mid : Integer;

begin

L :* 1; R :* MaxRec; repeat

Mid := (L+R) div 2; if Key < KList[Mid].Key then R Mid-1

else L Mid+1

until (Key * KList[Mid].Key) or (L > R); if Key = KList[Mid].Key then FindKey :* Mid else FindKey := -1

end; j of proc FindKey }

procedure GetRecord(Key : Keytype; var Rec : DataRec;

var Error ; Integer);

looks through KList for Key; if found, returns in Rec.

It and the routines that follow assume the procedure Seek for random access of the file of records.

\

var

Item ; Integer;

beg i n

Error :« NoError;

Item :■ FindKey(Key); if Item > 0

then FRead(KList[Item].Num,Rec,Error) else Error :■ RecordNotFound end; { of proc GetRecord }

procedure PutRecord(Rec : DataRec; var Error : Integer);

writes Rec out to the file. If a record with that key already exists, then overwrites that record; otherwise, adds the record to the end of the file.

If there’s no more room for records, exits with an error code

}

var

Item : Integer;

begin

Error := NoError;

Item :« FindKey(Rec.Key);

If I tern >■ 0

then FWrite(KList[Item].Num,Rec.Error) else if MaxRec < IndexMax then begin MaxRec := MaxRec + 1;

FWrite(MaxRec,Rec,Error);

KList[MaxRecl.Key Rec.Key;

KList[MaxRecJ.Num :■ MaxRec;

SortlndexList

end

else Error :■ NoMoreRoom end; j of proc PutRecord \

procedure AddRecord(Rec : DataRec; var Error : Integer);

adds a record to the file. If a record with the same key already exists, then exits with an error code

var

Item ; Integer;

begin

Error NoError;

{continued)

BYTE LISTINGS SUPPLEMENT 367

Item :■ FindKey(Rec.Key);

If Item > 0

then Error :* AlreadyExists else PutRecord(Rec,Error) end; J of proc AddRecord }

procedure DeIeteRecord(Key : Keytype; var Error : Integer);

deletes the record with 'Key* by copying the last record In the file to that slot, then modifies KList by shuffling a I I the key entries up

var

I tern,Last,Max,MVaI : Integer;

TRec : DataRec;

begin

Error := NoError;

Item :» FindKey(Key); i f Item * -1

then Error :« RecordNotFound else begin

Max := 1; MVal :■ KList[Max].Num; for Last :* 2 to MaxRec do

if KList[Last].Num > MVal then begin Max :« Last; MVal := KList[LastJ.Num end;

if Max <> Item then begin

FRead(MVal,TRec,Error); { get last record in file }

FWrlte(KList[Item].Num,TRec,Error); | write over it j KList[Max].Num KList[Item].Num end;

for Last :■ Item to MaxRec-1 do { delete KList[Item] }

KList[Last] KList[Last+1];

MaxRec :» MaxRec - 1 { adjust # of records }

end

end; { of proc DeleteRecord }

\ USERIO.LIB

Wr i teStr Error GetChar Yes

GetString IOCheck

\

type

MsgStr

CharSet

procedure and functions in this library

write message out at (Col,Line)

writes message out at (1,1), waits for character

prompt user for one of a set of characters

gets Y/N answer from user

prompt user for a string

checks for I/O error; prints message if necessary

= string[80];

« set of Char;

var

IOErr

IOCode

Boo Iean; Integer;

procedure WriteStr(Co I,Line : Integer; TStr : MsgStr);

purpose writes message out at spot indicated

last update 23 Jun 85

beg i n

GoToXY(Col,Line); ClrEol;

Write(TStr)

end; j of proc WriteStr } procedure Error(Msg : MsgStr);

purpose writes error message out at (1,1); waits for characte

last update 05 Jul 85

const

368 BYTE LISTINGS SUPPLEMENT

Bell * ^G;

var

Ch : Char;

begin

Write$tr(1,1,Msg+BeIl+* - •

Read(Kbd.Ch) end; { of proc Error }

procedure GetChor(var Ch : O: MsgStr; OKSet ; CharSet);

purpose let use* e--e- ccmw-~d

last update 23 Jun 55

begin

WriteStr(1,1.Prompt); repeat

Read(Kbd.Ch);

Ch :« UpCase(Ch) untiI Ch in OKSet;

WriteLn(Ch)

end; { of proc GetChar \

function Yes(Question : MsgSt' 5:: -r;

purpose asks _s*' :.*st on

last update 03 Ju Sc

var

Ch : Cher;

begin

GetCharfCh,Question+* (Y S) " [*Y N*l);

Yes (Ch - *Y’) end; { of func Yes |

procedure GetString(var NStr : MsgStr; Prompt . OKSet : CborSmt);

MsgStr; MaxLen : Integer;

\

purpose last update

get string from user 09 Jul S5

- "H;

* A M;

: CharSet «

: MsgStr;

: Integer;

: Char;

const BS CR

ConSet : CharSet « [BS.CR];

var TStr TLen.X Ch

beain

I$I-| | turn off I/O checking J TStr

TLen :* 0;

WriteStr(1,1.Prompt);

X :* 1 + Length(Prompt);

OKSet OKSet + ConSet; repeat

GoToXY(X.I);

repeat

Read(Kbd.Ch) until Ch in OKSet; if Ch « BS then begin if TLen > 0 then begin TLen :■ TLen - 1;

X :« X - 1;

GoToXY(X.I); Write(’ '); end end

else If (Ch <> CR) ond (TLen < MoxLen) then begin Wrlte(Ch); *

TLen :* TLen + 1;

TStr[TLen] :* Ch;

X :« X + 1; end

until Ch - CR;

[continued)

BYTE LISTINGS SUPPLEMENT 369

I f TLen > 0 then begin TStr[0] :» Chr(TLen);

NStr :» TStr end

else Write(NStr)

{$1 + 1

end; J of proc GetStrlng f procedure IOCheck(IOCode ; Integer);

purpose last update

$

var TStr begin IOErr :

If IOErr

check 19 Feb

for

86

10 error; print message If needed

strIng[4];

(IOCode <> 0); then case IOCode

end end; {

$01 : Error(*I0ERR0R>

$02 : Error(*IOERROR>

$03 : Error(*I0ERR0R>

$04 : Error(*I0ERR0R>

$10 : Error(*I0ERR0R>

$20 : Error(*I0ERR0R>

$21 : Error(*I0ERR0R>

$22 : Error(*I0ERR0R>

$90 : Error(*I0ERR0R>

$91 : Error(*I0ERR0R>

$99 : Error(*I0ERR0R>

$F0 : Error(*I0ERR0R>

$F1 : Error(*I0ERR0R>

$F2 : Error(*I0ERR0R>

$FF : Error(*I0ERR0R> else Str(I0Code:3,TSt

Error( , I0ERR0R>

of

File does not exist *);

File not open for Input*);

File not open for output*);

FI le not open*);

Error in numeric format*);

Operation not allowed on logical device’) Not allowed in direct mode’);

Assign to standard files not allowed*); Record length mismatch*);

Seek beyond end of file*);

Unexpected end of file*);

Disk write error *);

Directory is full*);

File size overflow*);

File disappeared*) r);

Unknown I/O error: *+TStr)

of proc IOCheck \

const

CmdPrompt

declarations and code for test program

\

: MsgStr =

*TEST> A)dd, D)elete. F)lnd. L)ist, I)ndex, C)lose, Q(u *TEST> Enter file name: *;

*TEST> Another file?*;

*A\*D\*F\*L\’I\*C\*Q*]; *0*..*9*.*-*.’/’.*(’.*)’];

Fi1ePrompt

:

MsgStr =

DonePrompt

:

MsgStr =

CmdSet

:

CharSet «

NameSet

:

CharSet «

PhoneSet

:

CharSet 1

ir

Cmd

.

Char;

ErrVa1

:

Integer;

F i 1eName

:

Fi leStr;

Done

;

Boo 1ean;

procedure FiIeError(ErrVaI : Integer); begin

if ErrVal < 100 then RecCountErr NewFiIeCreated RecordNotFound NoMoreRoom Al readyExists end

else begin

IOCheck(ErrVa1-100) end

end; j of proc FileError {

case ErrVal of

Error(’Record count mismatch*); Error(’Creating new file*); Error(’Record not found*);

Error(

Error(

•(*No more room*); '('Record already exists’)

370 BYTE LISTINGS SUPPLEMENT

June

add a record to the file 19 Feb 86

: MsgStr;

: DataRec;

procedure DoAdd;

purpose last update

i

var TStr TRec begin

FiIIChar(TRec,SizeOf(TRec), 0 ); with TRec do begin TStr :=

GetString(TStr,’ADD> Enter name: if TStr <> •• then begin Key := TStr; TStr :»

GetString(TStr,*ADD> Enter phone #: \ 12,PhoneSet); theRest :* TStr;

AddRecord(TRec,ErrVaI);

FIush(DFlie);

FiIeError(ErrVaI) end end;

end; { of proc DoAdd }

*,40,NameSet);

procedure DoDelete;

purpose delete a record from the file

last update 19 Feb 86

i

var

Key : Keytype;

beg i n

GetStrIng(Key,*DELETE> Enter name: *,40,NameSet); DeIeteRecord(Key,ErrVaI);

Fi leError(ErrVal) end; j of proc DoDelete J

procedure DoFind;

purpose find a record in the file

last update 19 Feb 86

var

Key : Keytype;

TRec : DataRec;

beg I n

GetStrlng(Key, *FIND> Enter name; •,40,NameSet); GetRecord(Key,TRec,ErrVaI); if ErrVal « NoError then begin WriteStr(1,2,’The phone number is ');

Wr IteIn(TRec.theRest) end

else FI IeError(ErrVaI) end; j of proc DoDelete j

list out contents of the file 19 Feb 86

DataRec; Integer;

procedure DoList;

purpose last update

i

var TRec Indx beg i n

ClrScr; Writeln;

for Indx :- 1 to MaxRec do with KList[Indx] do begin WrIteStr(1,Indx+1,Key); WriteC *:(45-Length(Key))); GetRecord(Key,TRec,ErrVaI); if ErrVal - NoError then with TRec do Writeln(theRest) else FileError(ErrVal) end

end; j of proc DoList }

{continued)

BYTE LISTINGS SUPPLEMENT 371

I me

procedure Showlndex;

\

purpose list out contents of the key list

last update 19 Feb 86

i

var

Indx : Integer;

begin

ClrScr; Writeln;

for Indx :■ 1 to MaxRec do with KList[Indx] do Write In(Key,* *:(45-Length(Key)),Num:5) end; \ of proc DoList \

begin

repeat

Done :« False;

ClrScr;

GetStrlng(FiIeName,FlIePrompt,80.NameSet); InitStuff(FIleName.ErrVal);

FIleError(ErrVal); repeat

GetChar(Cmd.CmdPrompt,CmdSet); case Cmd of

’A’

: DoAdd;

’D’

: DoDelete;

*F*

: DoFind;

•L’

: DoList;

•r

: Showlndex;

’Q’

: Done :* True

end

unt11 (Cmd

■ *C') or Done;

CleanUpStuff(ErrVaI);

FiIeError(ErrVaI);

ClrScr; if not Done

then Done :■ not Yes(DonePrompt) untiI Done

end. { of program Testlndex \

midilll.c

TEXT

"A MIDI Project," by Jay Kubicky.

June, page 199. Also download rxintll.a.

/* MIDInterface 1.11

Copyright (C) 1985, 1986 By:

Jay Kubicky 934 N. Orange St.

Media, PA 19063 215-565-7761

This is a VERY recent version of this program.

It has not been ’tested* extensively, though all testing that has been done shows favorable results.

All users are free, of course, to test (and debug) this software as desired.

372 BYTE LISTINGS SUPPLEMENT

This program was developed under the DeSmet C compiler, and utilizes DeSmet’s vastly useful in-line assembly language capability. Compiling it on other compilers (such as Lattice) may require EXTENSIVE modification.

2/14/86

*/

#define MIDID 0xffa0 #define MIDIS 0xffa2 #define PIC0 0x20 #define PIC1 0x21 #define CSTAT 0xFFA7 #define COUNTER1 0xFFA4 #define C0UNTER2 0xFFA5

^define Tsize 25600 /* track size in bytes (24K) */

#define Tk 25 /* track size in K */

#deflne seg_per_trk 1600 /* track size in paragraphs */

/* the following structures hold data for each buffer */

char prog_Jd[]={"MIDInterface 1.11 (c) 1985, 1986 Jay Kubicky"\;

struct rec { /* 63 bytes long 63*16=1008 bytes total */

char chan; unsigned ssize; char name[40];

char transpose; /* transpose amount */ char extra[19]; /* for later use */

\ parts[16];

char in_filt;

/* This is the MIDI input filter mask: bit: message filtered out:

0

1

2

3

4

5

6

char

char

char

char

char

on[4]= M 0N "; off£4j« M 0FF M

yes. no[4]

-"YES";

"NO

/*

*0N* */ ’OFF' */

sin_line[80]; /* A 79 char,

unsigned r_segment; char *ptr, *end; int fd; char f1 Iename[30];

Note ON

Note OFF

Program Change

Channel Pres. (After-touch)

Pitch Wheel

Control Change

Poly. Key pres. (After-touch)

single line*/

int r_tempo; /* tempo val (bpm) */

unsigned tempo; /* real tempo val. */

char destbyte, stop;

char clsb, cmsb, dsync, MIDIsync, audmet; char rbuff; /* receive buffer */

char beat, mbeat,abeat, s_t_b, m_t_b, a_t_b; /* beats & time bases */

char buffon[16]; unsigned pointers[16]; unsigned startp[16]; unsigned endp[l6l; unsigned segment[16];

/* true means given buff is active */

/* an array of pointers into present buffers */ /* an array of starts of present buffer */

/* pointers to end of songs */

/* array of segments of tracks */

int pfd; char printer;

/* fd for printer */ /* printer enable */

extern unsigned _rax, _rbx, _rdx, _res, _rds;

June

char LAST.STAT; char C_0_F; char clk_type; char counter_dec; char vir_buff[1024]; char buff1[Tsizej;

/* 0-lnternal, 1-external */

char buff2[Tslze

/* track 0 - 3070 notes */

/* track 1 - 3070 notes */

/♦"firsttwo tracks eat up 50K */

/* last fourteen will take 350K combined */

/* total note storage

3200 notes per track 51200 notes in al1!!! */

char *_showsp(),*_showss(),*_showds(); maln()

unsigned a;

char cIkvaI,seI,b; Int c;

unsigned base_seg, cont_mem;

/* the following code stores the DS at 0x4FA */

/* THIS IS VERY IMPORTANT!!!!I II! */

/* this allows the DS to be transffered to the RXINT function */ # asm

MOV CX.DS ; store DS In CX PUSH DS ; save DS

MOV AX,0 ; this will be new value for DS MOV DS,AX ; put 0 In DS MOV WORD [04FAH], CX ; store DS POP DS ; retrieve DS

/* MIDInterface 1.11 16-track digital sequencer

Data storage format:

byte num:

Note ON

Note OFF

Prog Chan

Chan Pres (after-touch) Pitch Wheel

Cntrl Chan

Key Pres, (after-touch)

End

Table caption(MIDI ORIENTED COMMANDS)

first

second

th 1 rd

fourth

+ H

00VVVVVV

LLLLLLLL

MMMMMMMM

Innnnnnn

00VVVVVV

LLLLLLLL

MMMMMMMM

0nnnnnnn

01000000

LLLLLLLL

MMMMMMMM

0ppppppp

01000001

LLLLLLLL

MMMMMMMM

0aaaaaaa

10WWWWWW

LLLLLLLL

MMMMMMMM

—

11000000

LLLLLLLL

MMMMMMMM

0nnnnnnn

01Ivvvvv

i

LLLLLLLL

MMMMMMMM

0nnnnnnn

(INTERNAL ORIENTED COMMANDS)

11000001 j LLLLLLLL

MMMMMMMM

i tttttttt

11111111 |

i -- i

1 “ 1

i -

Table captionfifth

Table caption0CCCCCCC

WWW

top 6 bits of velocity (NOTE ON

LLLLLLLL

LSB of elk

MMMMMMMM

MSB of elk

nnnnnnn

note for either NOTE ON or NOTE

PPPPPPP

new program

aaaaaaa

chan pressure (after-touch)

WWWWWW

top six of bender

nnnnnnn

control number

ccccccc

—

control value

tttttttt

_

new tempo value (40-200)

*/

c-0;

374

BYTE LISTINGS SUPPLEMENT

start:

pr intf( pr intf( pr intf( pr intf( pr intf( pr Intf( pr intf( printf ( pr intf ( pr intf( pr intf( printfC pr intf( pr intf ( pr intf(

June

while(c<79)

sin. -O—> 2 sin_line[c]=

in_f I 11**0xf ^ fm Zxr “*£ fl t* cut anything */

clk_type*8:

counter.dec*!

rbuff*255;

segment[0]=j*;---- /* 1st two buffs in DS */

startp[0l*b- : =:jff1+Tsize-8;

startp[1J=r. : - - uff2+Tsize-8;

parts[0].ss ze—: ; per*s'* ].ssize=0;

/* This is *‘* T~mz -• r :::* :~ section.

This is *•: • : nzr ~ -do-aI Iocation scheme

allowing <*-*'~e system memory (up to 640K).

Memory s : : : soft ~t 3 ::«s of 25k (1600 paragraphs).

All trcc«s r-* z"mczGmz sequential ly until you run out of syste- - -*c tracks are taken care of

in the I . as * 21 •r-* :*:.ld always be room for these.

*/ r

• r:*: just after stack */

/* This is the segment boundary of the bottom of un-initia Iized mem */ -9 z safety */

cont_mer-=ge * _r _r-rr

cont.mea ** • r aw late i of system para. */

/* Here’s • ♦- "x: a:r** uemory" */

base_seg«_s~: base.seg •* . 1 - 3 *

++base_seg;

_setme*(sepr«?-*—* Z1 MT~ c=2;

for (a~bcs«_aw:

sejNrt'rW str'tc're-: "

*> crii lK

pcrt*[c]_ 2 -i

}

tt c < 16; a+=seg_per_trk) j

/* default time bases */

m_t_b»2; s_-_r*

pr inter*0; scr.cIo();

prlntf("Do • 1 - ^ wm winter as an audio meternome?"); i f (toupper ;•*:*sr[J j— T]

pr -•* ’ : >ter and hit any key");

getclsor 5 ^ ^ ^

I :• ccening printer ... aborting\n");

I

beepp pr inters*

i

setdart();

intoff();

scr_cla();

11

m

/• t.

off */

7 /; 'vvvvvvvvvvvvvvi>vvvvi>vvvin>i>vvv[\n ")

7 ^I>-erixc« *.11 16 Track Digital Recorder V\n")

wain Menu:\n");

5556566666\n") ;

.Erase a track\n");

2- ...Record to a track\n M );

u.Ploy from a track\n");

* --Track Information\n");

i .Save a track\n"j);

!rtflH n trnrk\n"

i --LUUU VJ U \I1 J t

7— ..Set MIDI modes\n");

.Edit input f i I ter\n") ;

f ...Quit\n");

( continued )

BYTE LISTINGS SUPPLEMENT 375

scr.rowcoI(24,0);

printf(" Copyright (C) 1985, 1986 by Jay Kubicky");

scr.rowcol(18,0);

printf(" Enter Selection;");

sel-getchar(); switch (sel) j case * 1 *;

erbuff(); break; case '2’:

recbuff(); break; case *3*:

pbuffs(); break;

* 4 ’ :

dbuffs(); break; case *5’:

strack(); break;

’6*:

I track(); break; case *7’:

mmode(); break; case *8*:

ed.in.filt(); break; case *0’:

scr.cI a(); b=0;

for(a»0; a<16; ++a) }

if(parts[a].ssize) {

b»1; /* toggle high */

printf(" Data still left in track %d\n",a);

if(!b) I

c lose(pfd); ex 11(0);

case

case

printf("StiI I want to exit? "); if(toupper(getchar()) ■■ *Y # ) cIose(pfd); exit(0);

defauIt:

/*

goto start;

oto start;

*/

dbuffs() \

DBUFFS

This is the general buffer display routine.

It displays all pertinent data for all avaiable buffers.

char a,b; unsigned tn,nf,nu; scr.cIa();

printff" Track Assignment Screen:\n"V,

p r in t f( " vvvvvvvvvvvvvvvvvvvvvvvv\n " );

printf("Track Num; Transmit Chan: Notes Used; Transpose: EnabeIed:\n");

printf("%s\n",sin.line); for(a=0; a<16; ++a) }

if(segment[a]) {

tn=(endp[a]-startp[a])/8; nf=tn-(parts[a].ssize/8); nu=tn-nf;

b*parts[a].transpose;

print f("%d\t\t%d\t\t%d\t\t%d\t\t%s\n",a,parts[a].chan,nu, b < 128 ? b : -256+b, buffonfa]

\

e I se

376

BYTE LISTINGS SUPPLEMENT

pr i nt f ( "—\t\t—\t\t—\t\t—\t\t—\n " );

print f("%s\n",sin_line); ttag: scr_rowcoI(21,0);

printf("Change one trans. channel (1), change all (2), transpose(3),

enable status (4)\n");

printf("or (0) to quit/continue: ");

a=getchar();

scr_rowcol(22,17);

scr_cls(); /* clear rest of current line */ switch(a) {

case *0*;

return; break; case *1':

printf(" Enter track number:"); b*getint(); scr_rowcol(23,0);

printf( M Enter new transmit channel:"); parts[b].chan=getint(); break; case *2':

printf(" Enter new transmit channel for all tracks:"); a»getint(); for(b*0; b<16; ++b)

parts[b].chan-a;

break; case *3’:

printf(" Enter track number:"); b»getint(); scr_rowcoI(23,0);

printf(" Enter new transpose amount:"); parts[b].transpose-getint(); break; case *4*:

printf(" Enter track number:"); b«getint();

if(parts[b].ssize kk b !- rbuff)

buffon[b]« buffon[b] ? 0 : 1;

break;

defau11:

goto ttag;

goto s_;

/* ERBUFF

This funct. erase a buffer (set the size to 0)

*/

erbuff()

scr_cIa(); char b;

printff" Erase a Track\n");

printf("%s\n",sin_lIne); printf("\nWhich buffer? "); b«getT nt();

printf("Are you sure you want to erase buffer %d?",b); 1f(toupper(getchar()) !■ *Y’) return;

parts[b].ssize=0; buffon[b]«0;

/* PBUFFS

This Is the top-level play-buffer routine.

*/

pbuffs()

int m; copyptrs();

scr_cla();

printff" Play Track Mode\n");

printff"Xs\n\n\n",sin_line);

[continued]

BYTE LISTINGS SUPPLEMENT 377

June

printf(" Hit any key to continue\n");

getchar();

dbuffs();

scr_cla();

printff" Play Track Mode\n");

prIntf("%s\n\n\n",sin_lIne);

get_options();

prIntf( M \nHit space bar to continue, any other key to quit\n M ); If(getchar()!«32) return; setrec(); destbyte=»0xf f; playQ;

intoff();

_outb(5,MIDIS); /* send off to drum mach. */

_outb(104,MIDIS);

_outb(0xfc.MIDID); /* MIDI seq off */

for(m«0; m<16; ++m) j i f(partsfmj.ssize)

buffon[ml*1;

RECBUFF:

This Is the track record routine.

All it really does is set up & enable the interrupt routine Rxlnt

*/

recbuff()

char b; Int m;

copyptrs();

scr_cla();

prlntf(" Record a Track\n");

printf("%s\n\n",sin_line); pr intf (" Which buffer: 1 ');

b*getint();

if(parts[b].ssize) j

printf("That buffer already has music, still want to record (Y/N)?"); If(toupper(getchar()) !« *Y') return;

I f (isegment[b]) \

printf("Sorry, that track is not available to record in.\n"); hak(); return;

rbuff*b;

parts[bl.ssize=0;

dbuffs(); /* display buff enable board w/ option to change */ scr_cla();

get.options();

printf("\nHit any key to begin recording\n");

getcharO;

scr_cI aO J

printf("Hit any key to stop recording\n");

setrec(); play();

_poke(255,ptr,segment[rbuff]); /* EOS (end-of-song) */

parts[b].ssize=ptr-startp[rbuff];

printf("\nSong is %d notes long\n",parts[b].ssize / 8); rbuff-255; /* no more record buffer */

pointers[b]=startp[b]; /* copy start pointer */

buffon[b]=1; /* enable present buffer */

_outb(5,MIDIS); /* send off to drum mach. */

_outb(104,MIDIS);

_outb(0xfc,MIDID); /* MIDI seq off */

378 BYTE LISTINGS SUPPLEMENT

rbuff»0xff; hok();

J une

}

/* SETREC

This sets up c

*/

setrec()

int a;

r~ fzr Play & Record.

stop»0; destbyte-8; setint(); ptr«startp[r:. * - ' end*endp[rfc.•• r_segment-sef * end«endp[rfc_ * * ' C_O_F«0x98; beat-abeat*-:*: * •

i f(dsync)

.OL*: : tfH : • !?*: start to drums */

^ _ol:: =— r- e : :

if(MIDIsync) _

_c.*r : : Ml: Zfi /* start ext seq */

pointers= s•: z* pointers[*-: -“ *

setcounte' » 8,255,255);

copyptrs() /* cc:- f: :.*'ers into pointer areas */

char a;

for(a-0; c< * 5 —r

po s];

/* LTRACK

*/

I track()

\

Load a trock

char tr; scr_cla():

printff" Load a Track\n M );

printf("%s\n*.• -t

dir("????????• • —

scr.rowcol (2,e);

printf(" Locc ** c; *: • );

tr«getint();

If(ports[tr].ssize) f

print';'T:*: c n that track ... abortingAn");

getchor(); rttirn; j

printf(" Load **om r* r file:"); scant("%s",fi e-c** if((fd-open(filenaae 2)) — -1) |

prIntf("Can*t open %s ... abort1ng\n",fiIename);

getcharQ;

return;

i f(read(fd,parts[tr].S3) «» -1) J

printf("Error encountered during reading.\n");

getchar();

return;

Jf(seg_read(fd,tr,parts[tr].ssize+1) — -1) j

printf("Error encountered while reading.\n"); getchar(); return; }

c lose(fd);

printf("Total bytes loaded from disk:%d\n",parts[tr].ssize+63); buffonftr]«1; getchar();

(continued)

BYTE LISTINGS SUPPLEMENT 379

/* STRACK

Save a track to disk.

*/

strack() /* save a track */ char tr;

scr_cla():

printff" Save a Track\n");

printf("%s\n",sin.line);

dlr("????????", ,, ??? M );

scr.rowco1(2,0);

prlntf(" Save which track:");

tr«getint();

If(iparts[tr].ssize) {

prIntf("Nothing In that track ... abortlng.\n"); getchar(); return; } prlntf(" Save to what file:"); scanf("%s",filename); lf((fd»creat(fiIename)) ■* -1) j

printf("Can't creat %s ... abortlng\n",fiIename);

getchar();

return;

If(wrlte(fd,parts[tr],63) — -1)^ j

prIntf("Error encountered during wr1tlng.\n");

getchar();

goto .end;

If(seg.write(fd,tr,parts[tr].ssize+1) ■■^-1) {

printf("Error encountered while writing.\n"); aetchar(); goto .end; (

close(fd);

pr1ntf("TotaI bytes written to disk:%d\n",parts[tr].ssize+63);

hak();

return;

.end:

close(fd);

/* SEG.READ, SEG.WRITE

These functions carry out intra-segmentary disk I/O functions.

*/

seg_reod(fd,tr.size)

int fd, tr; unsigned size;

unsigned a;

a=startp[tr]; /* this won't be 0 for tr. 0 k 1 : it's a pointer */

1f(s1ze > 1024) j

size+*a; /* make size look like a pointer */

for(;a < (size-1024); a+«1024) {

if(read(fd,vir.buff,1024) == -1) return(-1);

_lmove(1024,vir.buff,_showds(),a,segment[tr]);

e I se

size+«a;

1 f(!(size-a))

return(1);

1f(read(fd,vir.buff,size-a) *» -1) return(-1);

.Imovefsize-a,vir.buff,_showds(),a,segment[tr]); return(l);

seg.write(fd.tr.size) int fd, tr; unsigned size;

unsigned a;

a=startp[tr]; /* this won't always be 0 because of tracks 0 & 1 */

if(size > 1024) }

size+*a; /* make size look like a pointer */

for(;a < (size-1024); a+«1024) \

380 BYTE LISTINGS SUPPLEMENT

_lmove(1024,a,segment[tr],virebuff,_showds()); if (write(fd,vir_buff,1024) *= -1) return(-1);

\

e I se

size+»a;

If(!(size-a)) /* Is the buff length 0 || have we written all data? */

return(1);

_lmove(sIze-a,a,segment[tr],vlrebuff,_showds());

If(write(fd,vlr_buff,size-a) ** -1) return(-1); return(1);

/* Play()

This function plays through the 16 tracks until track 0 ends or a key is struck.

*/

ploy()

\

sp:

Int playing; char a,ch,b; unsigned n; scr_rowco1(2,0); pr intf("Tempo:

%d",r_tempo);

for (a=0; a<15; ++a) {

if(buffon[a] && a!*rbuff) if(playfrom(a)) \ if (a)

I

/* Track or song end */

/* If not track 0 */ buffon[a]=0; /* turn off buff */

e l se

\

return;

If(dsync)

btQ; if(MIDIsync)

bt2(); If(oudmet)

bt3();

If(!(ch-scr_csts())) goto sp;

else {

switch(ch)

case

defauIt:

++r_tempo; break;

».

—r_tempo; break;

return;

scr_rowcoI(2,10); printf("%d",r_tempo); tempo«2000000/((r_tempo*48)/60); set_cnt_1(tempo,tempo » 8);

i

goto sp;

p I ayfrom(a) char a;

char *p,d,*p1;

p«virebuff;

_l move(8,pointers[a].segment[a],v!r_buff,_showds());

if(*p«»0 xff) /* check for EOS */ return(l);

[continued)

BYTE LISTINGS SUPPLEMENT 381

readclk();

p1*p+2;

if(*p1 > cmsb)

goto pnow;

If(*p1 < cmsb)

return(0); lf(*(p+1) < clsb) return(0);

pnow: /* now we know that it's time to play [notes]... */

d«*p Sc 0xc0; switch(d) j

case 00: /* note on or off */

pnt(p,parts[a].chan.parts[a].transpose);

pointers[o]+-4;

break;

case 0x40: /* prog chan / chan pres. / key pres. */

pchan(p,parts[a].chan); pointers[a]+=4; break;

case 0x80: /* pitch bender */

w_f_e(); /* let FIFO empty */

_outbf0xE0+parts[a].chan.MIDID); /* send P. B. code */ w_f_e(); /* l«t FIFO empty */

_outb(0,MIDID); /* we didn’t store LSB */

w_f_e();

_outb(*p « 1.MIDID); /* send MSB */

pointers[a]+«3;

break;

case 0xC0: /* cntrl chan | temp chan */

cchan(p,parts[a].chan);

If(!(*p&1)); /* make up for control change */ ++pointers[a]; pointers[a]+=4; break;

}

return(0);

pnt(p,tc,trans) char *p,tc,trans;

# asm

MOV SI.WORD [BP+41 MOV AL,BYTE [SI+3J AND AL,128 JZ znoff

MOV AL.BYTE [BP+6] ADD AL.090H

zcheat1:

MOV DX.0FFA0H CALL w_f_e_

OUT DX.AL

MOV AL,BYTE [SI+3] ADD AL,BYTE [BP+8] AND AL.07FH CALL w_f_e_

OUT DX.AL MOV AL.BYTE [SI] SHL AL,1 CALL w_f_e_

OUT DX.AL JMP zalI done

znoff:

MOV AL,BYTE [BP+6] ADD AL.080H JMP zcheat1

zaI I done:

get p

get *(p+3) strip off top bit play a note off get tchan

add a basic note on

here’s where we’ll cheat on a Note OFF

MIDI Data port

wait for DART FIFO to empty

send byte

get note to turn on

add transpose vaI.

strip off top bit

wait for DART FIFO to empty

send out note

get velocity

shift up Into range

wait for DART FIFO to empty out

send velocity

finished

send Note OFF command get transmit channel add basic Note OFF let’s take a short cut

a I I done

{

pchan(p.tc) /* Program change, channel pressure, or after-touch */ char *p,tc;

382 BYTE LISTINGS SUPPLEMENT

# asm

Table captionzpchan:

Table captionzchanp:

Table captionzcheat2:

Table captionasm

Table captionztchan:

#

/*

# asm

MOV DX.0FFA0H

port

MOV SI,WORD [BP-*’ MOV AL,BYTE [SI]

5** P

: get I.D. byte

CMP AL.040H

. I for Prog change

JZ zpchan

: - :-if Prog change

CMP AL,041H

I : for Chan pressure, after-touch

JZ zchanp

MOV AL,BYTE [B^-t*

• se -oly. key press, (after-touch)

:•* t'cnsmit chan

ADD AL,0A0H

key pressure

CALL w_f_e_

OUT DX.AL

s f: 'st byte

MOV AL,BYTE [S1+2*

; S*t key f

CALL w_f_e_

OUT DX,AL

MOV AL,BYTE [SI]

pressure

AND AL.01FH

st- *p off bottom 5

SHL AL,1

SHL AL,1

:jp two bits

CALL w_f_e_

OUT DX,AL

JMP za11done2

Z z done

MOV AL,BYTE [BP+«]

change

;* * transmit channel

ADD AL.0C0H

::sc prog chan

JMP zcheat2

_ s e :sde from above routine

MOV AL,BYTE [==-:’

:*r--el pressure get trcnsmit channel

ADD AL.0D0H

::: rcsic chan pres

JMP zcheat2

CALL w_f_e_

e-t'y point from zpchan ; wcit for DART

OUT DX.AL

; eerd byte

MOV AL.BYTE [SU3]

; get new vel

OUT DX.AL

; seftd

>2:

; Flic

,tc)

»tc;

MOV SI,WORD [BP+4] MOV AL.BYTE [SI]

: get p

; get I.D. byte

AND AL,1

; bit 0

JNZ ztchan

; teepo change

MOV AL.0B0H

; now we know It's a cntrl chan ; cntrl chan

ADD AL.BYTE [BP+6]

; odd transmit channel

MOV DX.0FFA0H

; MIDID port

CALL w_f_e_

; wait for DART to empty

OUT DX.AL

MOV AL.BYTE [SI+3]

; get cntrl #

CALL w_f_e_

; wait for DART FIFO to empty

OUT DX.AL

MOV AL.BYTE [SI+4]

; get cntrl val

CALL w_f_e_

OUT DX.AL

JMP _fine2

; done

MOV AL,extsync_

OR AL,AL

; tempo change

; set flags

JNZ _fine2

; If extsync mode, then this has no purpose

tempo(*(p+3)+30);

*/

( continued)

BYTE LISTINGS SUPPLEMENT 383

_fIne2:

?

w_f.e() /* this function

# asm

PUSH DX PUSH AX MOV DX,0FFA2H try_again:

IN AL,DX AND AL,4 JZ try_again POP AX POP DX

t

/*

BT, BT2, BT3

"sleeps" until the FIFO In the DART

; DART status register

; Tx buff empty?

; no?

*/

bto

\

These are the meternome counting routines.

readclk();

I f (beat«c I sb) |

_outb(5,MIDIS+1); /* send sync high */

_outb(128.MIDIS+1);

_outb(5.MIDIS+1); /* send sync low */

_outb(0,MIDIS+1); beat-*s_t_b;

is empty */

bt2()

readclk(); lf(mbeat«*cIsb) j

_outb(0xf8,MIDID); /* MIDI timing elk */

mbeat-=m_t_b;

bt3()

readclk();

I f(abeat==cIsb) \

I f(printer)

beepp(); abeat-=a_t__b;

beepp()

_rax=0x0500;

_rdx«7;

_doint(0x21);

/* SETINT

This routine sets up the interrupt.

*/

setInt()

Int rxintQ.a;

int seg_num, (*fun_add)();

fun_add = rxint; seg_num*_showcs();

_pokeffun_add & 0xff,0x28,0); _pokeffun_add » 8,0x29,0); _poke(seg_num & 0 xff,0 x2a,0 ); _poke(seg_num » 8,0x2b,0); setdart(); setpic();

384

BYTE LISTINGS SUPPLEMENT

setdort()

_outb(24,MIDIS); _outb(1.MIDIS) _outb(3,MIDIs) _outb(4,MIDIS) _outb(5,MIDIS)

setpic()

{

char a; a=_inb(PIC1);

If(a&4)

a-*4;

_outb(o,PICl);

\

/* reset channel A */ _outb(24,MIDIS); /* int on

_outb(193,MIDIS);

_outb(196,MIDIS); _outb(104,MIDIS);

/* read interrupt mask */

/* if DART is masked off */

all Rx + Ext Stat */

/* re-enable ints */

setcounter(11,m1,12,m2) char II,ml,12,m2;

i

char e,d;

— outb(0x34,CSTAT); /* counter 1=mode 2 - read/load both */

e=d; d=e;

_outb(0x70,CSTAT); /* counter 2= mode 0 - read/load both */ e«d; d=e;

_outb(I2.C0UNTER2); /* set LSB of counter 2 */

e=d; d*e;

_outb(m2,C0UNTER2); /* set MSB of counter 2 */

e=d; d*e;

_outb(11,COUNTER1); /* set LSB of counter 1 */

e«d; d=e;

_outb(m1,COUNTER1); /* set MSB of counter 1 */

readclk();

whiIe(cmsb1=255 kk clsb!«255) readcIk();

return;

set.cnt.1(11,m1) char II,ml;

_outb(11,COUNTER1); /* set LSB of counter 1 */

_outb(m1.COUNTERI); /* set MSB of counter 1 */

I

intoff()

outb(01.MIDIS); /*

_outb(00,MIDIS); /*

inton()

_outb(01,MIDIS); /*

- outb(24,MIDIS); /*

readclkQ

I

# asm

turn off my interrupt */ (at the DART) */

turn on my interrupt */ (at the DART) */

MOV AL,64 MOV DX.0FFA7H

CLI ; an interrupt right now from Rxint would be bad

OUT DX.AL

NOP

NOP

NOP

SUB DX,2 IN AL,DX MOV cIsb_,AL

NOP

NOP

NOP

IN AL.DX MOV cmsb_,AL STI

Ints back on

f

(continued)

BYTE LISTINGS SUPPLEMENT 385

scr_cla() /* clear screen Sc pstn cursor at top */

scr_clr(); scr.rowco1(0,0);

/*

*/

mmode() st:

ss:

skip:

MMODE

This Is a no—frills routine for setting up various MIDI system modes

char a,mo,v;

scr_cI a();

prlntff" MIDI mode ass Ignments:\n");

pr intf ("%s\n'\sin.J Ine);

putchar(*\n*); prIntf(" 1

printf(" 2

p r I n t f (" 3

pr Intf (" 4

prIntf(" 5

pr Intf ('* 6

printf(" 7

prIntfi " 0

printf("Enter new mo»getInt(); lf (!mo)

lf(mo>7)

return;

Omn i Omn i Omn i Omn I

ON

OFF

ON

OFF

■)

/ Poly\n / Poly\n / Mono\n") / Mono\n"; - Program change\n");

Al I notes

- AlI notes

- Ex It\n"); mode: '•);

off (all channeIs)\n"); off (one channeI)\n");

goto st;

1f(mo««6)

goto skip;

prIntf("Send over which channel:"); a*getInt(); If(a > 15)

goto ss;

printf("\nChannel %d:\n",a);

swltch(mo) {

case 1:

prlntf(" Poly / Omni on\n");

P°ly(a); o_on(a); break;

case 2:

printf(" Poly / Omni off\n");

poly(a);

omni_off(a);

break;

case 3:

printf(" Mono / Omni on\n"); monofa); o.on(a); break;

case 4:

prlntf(" Mono / Omni off\n"); mono(a); omni_off(a); break;

case 5:

printff" Program change\n"); printf(" Enter new program: "); v»getInt();

_outb(192+a,MIDID);

_outb(v,MIDID); break;

case 6:

for(a=0; a<16; ++a) j

_outb(0xb0+a,MIDID);

_outb(123.MIDID); w_f_e();

_outb(0,MIDID);

i

printf(" All notes off - all channeIs\n");

386 BYTE LISTINGS SUPPLEMENT

getchar(); break;

case 7:

outb(0xb0+a,MIDID); _outb(123,MIDID); w-f-e );

__outb(0,MIDID);

printf(" All notes off\n");

getchar();

break;

i

goto st;

i

o_on(ch) char ch;

outb(176+ch,MIDID); Ioutb(125,MIDID);

w_f_e();

_outb(0,MIDID); getchar();

\

omni_of f(ch) char ch;

outb(176+ch,MIDI0); _outb(124,MIDID);

_outb(0,MIDID); getchar();

\

poly(ch) char ch;

outb(176+ch,MIDID); _outb(127.MIDID);

w_f_e():

_outb(0,MIDID);

getchar();

\

mono(ch) char ch;

{

char v*

prIntf("How many channels? (0 - # In receiver, or other) "); v-getint();

outb(176+ch,MIDID);

_outb(126,MIDID);

wj_e );

_outb(v.MIDID); getchorQ;

\

get_av_mem() /* returns total system RAM - In K */

_doint(0x012); return(_rox);

\

char *_showss()

§ asm

MOV AX.SS

f

hak() /* display "hit any key to continue" & wait */ puts("\n\n");

scr_cls(); „.

p U t 8 (» Hit any key to continue. );

(continued)

BYTE LISTINGS SUPPLEMENT 387

whlle(!scr_csts());

|etInt() /* error check an input line k return int */

char lnln[20],*b,flag;

stg:

.gets(inln,20);

If(strlen(inln)) j

for(b»inIn;*b!■*\0';++b) {

If(11sdig1t (*b) kk *b !- •-’) j putchar(7); goto stg;

^ return(atoi(inln));

e I se

putchar(7); goto stg;

/* ED.IN.FILT

Thi8 routine allows the user to edit the input filter

*/

ed.in.fi 11()

int n;

scr_cla();

scr.rowcol(0,26);

pr Intf("Edit Input Filter\n");

pr intf("%s\n\n",sin.line);

st.fi It:

goto re.try;

if o*o

return;

n*1 « (n-1); /* make n into bit to complement */

in.filt - in.filt & n ? in.filt-n : in.filt+n; goto st.fi It;

& 1) ? yes : & 2) ? yes : & 4) ? yes : & 8) ? yes : & 16) ? yes k 32) ? yes k 64) ? yes

let.options() /* enter various user options */

em; pr1ntf("Enter metrenome speed:"); r_tempo«getInt(); if(r.tempo<40 || r.tempo>200) goto em;

tempo-2000000/((r_tempo*48)/60); printf("Audio Sync (Y/N):"); audmet-ftoupper(getchar())««*Y*) ? 1:0;

putchar(*\n*);

prIntff"Drum Sync (Y/N):"); d8ync«(toupper(getchar())■*'Y*) ? 1:0; putchar(*\n *); prIntf("MIDI Sync (Y/N):"); MIDIsync*(toupper (getchar O)**^* ) ? 1:0;

no) no) no) no) : no : no : no

388

BYTE LISTINGS SUPPLEMENT

/* dlr(fname.ext)

char *fname,*ext;

This function shows a directory of the currently logged directory and disk and print it on the screen in "five-across" format.

*/

di r(fname.ext) /* function to show directory of currently logged disk k dir */ char *fname,*ext; /* pointers to filename k extension */

i

struct fcb {

char drive.num; char fiIename[8]; char extension[3];

char rest[25]; /* the rest of the fcb */

\ fcb;

struct fcb fcb2; unsigned dta.add, dta.seg; char f i Iename[21]; char flag=4; char cnt=80;

fcb.drive_num«0;

strcpy(filename," ");

strncpy(fcb.fiIename,fname,8); strncpyffcb.extens ion,ext,3);

.setmem(fcb.rest,25,0);

.rax=0x2f00; /* get current DTA */

_dolnt(0x21); dta.add«_rbx;

dta_seg*.res; /♦ this is the offset k segment of the current DTA */

_rdx*fcb;

_rds=_showds();

_rax«0x1100;

scr.rowco1(6,0);

printf("%s\n".sin_I 1ne);

scr.rowco1(7,0); scr.cls(); for(;;) }

.do Int(0x21); if((.rax k 0xff))

break; /* last file has been listed */ .lmove(20,dta.add,dta_seg,fcb2,_showds()); strncpy(fiIename,fcb2.fiIename,8); f1 Ienamersl-*.*; fIlenametQJ-’X©*; strcat(fiIename,fcb2.extension); fI Iename[12]*’\0*; puts(fiIename); puts(" M );

If(If lag)

fIag=5;

if(!—cnt) {

printf(" Hit any key to continue.");

getchar();

scr.rowcoI(7,0);

scr.cIs();

cnt«80;

fIag=4;

\

—flag;

.rax«0x1200;

i

BYTE LISTINGS SUPPLEMENT J89

rxint11 .0 TEXT

"A MIDI Project," by Jay Kubicky.

June, page 199. Also download midMIl.c.

0 RXINT:

; version 1.1

; 2/2/86

•

; This is the main receive interrupt.

; It Is called when the DART receives data.

; This version supports carry-over (running) status bytes

; as well as a translate table.

DSEG

Table caption; These are C’s globals

PUBLIC

r.segment.

PUBLIC

Ptr.

PUBLIC

end.

PUBLIC

destbyte.

PUBLIC

c 1 sb_

PUBLIC

cmsb.

PUBLIC

stop.

PUBLIC

LAST.STAT.

PUBLIC

C.O.F.

; status carry-over flag

PUBLIC

c1k.type.

; 0=internal, 1«external

PUBLIC

counter.dec.

PUBLIC

in.f1 It.

; the MIDI input fi1 ter ; bit:

0 = Note on flit

1 « Note off filt

2 = Prog change filt

3 * Channel after-touch

4 - Pitch wheel

5 * AM other controllers

6 * Key after-touch

CSEG ; ALL CODE

PUBLIC rxint.

rxint.:

STI

PUSH AX MOV AL.0B9H OUT 021H,AL PUSH BX PUSH DX PUSH ES PUSH DS MOV AX, 0

MOV DS, AX

MOV BX,WORD [04FAH] MOV DS, BX MOV AX,r.segment. MOV ES, AX

; interrupts back on ; shut off counter interrupt

; this will be new value for the ; DS so we can access the OLD DS

put new DS in BX ; put new DS in DS

; set buffer segment

s s t:

MOV DX.0FFA2H MOV AL, 1 OUT DX.AL IN AL.DX AND AL ,32 JNZ finished

_st:

aval table

IN AL.DX AND AL, 1 JZ .Iret

; midi stat

; rd register 1

; RD reg 1 ; Rx overrun error?

; if so, than we're REALLY done!

; jumped to by _lret if another char is

; read status register ; Rx char?

; if not, return

390 BYTE LISTINGS SUPPLEMENT

Table captionCl:

Table captionC4:

revelation! contzz:

MOV

DX.0FFA0H

; MIDI data

IN

AL.DX

; now let’s read it

MOV

DL ,AL

; store in DL for later

CMP

AL ,0F8H

; timing clock?

JNZ

Cl

; if not, check for

stop

MOV

DL,counter_dec

get amount to decrement

counter

MOV

DH, 0

; we’ll do a word subtract

MOV

AL,c1sb_

; get Isb

MOV

AH,cmsb_

; get msb

SUB

AX,DX

; dcr word

MOV

c1sb_,AL

; store Isb

MOV

cmsb_,AH

; store msb

JMP

_I ret

; if is, all done

CMP

AL.0FCH

; MIDI Stop?

JNZ

C4

; if not, continue

MOV

BYTE stop.., 41

; else, set stop byte

JMP

_! ret

; and return

AND

AL.0F0H

; strip off top 4

CMP

AL,0F0H

; running status?

JZ

_1 ret

; if so, we’re done

MOV

BYTE AL,destc•*

get destbyte

CMP

AL.0FFH

; shal1 we continue?

JZ

_I ret

; if not, then we’re

done

MOV

BL, AL

; keep for later

AND

AL.0F0H

; strip off top four

JZ

_newmsg

; first byte of a new

message

CMP JZ . CMP JZ . CMP JZ . CMP JZ . CMP JZ .

AL.010H .nton AL.020H .nof f AL.070H .keypres AL.040H .bender AL.050H .cchan

What

; branch point from carry-over status ; Note ON?

; yes?

; Note OFF?

; yes?

; Poly key pres?

; Bender?

; yes?

; Control Change?

: yes?

CMP AL.060H JZ _cveI CMP AL.030H JZ _pchan JMP _iret

; Channel Velocity?

; For now, throw away channel velocity ; Prog Change?

: yes?

; This would fall through for FILTed out

; this routine processes the first byte of a given

; message, ana c so decides if it Is an important message

_newmsg:

MOV AL.DL AND AL.080H MOV AL,DL MOV BYTE C_0_F_, 0 JNZ contxx

MOV BYTE AL, LAST STAT_ MOV BYTE C_O_F_,0FFH contxx:

MOV BYTE destbyte_,0

MOV CL,1n_fI 11_ AND AL,0F0H MOV LAST_STAT_,AL CMP AL.090H JZ _nnon CMP AL.080H JZ _nnoff CMP AL,0A0H JZ _nkeypres CMP AL,0E0H JZ _npwch CMP AL.0B0H JZ _ncchan CMP AL.0C0H

it’s a new message ; retrieve

; no carry-over

; check for MIDI carry-over stat.

; get previous status byte ; carry-over status

; this is default in case code isn't ; supported or is filtered out ; this is input f 1 I ter ; strip off channel info.

; save new last stat ; Note ON?

; yes?

; Note OFF?

; yes?

; Poly key press?

; yes?

; Pitch Wheel ; yes?

; Control Change?

; yes?

; Prog. Chan?

codes

[continued)

BYTE LISTINGS SUPPLEMENT 391

June

JZ _npchon CMP AL.0D0H JZ _nchanv JMP _I ret support

; yes?

; Channel Velocity?

* yes?

; otherwise, It must be a code we don’t

_nnon:

AND CL.1

JZ _lret

CALL .stlme

MOV BYTE ES: [BX] , 0

MOV BYTE destbyte.,011H

JMP _cco

first byte of a note on just came in ; keep note-ons?

; no, then al I done.

; store present time

; put 0 at *ptr - I.D. code for note on/off ; note on in dest byte ; check carry-over

_nnoff:

AND CL,2

JZ _Iret

CALL .stlme

MOV BYTE ES: [BX] , 0

MOV BYTE destbyte.,021H

first byte of note off just came in ; keep note-offs?

; no, then a I I done ; same as _nnon (above)

; I.D.

; note off in destbyte

JMP .cco

.ncchan:

AND CL,32 JZ _i ret CALL .stlme MOV BYTE ES:[BX],0C0H MOV BYTE destbyte.,051H JMP _cco

.npchan:

AND CL,4 JZ _J ret CALL .stlme MOV BYTE ES:[BX],040H MOV BYTE destbyte.,031H JMP _cco

_nchanv:

AND CL,8 JZ _Iret CALL _stIme MOV BYTE ES:[BX],041H MOV BYTE destbyte.,061H JMP .cco

.nkeypres:

AND CL,64 JZ _iret CALL .stime MOV BYTE ES:[BX],060H MOV BYTE destbyte_,071H JMP .cco

.npwch:

AND CL, 16 JZ .iret CALL .stime MOV BYTE ES:[BX],080H MOV BYTE destbyte.,041H JMP _cco

_cco: ; check carry over flag

MOV BYTE AL,C_0_F_

OR AL, AL JZ _i ret

MOV BYTE AL.destbyte.

MOV BL.AL AND AL.0F0H JMP contzz

; check carry-over

; first byte of control change

; keep control changes? ; no

; I.D.

; cchan in destbyte

; check carry-over

; 1st byte of program change

; keep prog, changes?

; I.D.

; prog chan in destbyte ; check carry-over

; 1st byte of Channel pressure

; keep channel pressure?

; I.D.

; chan ve I In dbyte

; check carry-over

1st byte of Poly, key pres.

; keep poly, key pres?

; I.D.

; chan vel in dbyte

; check carry-over

; first byte of pitch wheel change ; keep pitch wheel?

; I.D.

; pitch wheel in dbyte ; check carry-over

; get carry over flag ; set flags

; carry over

; now for the routines that are called while a message is in ; progress:

392 BYTE LISTINGS SUPPLEMENT

I me

.nton:

AND BL.1

MOV WORD BX.ptr.

JZ .ntonvel OR DL.080H ADD BX,3

MOV BYTE ES: [BX] ,DL INC BYTE destbyte. JMP .iret .ntonveI:

SHR DL, 1

OR BYTE ES: [BX] ,DL MOV BYTE destbyte.,0 ADD WORD ptr_,4 JMP .iret

; note on processing routine ; BL still has destbyte in it ; get pointer

; must be a 2, so go and save velocity

; set top bit of note ; inr pointer to note ; store it

; inr for velocity, which will come in next ; all done

; must be a velocity byte

; shift velocity byte one to the right ; OR it in

; next byte will be a newmsg ; inr ptr ; all done

_nof f:

AND BL, 1

MOV WORD BX,ptr.

JZ .ntoffvel ADD BX, 3

MOV BYTE ES: [BX] ,DL INC BYTE destbyte. JMP .1 ret _ntoffveI:

SHR DL, 1

OR BYTE ES: [BX] ,DL MOV BYTE destbyte.,0 ADD WORD ptr_,4 JMP _i ret

; note off processing routine ; BL still has destbyte in it

; get pointer into buff ; if destbyte=2, then it must be a velocity ; inr to where we’ll store the note ; store note; top bit should already be 0 ; inr destbyte for velocity ; all done

; must be a velocity byte ; shift DL logically right 1

; OR It in

; next byte will be a newmsg

; now _ptr points to the next message spot ; all done

.pchan:

MOV WORD BX,ptr.

ADD BX, 3

MOV BYTE ES; [BX] ,DL MOV BYTE destbyte.,0 ADD WORD ptr.,4 JMP .iret

; program change (new program)

; get pointer; no need to check byte number

; because only two bytes are transmitted

; this is where we’ll store the new prog. #

; store data ; reset to newmsg

; inr to pstn, of next massage

; all done

.bender:

AND BL, 1 JZ .bmsb

INC BYTE destbyte. JMP .iret

.bmsb:

SHR DL, 1

MOV WORD BX,ptr.

OR BYTE ES: [BX] ,DL ADD WORD ptr.,3 MOV BYTE destbyte.,0 JMP .iret

.cchan:

AND BL.1

MOV WORD BX,ptr.

JNZ .cnum ADD BX, 4

MOV BYTE ES: [BX] ,DL MOV BYTE destbyte.,0 ADD WORD ptr.,5 JMP .iret

.cnum:

ADD BX,3

MOV BYTE ES: [BX] ,DIINC BYTE destbyte.

JMP _1 ret

_cveI:

MOV WORD BX.ptr.

MOV BYTE ES:[BX+3],DL ADD WORD ptr.,4 MOV BYTE destbyte.,0 JMP .Iret

; store bender data ; first data byte?

; if not, than go and store the MSB ; inr for next pass ; all done

; store MSB of bender ; shift DL down 1 ; get ptr

; OR in top 6 of MSB of bender ; inr pointer to next message

; next message wi I I newmsg ; all done

; control change ; control #?

; get ptr.

; if input is control #, then save it ; this is where we’ll store the control value ; store control value

; next byte wi I I newmsg

; inr to next message location

; all done ; number

; address of control number ; store control number

; next byte will be control value ; all done

; channel velocity ; load BX w/pointer ; store velocity

; Inr to next message pstn.

; next byte will be new msg ; all done

(continued)

BYTE LISTINGS SUPPLEMENT 393

_keypres:

AND BL, 1

MOV WORD BX,ptr_

JZ _storepres

ADD BX,3

MOV BYTE ES: [BX] ,DL

INC BYTE destbyte_

JMP _I ret _storepres:

SHR DL, 1

SHR DL, 1

OR ES:[BX],DL

MOV BYTE destbyte_,0

JMP _lret

; poly, key pressure ; amount?

; store key pressure

; this is where to store the note num.

; store It

; next byte will be va 1 .

; store key pressure

; shift DL right 2 (/4)

; OR it in

; next byte new message ; all done

_stime: resu1ts

; routine to read the PIT and store the

PUSH DX

MOV WORD BX,ptr_

MOV AL,clk_type_

OR AL.AL

JNZ ext_c1k

MOV AL.64

MOV DX.0FFA7H

OUT DX.AL

NOP

NOP

MOV DX.0FFA5H

IN AL,DX

MOV BYTE ES:[BX+1],AL

; In the buffer ; preserve data ; get pointer ; get elk type (0»int)

; set flags

; is clk_type=ext_clk??

; counter latching operation ; counter stat ; out to PIT

; stal 1 for time

; counter 2 ; read _clsb ; store in buffer

NOP

NOP

IN AL ,DX

MOV BYTE ES:[BX+2], AL

POP DX

RET

; read _cmsb

; restore data

ext_c1k:

MOV DL,clsb_

MOV DH,cmsb_

MOV BYTE ES:[BX+11,DL

MOV BYTE ES:[BX+2J,DH

POP DX

RET

; timing clock from MIDI

; get MSB & LSB

; store MSB & LSB ; restore DX ; all done

_eo i:

PUSH AX

MOV AL,020H

OUT 020H,AL

POP AX

RET

; send EOI to PIC ; we'll be using this ; EOI ; EOI

; restore AX ; all done

_i ret 1:

CALL _eoi

; execute EOI and then return

finished:

MOV BYTE stop_,0FFH

JMP f 2

; Rx overrun error ; CRITICAL ERROR III

_l ret:

MOV DX,0FFA2H

IN AL.DX

AND AL.1

; all done rout i ne ; DART status reg

; RxD? (THIS WILL HAVE TO BE CHANGED TO CHECK

JNZ sst f 2:

; FOR EXTERNAL STAT. ALSO)

; if so, than go to top of routine ; C equivalent:

; if(end > ptr)

; goto okay;

; else

MOV BX,ptr_

; MOV DX,end_

; CMP DX.BX

; stop=1;

Table caption394 BYTE LISTINGS SUPPLEMENT

JG f3

MOV BYTE stop_,1 ; Woaaaahl! Stop Everything!! - We're out of memory

mov a I,0b8h out 021h,a I POP DS POP ES POP DX POP BX

POP AX ; retrieve registers

call _eoi

IRET ; ALL DONE!!!!!!!

macview.pas TEXT

"Decoding MacPaint on the IBM PC" by Mark Anacker. June, page 131

MACVIEW.PAS - Display MacPaint pictures on the IBM PC graphics adapter.

Mark Anacker 09/24/85

PROGRAM MACVIEW; (*$V-*)

*)

TYPE

STRING255 « STRING[255];

SCANLINE - ARRAY [1..80] OF BYTE; (* hi-res screen is 80 bytes wide *)

CONST

SCANFLAG ; BOOLEAN - TRUE;

ODDLINE : INTEGER = 0;

EVENLINE : INTEGER = 0;

FILNAM : STRING[64];

PNTFIL : FILE OF BYTE;

ELEN ; BYTE;

ELEM : STRING255;

OUTPAT ; STRING255;

LCNT : INTEGER;

CNT ; INTEGER;

XPOS,YPOS : INTEGER;

STLINE.ENLINE : INTEGER;

EVSCREEN : ARRAY [0..99,1..80] OF BYTE ABSOLUTE $B800:$0000;

ODSCREEN : ARRAY [0..99.1..80] OF BYTE ABSOLUTE $B800:$2000;

DOIT : BOOLEAN;

SLPTR : ARRAY [0..719] OF ^SCANLINE; (* pointers to scan line buffers *)

PROCEDURE HELPMSG;

BEGIN

WRITE('MACVIEW - View MacPaint images ... by Mark Anacker'); WRITELNf' 09/24/85'); WRITELN;;

WRITELN('This program will let you view an entire MacPaint image.' WRITELNf'First, transfer the picture file from the Mac. Then,’); WRITELNi'run this program and give it the file name. You may use WRITELNC'the keypad keys 1-3 and 7-9 to scroll over the image.’ WRITELN('Press the space bar to exit back to DOS.');

WRITELN;

WRITELN('You may specify the file name on the command line.’); WRITELN;

WRITELNf'Remember, the aspect ratio is different. The pict.'e • WRITELN('be distorted somewhat in the vertical dIrection.•]: WRITELN;

END;

(continued)

r 'i _ SINGS SUPPLEMENT 395

]une

PROCEDURE GETFILE;

VAR CNT : INTEGER;

INCH : CHAR;

BEGIN

ASSIGN(PNTFIL,FILNAM);

(*$I-*) RESET(PNTFIL); (*$I+*)

IF IORESULTO0 THEN BEGIN

WRITELN(’** Error opening file - halting ***); HALT(1); END;

SEEK(PNTFIL,512); (* skip brush patterns *)

YPOS:-0; LCNT:«0; OUTPAT:-”;

SCANFLAG:-TRUE;

ODDLINE:-0; EVENLINE:«0;

STLINE:-0;

END;

PROCEDURE OUTSCREEN;

VAR CNT.CNT2 : INTEGER;

BEGIN

FOR CNT:-1 TO LENGTH(OUTPAT) DO

OUTPAT[CNT];-CHR(NOT ORD(OUTPAT[CNT])); NEW(SLPTR[LCNTl);

FILLCHAR(SLPTR[LCNT]*,80,CHR(0));

MOVE(OUTPAT[1],SLPTR[LCNT] * .72);

END;

(* display line *)

(* invert bits to black *)

(* on white like the Mac *)

(* allocate a new buffer line*) (♦fill it to bIack *)

(* and copy the decoded bits *)

PROCEDURE PUTLINE; (*

BEGIN

OUTPAT:-OUTPAT+ELEM; (*

IF LENGTH(0UTPAT)>«72 THEN (*

BEGIN

IF LENGTH(0UTPAT)>72 THEN (*

OUTPAT;-COPY(OUTPAT.1,72); OUTSCREEN; (*

LCNT:-LCNT+1; OUTPAT:-••;

FILLCHAR(OUTPAT,75,CHR(0)); (* END;

END;

decide if we need to do line *)

build scan line pattern *)

If we have a full line, *)

if too long, truncate *)

put it in the buffer *)

reset the string *)

PROCEDURE REPBLOCK; (*

VAR TMPBYTE ; BYTE;

CNT : INTEGER;

BEGIN

ELEN:«(256-ELEN); (*

READ(PNTFIL.TMPBYTE); ( *

ELEM:-**;

FOR CNT:«0 TO ELEN DO

ELEM:-CONCAT(ELEM,CHR(TMPBYTE)); PUTLINE; (*

END;

block of repeating data *)

get character count *) get character to repeat *)

(* make string of chars. *) test for a complete scan line *)

PROCEDURE MIXBLOCK; (* block of mixed, raw data *)

VAR TMPBYTE : BYTE;

CNT ; INTEGER;

BEGIN

ELEM:-'*;

FOR CNT:-0 TO ELEN DO BEGIN

READ(PNTFIL,TMPBYTE); (* get characters *)

ELEM:-CONCAT(ELEM,CHR(TMPBYTE)); (* add to running pattern *)

END;

PUTLINE; (* test for complete scan line *)

END;

PROCEDURE LOADBUF; (* read data from file *)

BEGIN

GETFILE; (* open file *)

WRITELN(* Loading picture into buffer ... Please wait a moment*); REPEAT BEGIN

READ(PNTFIL,ELEN); (* get a byte *)

IF ELEN>127 THEN (* if 8th bit set. *)

REPBLOCK (* it * s a repeater, else *)

ELSE

MIXBLOCK; (* it*s mixed *)

396 BYTE LISTINGS SUPPLEMENT

I une

END;

UNTIL LCNT>*726; (* until all 720 lines are done *)

CLOSE(PNTFIL);

END;

PROCEDURE SHOWBUF; (* display the buffer on screen *)

VAR CNT : INTEGER;

BEGIN

EVENLINE:*0; OOC_ls£:*0

FOR CNT:*STLINE DO (* show the current 200 scan lines *)

BEGIN

IF (CNT AND *'ol TrEN (* even line *)

BEGIN

MOVE (SL?~[] V EVSCREEN[EVENLINE, 1 ] . 80) ; EVENLINE :*EVESLlsE+1;

END

ELSE

BEGIN (• odd line *)

M0VE(SLP7R[CK7]~.OC$CREEN[ODDLINE.1],80); OOOLINE:-OODLI*C+1;

END;

END;

END;

(* even I ines *)

(* odd Iines *)

PROCEDURE MOVEIT; (* scroll the picture up and down *)

CONST

FKTABLE : STRING[6l * *OPCG-I*; (* cursor/numeric key *)

FKEQUIV : STRING[6j * '123789*; (* conversion table *)

VAR INCH : CHAR;

CNT : INTEGER;

BEGIN

REPEAT

G0T0XY(75,1); WRITE(STLINE:3); (* put top scan line in upper corner

READ(KBD,INCH); (* get the key from the user *)

IF (INCH*CHR(27)) AND KEYPRESSED THEN (* if a real cursor key, *) BEGIN

READ(KBD,INCH); (* get the key code *)

IF POS(INCH,FKTA3LE)>0 THEN (* and convert to it's number *) BEGIN

CNT:-POS(INCH,FKTABLE); INCH:«FKEQUIV[CNT];

END;

END;

CASE INCH OF

'8* : BEGIN (* move image UP *)

IF STLINE<520 THEN BEGIN

FOR CNT:*0 TO 98 DO BEGIN

MOVE(EVSCREEN[CNT+1,11,EVSCREEN[CNT,11.72);

MOVE(ODSCREEN[CNT+1,1],ODSCREEN[CNT,1J,72);

END;

FILLCHAR(EVSCREEN[99,11,72,CHR(0));

FILLCHAR(ODSCREEN[99.1],72.CHR(0));

STLINE:-STLINE+2;

MOVE(SLPTR[STLINE+198l A ,EVSCREEN[99,11,72);

MOVE ( SLPTR [ STL INE+199 j 4 *, ODSCREEN [99,1 J ,72) ;

END;

END;

*2' : BEGIN (* move image DOWN *)

IF STLINE>1 THEN BEGIN

FOR CNT:*99 DOWNTO 1 DO BEGIN

MOVE(EVSCREEN[CNT-1,11,EVSCREEN[CNT,11,72);

MOVE(ODSCREEN[CNT-1,1J,ODSCREEN[CNT,11.72);

END;

FILLCHAR(EVSCREEN[0,11,72,CHR(0));

FILLCHAR(ODSCREEN[0.1J.72,CHR(0));

STLINE:*STLINE-2;

MOVE(SLPTR[STLINE]*,EVSCREEN[0,1],72);

MOVE(SLPTR[STLINE+1]*,ODSCREEN[0,11,72);

END;

END;

'3' : BEGIN (* page image DOWN *)

STLINE:"STLINE-100;

*)

{continued)

BYTE LISTINGS SUPPLEMENT 397

June

IF STLINE<0 THEN STLINE:-0;

SHOWBUF;

END;

*9* : BEGIN (* page Image UP *)

STLINE:-STLINE+100;

IF STLINE>520 THEN STLINE;-520;

SHOWBUF;

END;

•7* : BEGIN (* go to TOP of image *)

STLINE:«0; SHOWBUF;

END;

*1* : BEGIN (* go to BOTTOM of image *)

STLINE:*514; SHOWBUF;

END

END;

UNTIL INCH-* *; f* exit when SPACE bar is pressed *)

END; (* moveit *)

(* main section *)

BEGIN

TEXTC0L0R(7);

IF PARAMCOUNT-0 THEN BEGIN HELPMSG;

WRITE('MacPaint file name ; IF FILNAM-** THEN HALT(2); END ELSE

FILNAM:-PARAMSTR(1);

IF POS(*.*,FILNAM)-0 THEN FILNAM:«FILNAM+ *.MCP *;

LOADBUF;

HIRES;

SHOWBUF;

MOVEIT;

CLRSCR;

END.

* set color to gray *)

* If a blank command line, *)

(* show message, prompt for file *) *); READLN(FILNAM);

(* If none given, exit to DOS *)

f* else get file name from cmd line *) f* if no extension was given, *) t* assume .MCP *)

(* load the file *)

switch to hl-res mode *)

C* display the buffer *) move it up and down *)

(* clear the screen when done *)

398 BYTE LISTINGS SUPPLEMENT

DISKS AND DOWNLOADS

Ordering Disks of BYTE Usr sgs

Listings that accompany BYTE anides are available in a variety of disk formats and on Cauzin Softstrip. Each disk package (which som et im es consists of more than one disk) contains an entire month s listings. If you want to order a is* package from a previous month, please call (603; 924-9281 to find out how many disks it includes. 1b order listings (for noncommercial use only), fill out this form and send a check or money order in the correct amount to:

BYTE Listings

One Phoenix Mill Lar.e

Peterborough. NH 03-158

All prices include postage Prograr listings can also be downloaded via BYTEnet Listings at (617) 861-9764.

BYTE issue: _

COMMON 5 W-INCH FORMATS

All cost $8.95. $10.95 outside US A. Annual subscription is $69.95. $89.95 outside U.S.A.

□ Apple II 514-inch DOS 3.3

□ Apple II 514-inch ProDOS

□ Hewlett-Packard 125

□ IBM PC

□ Kaypro 2 CP/M

□ Texas Instruments Professional

□ TRS-80 Model III

□ TRS-80 Model 4

□ Zenith Z-100

COMMON 3'/2-INCH FORMATS

All cost $9.95, $11.95 outside U.S.A. Annual

subscription is $79.95, $99.95 outside U.S.A.

□ Apple Macintosh

□ Atari 520ST

□ Commodore Amiga

□ Data General/One

□ Hewlett-Packard 150

CP/M STANDARD 8-INCH FORMAT

All cost $9.95, $11.95 outside U.S.A. Annual

subscription is $79.95, $99.95 outside U.S.A.

□ Single-sided single-density

□ Double-sided double-density

OTHER FORMATS

Due to the diversity of requests and the custom work involved, there will be some delay in fulfilling these requests. All cost $9.95, $11.95 outside U.S.A. Annual subscription is $79.95, $99.95 outside U.S.A.

Size □ 8-inch □ 514-inch □ 3'/5-inch

Machine _

SEND TO:

Name_

Street_

City_State or Province_

Postal Code_Country_

Check or money order enclosed for $_

Bulletin Boards in Canada

Listed below are some computer bulletin boards that carry program listings from BYTE. Programs are for noncommercial use in connection with BYTE articles only. Some BBSs may charge an annual maintenance fee. and you must pay your own telephone charges.

Western Canadian Distribution Center 3421 - ; -.St.. Edmonton. Alberta T6L 3R5) will be supplying listings to its member bulletin board systems

Edmonton. Alberta. (403) 454-6093 Meadowlark, Alberta. (403) 435-6579 Montreal. Quebec. PComm Sysie~s 1 514) 989-9450 Prince George. British Columbia 16Tu, 562-9519 Regina. Saskatchewan. (306) 5 5r-~585 Canadian Remote Systems. Toronto

Toronto. Ontario. Epson Club _ :-onto (EPCOT). (416) 635-9600

Winnipeg, Manitoba. i204| - -1-" 529

In addition, arrangements for BYTEnet Listings have been made with one or mote system operators in the following nations: Ausbafia Austria. Brazil. Denmark. France Hc-g Kccg Indonesia Italy. lapan. Malaysia. The Netherlands. Kgeria. Norway. Saudi Arabia. Singapote Sweden. Switzerland. United Kingdom, and Ifest Germany. Contact us at (603) 924-9281 for an iMcxlate fist ■

JST1NGS SUPPLEMENT 399

EDITORIAL CALENDAR

1987

May — Desktop Publishing: An exploration of the hardware and software needed for desktop publishing, from page description languages to high-resolution printers and typesetting back ends.

June — Computer-Aided Design: The anatomy of computer-aided design/drafting software, the graphics display devices needed for CAD. and the data structures used by CAD programs to export data to other applications.

JULY — Local Area NETWORKS: The technology of linking personal computers together to share data files, programs, and peripheral devices.

AUGUST — PROLOG: A look at logic programming with articles on tips and techniques and explorations of the tasks Prolog is best suited for.

SEPTEMBER — PRINTER TECHNOLOGIES: An examination of the state of the art in printer technologies, including laser, liquid-crystal shutter, and ink-jet technologies.

October — Heuristic Algorithms: Artificial intelligence techniques for giving computers the ability to learn from experience.

November — High-Performance Workstations: A tour of the technology underlying the workstations used by scientists and engineers in computer-aided engineering/design.

December — Natural Language Processing: The technology of getting computers to understand the natural language of man.

1988

JANUARY Managing MEGABYTES: Looking at the ways computers store and retrieve data in situations where disk space is measured in gigabytes and memory is measured in megabytes. Also a look at the new applications that mega-memory and storage will permit.

FEBRUARY — LISP: A BYTE reexamination of the original language of artificial intelligence research.

March Floating-Point Processors: a look at the processors that speed the computation of mathematical operations in personal computers, including coprocessors and array processors.

APRIL Memory Management The hardware and software issues in managing a personal computer s memory space.

MAY CPU ARCHITECTURES: An exploration of the latest 32-bit microprocessors, including digital signal processors and programmable graphics processors.

Six great reasons to join EIX today

• Over 140 microcomputer-related conferences:

loin only those subjects that interest you and change selections at any time. Take pan when it's convenient for you. Share information opinions and ideas in focused discussions with other BIX users who share your interests. Easy commands and conference digests help you quickly locate important information.

• Monthly conference specials:

BIX specials connect you with invited experts in leading-edge topics—CD-ROM. MIDI OS-9 and more They're all part of your BIX membership

• M icrobytes daily:

Get up-to-the-minute industry news and new prod -ct information by joining Microbytes Daily and Whafs New Hardware and Software.

• Public domain software:

Yours for the downloading, including programs from BYTE articles and a growing library of PD listings

• Electronic mail:

Exchange private messages with BYTE editors and authors and other BIX users.

BIX User’s Manual and Subscriber Agreement as Soon as Wve Processed Your Registration. JOIN THE EXCITING WORLD'

OF BIX TODAY!

• Vendor support:

A growing number of microcomputer manufacturers use BIX to answer your questions about the:: products and how to use them for peak performance.

What BIX Costs. .How You Pay

Join BIX Right Now:

Set your computer's telecommunications program for full duplex. 8-bit characters, even parity. 1 stop bit OR 7-bit characters, even parity. 1 stop usmg 300 O' :20C baud.

Call your local tymnet number and respond as fcf cws

ONE-TIME REGISTRATION FEE S25

Hourly

Charges:

(Your Time of Access)

Off-Peak

6PM-7AM

Weekdays Plus Weekends & Holidays

Peak

7AM-6PM

Weekdays

Tymnet Prompt You Enter

Garble or "terminal identifier a

login: password: mhis login:

BIX Logo—Name:

byteneti <CR> mgh <CR> bix <CR> new <CR>

Note 1

Note 2

Note 3

Note 4

Note 5

Note 6

Note 7

Note 8

After you register on-line, you :e —ed:ately taken to the BIX learn conference ann : m r.a~ ,5 ng the system right away.

Foreign Access:

To access BIX from foreip) countries, you must have an account with your local Pose! 'Mephone & telegraph (PTT) company. From your PTT e nt er 310600157878. Then enter bix <CR> and new <CR> at the prompts Call or write us for PTT contact information

BIX

One Phoenix Mill Lane Peterborough NH 03458 (603i 924-9281

Announcing BYTE’s New Subscriber Benefits

Y

-Lou

Program

.our BYTE subscription brings you a complete diet of the latest in microcomputer technology every 30 days. The kind of broad-based objective coverage you read in every issue. In addition , your subscription carries a wealth of other benefits. Check the check list:

DISCOUNTS

id 13 issues instead of 12 if you send payment with subscription order.

ijf One-year subscription at $21 (50% off cover price).

id Two-year subscription at $38.

Three-year subscription at $55.

2 One-year GROUP subscription for ten or more at $17.50 each. (Call or write for details.)

SERVICES

BIX: BYTE’s Information Exchange puts you on-line 24 hours a day with your peers via computer conferencing and electronic mail. All you need to sign up is a microcomputer, a modem, and telecomm software.

jd Reader Service: For information on products advertised in BYTE, circle the numbers on the Reader Service card enclosed in each issue that correspond to the numbers for the advertisers you select. Drop it in the mail and we’ll get your inquiries to the advertisers.

^ TIPS: BYTE’s Telephone Inquiry System is available to

subscribers who need fast response. After obtaining your Subscriber I.D. Card, dial TIPS and enter your inquiries. You’ll save as much as ten days over the response to Reader Service cards.

li Disks and Downloads:

Listings of programs that accompany BYTE articles are now available free on the BYTEnet bulletin board, and on disk or in quarterly printed supplements.

Si Microform: BYTE is available in microform from University Microfilm International in the U.S. and Europe.

^ BYTE’s BOMB: BYTE’s Ongoing Monitor Box is your direct line to the editor’s desk. Each month, you can rate the articles via the Reader Service card. Your feedback helps us

keep up to date on your information needs.

Si Customer Service: If you have a problem with, or a question about, your subscription, you may phone us during regular business hours (Eastern time) at our toll-free number: 800258-5485. You can also use Customer Service to obtain back issues and editorial indexes.

BONUSES

Jfcj Annual Separate Issues: In addition to BYTE’s 12 monthly issues, subscribers also receive our annual IBM PC issue free of charge, as well as any other annual issues BYTE may produce.

2 BYTE Deck: Subscribers receive five BYTE postcard deck mailings each year—a direct response system for you to obtain information on advertised products through return mail.

To be on the leading edge of microcomputer technology and receive all the aforementioned benefits, make a career decision today. Call toll-free weekdays, 8:30am to 4:30pm Eastern time: 800-258-5485.

And. . . welcome to BYTE country!

Chapter Notes

BIX $9 $12

tymnet* * $2 $6

TOTAL SI 1/hr. $ 18/hr.**

• Continental U.S. BIX is accessible via Tymnet from throughout the US. at charges much less than regular long distance. Call the BIX helpline number listed below for the Tymnet number near you or Tymnet at 1-800-336-0149 '* User is billed for time on system tie.. Vt Hr. Off-Peak wTymnet - S5.50cfwr^.|

BIX and Tymnet charges billed by Visa or Mastercard only.

BIX Helpline

(8:30 AM-IL30 PM Eastern Weekdays)

U.S. (except NH|-1-800-227-BYTE Elsewhere (603) 924-7681

BITE

THE SMALL SYSTEMS JOURNAL

m