earlw@pesnta.UUCP (Earl Wallace) (06/12/85)
#! /bin/sh # # This is the Little Smalltalk program that Marc Ries of the P-E Tustin Office # acquired and passed on to me. It should work with Perkin-Elmer's Edition VII # and XELOS systems. # # -earlw@pesnta # #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # projects # This archive created: Tue Jun 11 19:06:39 1985 # By: Earl Wallace (Perkin-Elmer Data Systems Group / Customer Service) export PATH; PATH=/bin:$PATH if test ! -d 'projects' then mkdir 'projects' fi cd 'projects' if test -f 'READ_ME' then echo shar: will not over-write existing file "'READ_ME'" else cat << \SHAR_EOF > 'READ_ME' This is a directory of various projects submitted by various students. No guarentee if any of them work with the current system, or even if they work at all. (note - in order to save files, many directories have been converted into bundles. to recreate, create a directory and sh the files.) /browser - an attempt at a ``browser'', actually some of these ideas are quite good, and will probably be included in some future distibution /history - a ``history'' mechanism, similar to csh /window - a window package based upon the Maryland Windows package /simulation - an ice cream store simulation /generator - various playthings for manipulating monadic generators SHAR_EOF if test 672 -ne "`wc -c < 'READ_ME'`" then echo shar: error transmitting "'READ_ME'" '(should have been 672 characters)' fi fi # end of overwriting check if test -f 'hanoi' then echo shar: will not over-write existing file "'hanoi'" else cat << \SHAR_EOF > 'hanoi' From rogerh Fri Dec 14 14:11:54 1984 Received: by arizona.UUCP (4.12/4.7) id AA07979; Fri, 14 Dec 84 14:11:36 mst Date: Fri, 14 Dec 84 14:11:36 mst From: rogerh (Roger Hayes) Message-Id: <8412142111.AA07979@arizona.UUCP> To: budd Subject: hanoi.st Status: R Class Hanoi | a b c | [ new a <- Pole new: 10. b <- Pole new: 300. c <- Pole new: 600 | setup | screen rop d | screen <- Form new becomeScreen. rop <- RasterOp new. rop destForm: screen. rop dest: 0@0. rop extent: screen extent. rop rule: (rop ruleFor: #white). rop copyBits. (4 to: 1 by: -1) do: [ :n | d <- Disk new: n. (d isNil) ifTrue: [ ^ nil]. d moveTo: a horiz. a push: d. ] | exec self move: 4 from: a to: b using: c. ^ 'Done!' | move: n from: s to: d using: x (n > 1) ifTrue: [ self move: (n-1) from: s to: x using: d. self moveTop: s to: d. self move: (n-1) from: x to: d using: s ] ifFalse: [ self moveTop: s to: d ] | moveTop: pole1 to: pole2 | disk | disk <- pole1 pop. disk moveTo: (pole2 horiz). pole2 push: disk ] Class Pole | disks horiz nextVert | [ horiz ^ horiz | pop | d | d <- disks removeLast. d pop. nextVert <- nextVert + d thickness. ^ d | push: d disks addLast: d. nextVert <- nextVert - d thickness. d push: nextVert | new: aNumber nextVert <- 400. disks <- OrderedCollection new. horiz <- aNumber ] Class Disk | form pos rop | [ new: size form <- Form new read: ('d',(size asString),'Form'). (form extent x = 0) ifTrue: [ ^ self error: 'cant find disc ', (size asString)]. rop <- RasterOp new. rop sourceForm: form. rop source: 0 @ 0. rop rule: (rop ruleFor: #copy). rop destForm: (Form new becomeScreen). rop dest: 0 @ 0. rop extent: form extent. pos <- 0 @ 0 | thickness ^ form extent y | moveTo: x | i | (x < (pos x)) ifTrue: [i <- -3] ifFalse: [i <- 3]. ((pos x) to: x by: i) do: [ :newx | rop dest: newx @ (pos y). rop copyBits]. pos <- rop dest | pop " take self off pole " ((pos y) downTo: (200 - self thickness)) do: [ :y | rop dest: (pos x) @ y. rop copyBits]. " elevate to transport level " ((rop dest y) downTo: 150) do: [ :y | rop dest: (pos x) @ y. rop copyBits]. pos <- rop dest | push: y | thisx | " descend to top of rod " thisx <- pos x. ((pos y) to: 200) do: [ :y | rop dest: thisx @ y. rop copyBits]. " impale self " (200 to: y) do: [ :y | rop dest: thisx @ y. rop copyBits]. pos <- rop dest ] SHAR_EOF if test 4047 -ne "`wc -c < 'hanoi'`" then echo shar: error transmitting "'hanoi'" '(should have been 4047 characters)' fi fi # end of overwriting check if test -f 'simulation.bun' then echo shar: will not over-write existing file "'simulation.bun'" else cat << \SHAR_EOF > 'simulation.bun' : To unbundle, sh this file echo unbundling prob.st 1>&2 cat >prob.st <<'End' Class DiscreteProbability | randnum | [ initialize randnum <- Random new | next ^ self inverseDistribution: randnum next | computeSample: m outOf: n m > n ifTrue: [^ 0.0] ^ n factorial / (n - m) factorial ] Class Geometric :DiscreteProbability | prob | [ mean: m prob <- m | mean ^ 1.0 / prob | variance ^ (1.0 - prob) / prob * prob | density: x x > 0 ifTrue: [^prob * ((1.0-prob) raisedTo: x-1)] ifFalse: [^1.0] | inverseDistribution: x ^ (x ln / (1.0 - prob) ln) ceiling ] Class Binomial :DiscreteProbability | number prob | [ events: num mean: p (p between: 0.0 and: 1.0) ifFalse: [self error: 'mean must be > 0']. number <- num. prob <- p | mean ^ prob | variance ^ prob * (1 - prob) | density: x (x between: 0.0 and number) ifTrue: [^((self computeSample: x outOf: number) / (self computeSample: x outOf: x)) * (prob raisedTo: x) * ((1 - prob) raisedTo: number - x)] ifFalse: [^0.0] | inverseDistribution: x x <= prob ifTrue: [^ 1] ifFalse: [^ 0] | next | t | t <- 0. number timesRepeat: [t <- t + super next]. ^ t ] End echo unbundling prob.uniform 1>&2 cat >prob.uniform <<'End' Class ProbabilityDistribution :Stream [ new "create instance" ^ self basicNew | next "random sampling" ^ self inverseDistribution: U next | density: x "is the density func" self subclassResponsibility | distribution: aCollection "cum prob func, arg range of vals" self subclassResponsibility | inverseDistribution: x self subclassResponsibility | computeSample: m outOf: n m > n ifTrue: [^0.0] ^ n factorial / (n - m) factorial ] Class ContinuousProbability :ProbabilityDistribution [ distribution: aCollection | t aStream x1 x2 y1 y2 | t <- 0.0. aStream <- ReadStream on: aCollection. x2 <- aStream next. y2 <- self density: x2. [x1 <- x2. x2 <- aStream next] whileTrue: [y1 <- y2. y2 <- self density: x2. t <- t + ((x2 - x1) * (y2 + y1))]. ^ t * 0.5 ] Class Uniform :ContinuousProbability | startNumber stopNumber | [ from: begin to: end begin > end ifTrue: [self error "illegal interval"] ifFalse: [^ self new setStart: begin toEnd: end] | mean ^ (startNumber + stopNumber) / 2 | variance ^ (stopNumber + startNumber) squared / 12 | density: x (x between: startNumber and: stopNumber) ifTrue: [^1.0 / (stopNumber - startNumber)] ifFalse: [^0] | inverseDistribution: x ^ startNumber + (x * (stopNumber - startNumber)) | setStart: begin toEnd: end startNumber <- begin. stopNumber <- end ] End echo unbundling sim.1 1>&2 cat >sim.1 <<'End' Class Simulation :Object | currentTime action aProbDist totalProfit | [ initialize currentTime <- 0.0. totalProfit <- 0 | scheduleArrivalOf: actionBlock accordingTo: aProbabilityDistribution action <- actionBlock. aProbDist <- aProbabilityDistribution | startUp self initialize. self defineArrivalSchedule | proceed currentTime <- currentTime + aProbDist next. action value | time ^ currentTime | thisProfit: aNumber totalProfit <- totalProfit + aNumber | reportProfit totalProfit print | defineArrivalSchedule | customer profit | self scheduleArrivalOf: [customer <- Visitor new init. profit <- customer numberScoops * 40 / 100. self thisProfit: profit] accordingTo: Random new ] Class Visitor :Object | random | [ init random <- Random new | numberScoops | scoops | scoops <- 1 / (random next). ^ scoops ] End echo unbundling sim.2 1>&2 cat >sim.2 <<'End' Class Simulation :Object | currentTime eventQueue numberChairs newVisitor superVisitor numberServed visitorProbDist missedGroup totalProfit profitMargin coneCost | [ startUp self initialize. self defineArrivalSchedule. superVisitor <- SimulationObject new init. eventQueue at: self timeNextVisitor put: (newVisitor value: superVisitor) | initialize currentTime <- 0.0. numberChairs <- 12. profitMargin <- 0.75. coneCost <- 0.70. totalProfit <- 0. numberServed <- 0. missedGroup <- 0. eventQueue <- Dictionary new | defineArrivalSchedule self scheduleArrivalOf: [:superV | Visitor new initialize: superV] accordingTo: (Geometric new initialize mean: 24 / 60) | scheduleArrivalOf: aVisitor accordingTo: aProbabilityDistribution newVisitor <- aVisitor. visitorProbDist <- aProbabilityDistribution | timeNextVisitor ^ currentTime + visitorProbDist next | time ^ currentTime | proceed | visitor minTime | eventQueue at: self timeNextVisitor put: (newVisitor value: superVisitor). minTime <- 999999. eventQueue keysDo: [:x | x < minTime ifTrue: [minTime <- x] ]. visitor <- eventQueue removeKey: minTime ifAbsent: (self error: 'no visitor in eventQueue'). self incrTime: minTime. (visitor entering) ifTrue: [(visitor groupSize <= numberChairs) ifTrue: [self tasks: visitor] ifFalse: [self missed: visitor groupSize] ] ifFalse: [self releaseChairs: visitor groupSize] | incrTime: aNumber currentTime <- currentTime + aNumber | tasks: aVisitor self served: aVisitor groupSize. self takeChairs: aVisitor groupSize. self thisProfit: aVisitor groupSize * 1.5 * coneCost * profitMargin. "1.5 cones/person" eventQueue at: currentTime + aVisitor time put: aVisitor | served: aNumber numberServed <- numberServed + aNumber | takeChairs: aNumber numberChairs <- numberChairs - aNumber | releaseChairs: aNumber numberChairs <- numberChairs + aNumber | missed: aNumber missedGroup <- missedGroup + aNumber | report 'total profit' print. totalProfit print. 'number of people served' print. numberServed print. 'number of people turned away' print. missedGroup print | thisProfit: aNumber totalProfit <- totalProfit + aNumber ] Class Visitor :SimulationObject | sizeGroup wait alreadyEaten | [ initialize: superClass sizeGroup <- superClass size. wait <- superClass wait: sizeGroup. alreadyEaten <- false | entering (alreadyEaten == false) ifTrue: [alreadyEaten <- true. ^ true]. ^ false | time ^ wait | groupSize ^ sizeGroup ] Class SimulationObject :Object | sizeDist waitDist | [ init sizeDist <- Binomial new initialize events: 5 mean: 0.4. waitDist <- Random new "uniform distribution" | size ^ sizeDist next | wait: sizeGroup "uniform distribution from 1 to 6" ^ waitDist next * sizeGroup * 6 ] End echo unbundling sim.3 1>&2 cat >sim.3 <<'End' Class Simulation :Object | currentTime eventQueue resources newVisitor superVisitor visitorProbDist | [ startUp self initialize. self defineArrivalSchedule. superVisitor <- SimulationObject new init. self addNextEvent | initialize currentTime <- 0.0. eventQueue <- Dictionary new | initResources: aNumber resources <- aNumber | scheduleArrivalOf: aVisitor accordingTo: aProbabilityDistribution newVisitor <- aVisitor. visitorProbDist <- aProbabilityDistribution | timeNextVisitor ^ currentTime + visitorProbDist next | time ^ currentTime | proceed | visitor minTime | minTime <- 999999. eventQueue keysDo: [:x | x < minTime ifTrue: [minTime <- x] ]. visitor <- eventQueue removeKey: minTime ifAbsent: (self error: 'no visitor in eventQueue'). currentTime <- minTime. self tasks: visitor. self addNextEvent | addNextEvent eventQueue at: self timeNextVisitor put: (newVisitor value: superVisitor) | delay: visitor for: time eventQueue at: currentTime + time put: visitor | numResources ^ resources | takeResources: aNumber resources <- resources - aNumber | releaseResources: aNumber resources <- resources + aNumber ] Class IceCreamStore :Simulation | numberChairs missedGroup servedGroup totalProfit profitMargin coneCost | [ initialize super initialize. servedGroup <- 0. missedGroup <- 0. totalProfit <- 0. profitMargin <- 0.75. coneCost <- 0.70. numberChairs <- 8. super initResources: numberChairs | defineArrivalSchedule super scheduleArrivalOf: [:superV | Visitor new initialize: superV] accordingTo: (Geometric new initialize mean: 14 / 60) "expect 18 parties per hour" | tasks: visitor (visitor entering) ifTrue: [(visitor groupSize <= super numResources) ifTrue: [self getIceCream: visitor] ifFalse: [self missed: visitor groupSize] ] ifFalse: [self releaseChairs: visitor groupSize] | getIceCream: aVisitor self served: aVisitor groupSize. self takeChairs: aVisitor groupSize. self thisProfit: aVisitor groupSize * 1.5 * coneCost * profitMargin. "1.5 cones/person" super delay: aVisitor for: aVisitor time | takeChairs: aNumber super takeResources: aNumber | releaseChairs: aNumber super releaseResources: aNumber | missed: aNumber missedGroup <- missedGroup + aNumber | served: aNumber servedGroup <- servedGroup + aNumber | thisProfit: aNumber totalProfit <- totalProfit + aNumber | report 'total profit' print. totalProfit print. 'number of people served' print. servedGroup print. 'number of people turned away' print. missedGroup print ] End echo unbundling simulat.results 1>&2 cat >simulat.results <<'End' time: 35 profit: 13.38 served: 17 turned away: 23 End echo unbundling visitor.st 1>&2 cat >visitor.st <<'End' Class SimulationObject :Object | sizeDist waitDist | [ init sizeDist <- Binomial new initialize events: 5 mean: 0.4. waitDist <- Random new "uniform distribution" | size ^ sizeDist next | wait: sizeGroup "uniform distribution from 1 to 6" ^ waitDist next * sizeGroup * 6 ] Class Visitor :SimulationObject | sizeGroup wait alreadyEaten | [ initialize: superClass sizeGroup <- superClass size. wait <- superClass wait: sizeGroup. alreadyEaten <- false | entering (alreadyEaten == false) ifTrue: [alreadyEaten <- true. ^ true]. ^ false | time ^ wait | groupSize ^ sizeGroup ] End SHAR_EOF if test 10103 -ne "`wc -c < 'simulation.bun'`" then echo shar: error transmitting "'simulation.bun'" '(should have been 10103 characters)' fi fi # end of overwriting check if test -f 'generator.bund' then echo shar: will not over-write existing file "'generator.bund'" else cat << \SHAR_EOF > 'generator.bund' : To unbundle, sh this file echo unbundling 8queen.st 1>&2 cat >8queen.st <<'End' Class Main [ main | lq | lq <- nil. (1 to: 8) do: [:i | lq <- Queen new ; setColumn: i neighbor: lq]. lq first. lq printBoard. lq next. lq printBoard. ] Class Queen | row column neighbor | [ setColumn: aNumber neighbor: aQueen column <- aNumber. neighbor <- aQueen | first (neighbor notNil) ifTrue: [neighbor first]. row <- 1. ^ self testPosition | next (row = 8) ifTrue: [((neighbor isNil) or: [neighbor next isNil]) ifTrue: [ ^ nil ]. row <- 0 ]. row <- row + 1. ^ self testPosition | testPosition (neighbor isNil) ifTrue: [ ^ row ]. (neighbor checkRow: row column: column) ifTrue: [ ^ self next ] ifFalse: [ ^ row ] | checkRow: testRow column: testColumn | columnDifference | columnDifference <- testColumn - column. (((row = testRow) or: [row + columnDifference = testRow]) or: [row - columnDifference = testRow]) ifTrue: [^ true]. (neighbor notNil) ifTrue: [^ neighbor checkRow: testRow column: testColumn] ifFalse: [ ^ false ] | printBoard (neighbor notNil) ifTrue: [ neighbor printBoard ]. ('column ', column printString, ' row ', row printString) print ] End echo unbundling abgen.st 1>&2 cat >abgen.st <<'End' Class AbstractGenerator :Generator | baseGenerator initBlock control transform | [ gen: aGenerator init: aBlock control: controlBlock transform: transformBlock baseGenerator <- aGenerator. initBlock <- aBlock. control <- controlBlock. transform <- transformBlock | first | item | initBlock value. item <- baseGenerator first. (item isNil) ifTrue: [^nil] ifFalse: [^ self computeValue: item ] | next ^ self computeValue: (baseGenerator next) | computeValue: aValue ^ Switch new: (control value: aValue) ; case: 1 do: [^ nil] ; case: 2 do: [^ self next] ; case: 3 do: [^ transform value: aValue ] ; case: 4 do: [^ self first ] ; default: ['compute value' print. aValue print] ] End echo unbundling generator.st 1>&2 cat >generator.st <<'End' Class Generator :Collection [ select: aBlock ^ AbstractGenerator new ; gen: self init: [] control: [:x | (x isNil) ifTrue: [1] ifFalse: [(aBlock value: x) ifTrue: [3] ifFalse: [2] ] ] transform: [:x | x ] | collect: aBlock ^ AbstractGenerator new ; gen: self init: [] control: [:x | (x isNil) ifTrue: [1] ifFalse: [3]] transform: aBlock | until: aBlock ^ AbstractGenerator new ; gen: self init: [] control: [:x | ((x isNil) or: [ aBlock value: x ]) ifTrue: [1] ifFalse: [3] ] transform: [:x | x ] | while: aBlock ^ AbstractGenerator new ; gen: self init: [] control: [:x | ((x notNil) and: [ aBlock value: x]) ifTrue: [3] ifFalse: [1] ] transform: [:x | x ] | first: limit | counter | ^ AbstractGenerator new ; gen: self init: [counter <- 0] control: [:x | ((x notNil) and: [(counter <- counter + 1) <= limit]) ifTrue: [3] ifFalse: [1] ] transform: [:x | x] | repeated ^ AbstractGenerator new ; gen: self init: [] control: [:x | (x isNil) ifTrue: [4] ifFalse: [3] ] transform: [:x | x] ] End echo unbundling primes.st 1>&2 cat >primes.st <<'End' Class Primes :Generator | primeGenerator lastPrime | [ first primeGenerator <- 2 to: 20. ^ lastPrime <- primeGenerator first | next primeGenerator <- Factor new; gen: primeGenerator factor: lastPrime. ^ lastPrime <- primeGenerator next ] Class Factor | baseGenerator myFactor | [ gen: aGen factor: aFactor baseGenerator <- aGen. myFactor <- aFactor | next | possible | [ (possible <- baseGenerator next) notNil ] whileTrue: [ (possible \\ myFactor ~= 0) ifTrue: [ ^ possible ] ]. ^ nil ] End echo unbundling switch.st 1>&2 cat >switch.st <<'End' Class Switch | key found | [ new: aKey found <- false. key <- aKey | case: test do: aBlock (key = test) ifTrue: [found <- true. aBlock value] | default: aBlock found ifFalse: aBlock ] End SHAR_EOF if test 4089 -ne "`wc -c < 'generator.bund'`" then echo shar: error transmitting "'generator.bund'" '(should have been 4089 characters)' fi fi # end of overwriting check if test -f 'browser.st' then echo shar: will not over-write existing file "'browser.st'" else cat << \SHAR_EOF > 'browser.st' Class Browser :KeyedCollection |editor sysdir tempfile parser| [ at: aKey ^ <primitive 160 aKey> | at: aKey put: aClass <primitive 98 aKey aClass> | currentKey ^ <primitive 164> | first ^ <primitive 162> | next ^ <primitive 163> | removeKey: aKey ^ <primitive 161 aKey> | removeKey: aKey ifAbsent: errBlock ((self at: aKey) isNil) ifTrue:[^ errBlock] ifFalse:[^ <primitive 161 aKey>] | size ^ <primitive 165> | setEditor: astring (astring class == String) ifTrue:[editor <- astring] ifFalse:['editor must string' print] | getEditor ^ editor | setSysDir: astring (astring class == String) ifTrue:[sysdir <- astring] ifFalse:['system directory must be string' print] | list self do:[:x | x print] | listsys |s| self do:[:x | s <- (s <- ((x filename asString) copyFrom:1 length:(sysdir size))). (s sameAs: sysdir) ifTrue:[x print] ] | listnosys |s| self do:[:x | s <- (s <- ((x filename asString) copyFrom:1 length:(sysdir size))). (s sameAs: sysdir) ifFalse:[x print] ] | listsub: aclass self do:[:x | ((x superClass ) == aclass) ifTrue:[x print] ] | edit: aclass |x| x <- editor , ' ', ( aclass filename asString). <primitive 167 x> | include: afilename |x| x <- parser , ' ', afilename , ' >' ,tempfile. (<primitive 167 x> = 0) ifTrue:[<primitive 168 tempfile>] ifFalse:['could not include file' print] | setParser: astring parser <- astring | getParser ^ parser | setTempfile: astring tempfile <- astring | getTempfile ^ tempfile | delete: aclass self removeKey:(aclass asSymbol) ifAbsent:['no such class' print] | test 'yeaa it works 333222 ' print ] SHAR_EOF if test 2529 -ne "`wc -c < 'browser.st'`" then echo shar: error transmitting "'browser.st'" '(should have been 2529 characters)' fi fi # end of overwriting check if test -f 'class.st' then echo shar: will not over-write existing file "'class.st'" else cat << \SHAR_EOF > 'class.st' Class Class [ edit <primitive 150 self> | list <primitive 157 self> | new | superclass newinstance | superclass <- <primitive 151 self>. <primitive 3 superclass > ifTrue: [newinstance <- superclass new ]. newinstance <- <primitive 153 self newinstance >. <primitive 155 self #new > ifTrue: [newinstance <- newinstance new]. ^ newinstance | new: aValue | superclass newinstance | superclass <- <primitive 151 self>. <primitive 3 superclass > ifTrue: [newinstance <- superclass new ]. newinstance <- <primitive 153 self newinstance >. <primitive 155 self #new: > ifTrue: [newinstance <- newinstance new: aValue ]. ^ newinstance | printString ^ <primitive 152 self > | respondsTo <primitive 154 self> | respondsTo: aSymbol ^ <primitive 155 self aSymbol> | superClass ^ <primitive 151 self> | view <primitive 156 self> | filename ^ <primitive 166 self> | isSys |s| :q ] SHAR_EOF if test 1402 -ne "`wc -c < 'class.st'`" then echo shar: error transmitting "'class.st'" '(should have been 1402 characters)' fi fi # end of overwriting check if test -f 'cldict.c' then echo shar: will not over-write existing file "'cldict.c'" else cat << \SHAR_EOF > 'cldict.c' /* Little Smalltalk Internal class dictionary timothy a. budd, 10/84 */ # include <stdio.h> # include "object.h" # include "string.h" # include "primitive.h" struct class_entry { char *cl_name; object *cl_description; struct class_entry *cl_link; }; static struct class_entry *class_dictionary = 0; static struct class_entry *current = 0; static int size = 0; enter_class(name, description) char *name; object *description; { struct class_entry *p; for (p = class_dictionary; p; p = p->cl_link) if (strcmp(name, p->cl_name) == 0) { assign(p->cl_description, description); return; } /* not found, make a new entry */ size++; p = structalloc(struct class_entry); p->cl_name = name; sassign(p->cl_description, description); p->cl_link = class_dictionary; class_dictionary = p; } object *lookup_class(name) char *name; { struct class_entry *p; for (p = class_dictionary; p; p = p->cl_link) if (strcmp(name, p->cl_name) == 0) return(p->cl_description); return((object *) 0); } object *delete_class(name) char *name; { struct class_entry *p,*last; object *del_class; if (class_dictionary == 0) return((object *) 0); last = (struct class_entry *) 0; for (p = class_dictionary; p; p = p->cl_link) { if (strcmp(name,p->cl_name) == 0) { if (last) last->cl_link = p->cl_link; else class_dictionary = p->cl_link; del_class = p->cl_description; if (current == p) current = p->cl_link; free(p); size --; return(del_class); } last = p; } return((object *) 0); } free_all_classes() { struct class_entry *p; for (p = class_dictionary; p; p = p->cl_link) { obj_dec(p->cl_description); } } class_list() { struct class_entry *p; for (p = class_dictionary; p; p = p->cl_link) { primitive(SYMPRINT, 1, &(((class *) p->cl_description)->class_name)); } } object *class_first() { current = class_dictionary; return(current->cl_description); } object *class_next() { if (current) current = current->cl_link; if (current) return(current->cl_description); return((object *) 0); } char *class_current() { if (current) return(current->cl_name); return((char *) 0); } int class_size() { return(size); } SHAR_EOF if test 2805 -ne "`wc -c < 'cldict.c'`" then echo shar: error transmitting "'cldict.c'" '(should have been 2805 characters)' fi fi # end of overwriting check if test -f 'primitive.c' then echo shar: will not over-write existing file "'primitive.c'" else cat << \SHAR_EOF > 'primitive.c' /* Little Smalltalk Primitive manager timothy a. budd 10/84 hashcode code written by Robert McConeghy (who also wrote classes Dictionary, et al). */ # include <stdio.h> # include <ctype.h> # include <math.h> # include <errno.h> # include "object.h" # include "drive.h" # include "interp.h" # include "block.h" # include "string.h" # include "symbol.h" # include "number.h" # include "file.h" # include "primitive.h" # include "cldict.h" # ifdef MDWINDOWS # include <local/window.h> /* MD windows extension */ # endif extern int errno; extern object *lookup_class(); extern int responds_to(), generality(); extern class *mk_class(); extern object *o_object, *o_true, *o_false, *o_nil, *o_number, *o_magnitude; object *primitive(primnumber, numargs, args) int primnumber, numargs; object **args; { object *resultobj; object *leftarg, *rightarg, *fnd_class(), *fnd_super(); int leftint, rightint, i, j; double leftfloat, rightfloat; char *leftp, *rightp, *errp; class *aClass; struct file_struct *phil; int opnumber = primnumber % 10; char strbuffer[300]; # ifdef MDWINDOWS int win, argval, argval2, argval3; /* MD windows additions */ int argval4, argval5, argval6; /* MD windows additions */ char screenchar; /* MD windows addition */ Win *newin; /* MD windows additions */ # endif errno = 0; /* first do argument type checking */ switch(i = (primnumber / 10)) { case 0: /* misc operations */ if (opnumber <= 5 && numargs != 1) goto argcerror; leftarg = args[0]; break; case 1: /* integer operations */ case 2: if (numargs != 2) goto argcerror; rightarg = args[1]; if (! is_integer(rightarg)) goto argterror; rightint = int_value(rightarg); case 3: if (i == 3 && opnumber && numargs != 1) goto argcerror; leftarg = args[0]; if (! is_integer(leftarg)) goto argterror; leftint = int_value(leftarg); break; case 4: /* character operations */ if (numargs != 2) goto argcerror; rightarg = args[1]; if (! is_character(rightarg)) goto argterror; rightint = int_value(rightarg); case 5: if (i == 5 && numargs != 1) goto argcerror; leftarg = args[0]; if (! is_character(leftarg)) goto argterror; leftint = int_value(leftarg); break; case 6: /* floating point operations */ if (numargs != 2) goto argcerror; rightarg = args[1]; if (! is_float(rightarg)) goto argterror; rightfloat = float_value(rightarg); case 7: if (i == 7 && numargs != 1) goto argcerror; case 8: if (i == 8 && opnumber < 8 && numargs != 1) goto argcerror; leftarg = args[0]; if (! is_float(leftarg)) goto argterror; leftfloat = float_value(leftarg); break; case 9: /* symbol operations */ leftarg = args[0]; if (! is_symbol(leftarg)) goto argterror; leftp = symbol_value(leftarg); break; case 10: /* string operations */ if (numargs < 1) goto argcerror; leftarg = args[0]; if (! is_string(leftarg)) goto argterror; leftp = string_value(leftarg); if (opnumber && opnumber <= 3) { if (numargs != 2) goto argcerror; rightarg = args[1]; if (! is_string(rightarg)) goto argterror; rightp = string_value(rightarg); } break; case 12: /* string i/o operations */ if (opnumber < 6) { if (numargs < 1) goto argcerror; leftarg = args[0]; if (! is_string(leftarg)) goto argterror; leftp = string_value(leftarg); } break; case 13: /* operations on file */ if (numargs < 1) goto argcerror; if (! is_file(args[0])) goto argterror; phil = (struct file_struct *) args[0]; break; case 15: /* operations on classes */ if (opnumber < 3 && numargs != 1) goto argcerror; if (! is_class(args[0])) goto argterror; aClass = (class *) args[0]; break; case 16: /* operations on class dictionary */ if (numargs > 2) goto argcerror; break; # ifdef MDWINDOWS case 20: /* MD windows interface */ case 21: break; # endif } /* now do operation */ switch(primnumber) { case 1: /* class of object */ resultobj = fnd_class(args[0]); if (resultobj) goto return_obj; else goto return_nil; case 2: /* get super_object */ resultobj = fnd_super(args[0]); if (resultobj) goto return_obj; else goto return_nil; case 3: /* see if class responds to new */ leftint = 0; if (! is_class(args[0])) goto return_boolean; leftint = responds_to("new", (class *) args[0]); goto return_boolean; case 4: /* compute size of object */ leftint = args[0]->size; goto return_integer; case 5: /* return hashnum of object */ if (is_integer(leftarg)) leftint = int_value(leftarg); else if (is_character(leftarg)) leftint = int_value(leftarg); else if (is_symbol(leftarg)) leftint = (int)string_value(leftarg); else if (is_string(leftarg)) { leftp = string_value(leftarg); leftint = 0; for(i = 0; *leftp != 0; leftp++){ leftint += *leftp; i++; if(i > 5) break; } } else /* for all other objects return address */ leftint = (int) &leftarg; if (leftint < 0) leftint = -leftint; leftint = (leftint % 17) + 1; goto return_integer; case 6: /* built in object type testing */ if (numargs != 2) goto argcerror; leftint = (args[0]->size == args[1]->size); goto return_boolean; case 7: /* object equality testing */ if (numargs != 2) goto argcerror; leftint = (args[0] == args[1]); goto return_boolean; case 8: /* toggle debugging flag */ debug = 1 - debug; goto return_nil; case 9: /* numerical generality comparison */ if (numargs != 2) goto argcerror; leftint = (generality(args[0]) > generality(args[1])); goto return_boolean; case 10: /* integer addition */ leftint += rightint; goto return_integer; case 11: /* integer subtraction */ leftint -= rightint; goto return_integer; case 12: case 42: leftint = (leftint < rightint); goto return_boolean; case 13: case 43: leftint = (leftint > rightint); goto return_boolean; case 14: case 44: leftint = (leftint <= rightint); goto return_boolean; case 15: case 45: leftint = (leftint >= rightint); goto return_boolean; case 16: case 46: leftint = (leftint == rightint); goto return_boolean; case 17: case 47: leftint = (leftint != rightint); goto return_boolean; case 18: leftint *= rightint; goto return_integer; case 19: /* // integer */ if (rightint == 0) goto numerror; i = leftint / rightint; if ((leftint < 0) && (leftint % rightint)) i -= 1; leftint = i; goto return_integer; case 20: /* gcd of two integers */ if (leftint == 0 || rightint == 0) goto numerror; if (leftint < 0) leftint = -leftint; if (rightint < 0) rightint = -rightint; if (leftint > rightint) {i = leftint; leftint = rightint; rightint = i;} while (i = rightint % leftint) {rightint = leftint; leftint = i;} goto return_integer; case 21: errp = "primitive bitAt:"; goto not_implemented; case 22: /* logical bit-or */ leftint |= rightint; goto return_integer; case 23: /* logical bit-and */ leftint &= rightint; goto return_integer; case 24: /* logical bit-exclusive or */ leftint ^= rightint; goto return_integer; case 25: /* bit shift */ if (rightint < 0) leftint >>= - rightint; else leftint <<= rightint; goto return_integer; case 26: /* integer radix */ prnt_radix(leftint, rightint, strbuffer); goto return_string; case 27: errp = "primitive raisedToInteger:"; goto not_implemented; case 28: if (rightint == 0) goto numerror; leftint /= rightint; goto return_integer; case 29: if (rightint == 0) goto numerror; leftint %= rightint; goto return_integer; case 30: /* doPrimitive:withArguments: */ if (numargs != 2) goto argcerror; resultobj = primitive(leftint, args[1]->size, &args[1]->inst_var[0]); goto return_obj; case 32: /* convert random int into random float */ leftfloat = ((double) ((leftint/10) % 1000)) / 1000.0; goto return_float; case 33: /* bit inverse */ leftint ^= -1; goto return_integer; case 34: errp = "primitive highBit:"; goto not_implemented; case 35: /* random number */ srand(leftint); leftint = rand(); goto return_integer; case 36: /* convert integer to character */ goto return_character; case 37: /* convert integer to string */ sprintf(strbuffer,"%d", leftint); goto return_string; case 38: /* factorial */ if (leftint < 0) goto numerror; if (leftint < 12) { for (i = 1; leftint; leftint--) i *= leftint; leftint = i; goto return_integer; } /* compute gamma */ leftfloat = (double) (leftint + 1); sassign(leftarg, new_float(leftfloat)); resultobj = primitive(GAMMAFUN, 1, &leftarg); obj_dec(leftarg); goto return_obj; case 39: /* convert integer to float */ leftfloat = (double) leftint; goto return_float; case 50: leftint = isdigit(leftint); goto return_boolean; case 51: if (isupper(leftint)) leftint += 'a' - 'A'; leftint = (leftint == 'a') || (leftint == 'e') || (leftint == 'i') || (leftint == 'o') || (leftint == 'u'); goto return_boolean; case 52: leftint = isalpha(leftint); goto return_boolean; case 53: leftint = islower(leftint); goto return_boolean; case 54: leftint = isupper(leftint); goto return_boolean; case 55: leftint = isspace(leftint); goto return_boolean; case 56: leftint = isalnum(leftint); goto return_boolean; case 57: if (isupper(leftint)) leftint += 'a' - 'A'; else if (islower(leftint)) leftint += 'A' - 'a'; goto return_character; case 58: /* convert character to string */ sprintf(strbuffer,"%c", leftint); goto return_string; case 59: /* convert character to integer */ goto return_integer; case 60: /* floating point addition */ leftfloat += rightfloat; goto return_float; case 61: /* floating point subtraction */ leftfloat -= rightfloat; goto return_float; case 62: leftint = (leftfloat < rightfloat); goto return_boolean; case 63: leftint = (leftfloat > rightfloat); goto return_boolean; case 64: leftint = (leftfloat <= rightfloat); goto return_boolean; case 65: leftint = (leftfloat >= rightfloat); goto return_boolean; case 66: leftint = (leftfloat == rightfloat); goto return_boolean; case 67: leftint = (leftfloat != rightfloat); goto return_boolean; case 68: leftfloat *= rightfloat; goto return_float; case 69: if (rightfloat == 0) goto numerror; leftfloat /= rightfloat; goto return_float; case 70: leftfloat = log(leftfloat); goto float_check; case 71: if (leftfloat < 0) goto numerror; leftfloat = sqrt(leftfloat); goto float_check; case 72: leftint = (int) floor(leftfloat); goto return_integer; case 73: leftint = (int) ceil(leftfloat); goto return_integer; case 74: errp = "primitive asFraction"; goto not_implemented; case 75: leftfloat = modf(leftfloat, &leftint); goto return_integer; case 76: leftfloat = modf(leftfloat, &leftint); goto return_float; case 77: /* gamma function */ # ifdef GAMMA leftfloat = gamma(leftfloat); if (leftfloat > 88.0) goto numerror; leftfloat = exp(leftfloat); goto float_check; # endif # ifndef GAMMA errp = "gamma function not implemented"; goto return_error; # endif case 78: sprintf(strbuffer,"%g", leftfloat); goto return_string; case 79: leftfloat = exp(leftfloat); goto return_float; case 81: leftfloat = sin(leftfloat); goto float_check; case 82: leftfloat = cos(leftfloat); goto float_check; case 84: leftfloat = asin(leftfloat); goto float_check; case 85: leftfloat = acos(leftfloat); goto float_check; case 86: leftfloat = atan(leftfloat); goto float_check; case 88: if (numargs != 2) goto argcerror; if (! is_float(args[1])) goto argterror; leftfloat = pow(leftfloat, float_value(args[1])); goto float_check; case 89: errp = "primitive floating point radix"; goto not_implemented; case 91: /* symbol comparison */ if (numargs != 2) goto argcerror; if (! is_symbol(args[1])) goto argterror; leftint = (leftp == symbol_value(args[1])); goto return_boolean; case 92: /* symbol printString */ sprintf(strbuffer, "#%s", leftp); goto return_string; case 93: /* symbol asString */ sprintf(strbuffer, "%s", leftp); goto return_string; case 94: /* symbol print */ printf("%s\n", leftp); goto return_nil; case 95: /* perform: withArguments: */ if (numargs != 3) goto argcerror; if (! is_interpreter(args[1])) goto argterror; send_mess(args[1], args[2]->inst_var[0], leftp, &(args[2]->inst_var[0]), args[2]->size - 1); goto return_nil; case 96: goto return_nil; case 97: /* make a new class (generated by parser)*/ if (numargs != 7) goto argcerror; if (! is_symbol(args[1])) goto argterror; if (! is_symbol(args[2])) goto argterror; if (! is_integer(args[6])) goto argterror; resultobj = (object *) mk_class(leftp, args); goto return_obj; case 98: /* install class in dictionary */ if (numargs != 2) goto argcerror; if (! is_class(args[1])) goto argterror; enter_class(leftp, args[1]); goto return_nil; case 99: /* find a class in class dictionary */ if (numargs != 1) goto argcerror; resultobj = lookup_class(leftp); if (resultobj == (object *) 0) { sprintf(strbuffer,"cannot find class %s", leftp); sassign(resultobj, new_str(strbuffer)); primitive(ERRPRINT, 1, &resultobj); obj_dec(resultobj); resultobj = lookup_class("Object"); if (! resultobj) cant_happen(7); } goto return_obj; case 100: /* string length */ leftint = strlen(leftp); goto return_integer; case 101: /* string compare, case dependent */ leftint = strcmp(leftp, rightp); goto return_integer; case 102: /* string compare, case independent */ leftint = 1; while (*leftp || *rightp) { i = *leftp++; j = *rightp++; if (i >= 'A' && i <= 'Z') i = i - 'A' + 'a'; if (j >= 'A' && j <= 'Z') j = j - 'A' + 'a'; if (i != j) {leftint = 0; break;} } goto return_boolean; case 103: /* string catenation */ for (i = leftint = 0; i < numargs; i++) { if (! is_string(args[i])) goto argterror; leftint += strlen(string_value(args[i])); } errp = (char *) o_alloc((unsigned) (1 + leftint)); *errp = '\0'; for (i = 0; i < numargs; i++) strcat(errp, string_value(args[i])); resultobj = (object *) new_istr(errp); goto return_obj; case 104: /* string at: */ if (numargs != 2) goto argcerror; if (! is_integer(args[1])) goto argterror; rightint = int_value(args[1]) - 1; if (rightint < 0 || rightint >= strlen(leftp)) goto indexerror; leftint = leftp[rightint]; goto return_character; case 105: /* string at: put: */ if (numargs != 3) goto argcerror; if (! is_integer(args[1])) goto argterror; if (! is_character(args[2])) goto argterror; leftint = int_value(args[1]) - 1; rightint = int_value(args[2]); if (leftint < 0 || leftint >= strlen(leftp)) goto indexerror; leftp[leftint] = rightint; goto return_nil; case 106: /* copyFrom: length: */ if (numargs != 3) goto argcerror; if (! is_integer(args[1])) goto argterror; if (! is_integer(args[2])) goto argterror; i = int_value(args[1]) - 1; if (i < 0) goto indexerror; j = int_value(args[2]); if (j < 0) goto indexerror; for (rightp = strbuffer; j; j--, i++) *rightp++ = leftp[i]; *rightp = '\0'; goto return_string; case 107: /* string copy */ if (numargs != 1) goto argcerror; resultobj = new_str(leftp); goto return_obj; case 108: /* string asSymbol */ if (numargs != 1) goto argcerror; resultobj = new_sym(leftp); goto return_obj; case 109: /* string printString */ if (numargs != 1) goto argcerror; sprintf(strbuffer,"\'%s\'", leftp); goto return_string; case 110: /* new untyped object */ if (numargs != 1) goto argcerror; if (! is_integer(args[0])) goto argterror; leftint = int_value(args[0]); if (leftint < 0) goto numerror; resultobj = new_obj((class *) 0, leftint, 1); goto return_obj; case 111: /* object index */ if (numargs != 2) goto argcerror; if (! is_integer(args[1])) goto argterror; rightint = int_value(args[1]); if (rightint < 1 || rightint > args[0]->size) goto indexerror; resultobj = args[0]->inst_var[ rightint - 1 ]; goto return_obj; case 112: /* object atindex put */ if (numargs != 3) goto argcerror; if (! is_integer(args[1])) goto argterror; rightint = int_value(args[1]); if (rightint < 1 || rightint > args[0]->size) goto indexerror; assign(args[0]->inst_var[rightint - 1], args[2]); goto return_nil; case 113: /* object grow */ leftarg = args[0]; rightarg = args[1]; if (is_bltin(leftarg)) goto argterror; resultobj = new_obj(leftarg->class, leftarg->size+1, 0); if (leftarg->super_obj) sassign(resultobj->super_obj, leftarg->super_obj); for (i = 0; i < leftarg->size; i++) sassign(resultobj->inst_var[i], leftarg->inst_var[i]); sassign(resultobj->inst_var[i], rightarg); goto return_obj; case 114: /* new array */ if (numargs != 1) goto argcerror; if (! is_integer(args[0])) goto argterror; leftint = int_value(args[0]); if (leftint < 0) goto numerror; resultobj = new_array(leftint, 1); goto return_obj; case 120: /* print, no return */ printf("%s", leftp); goto return_nil; case 121: /* print, with return */ printf("%s\n", leftp); goto return_nil; case 122: /* format for error printing */ aClass = (class *) fnd_class(args[1]); sprintf(strbuffer,"%s: %s", aClass->class_name, leftp); leftp = strbuffer; case 123: fprintf(stderr,"%s\n", leftp); goto return_nil; case 125: /* unix system call */ leftint = system(leftp); goto return_integer; case 127: /* block return */ errp = "block return without surrounding context"; goto return_error; case 128: /* reference count error */ if (numargs != 1) goto argcerror; sprintf(strbuffer,"object %d reference count %d", args[0], args[0]->ref_count); errp = strbuffer; goto return_error; case 129: /* does not respond error */ if (numargs != 2) goto argcerror; if (! is_symbol(args[1])) goto argterror; fprintf(stderr,"129 error %s\n", symbol_value(args[1])); aClass = (class *) fnd_class(args[0]); if (! is_class(aClass)) goto argterror; sprintf(strbuffer,"%s: does not respond to %s", symbol_value(aClass->class_name), symbol_value(args[1])); errp = strbuffer; goto return_error; case 130: /* file open */ if (numargs != 3) goto argcerror; if (! is_string(args[1])) goto argterror; if (! is_string(args[2])) goto argterror; file_open(phil, string_value(args[1]), string_value(args[2])); goto return_nil; case 131: /* file read */ if (numargs != 1) goto argcerror; resultobj = file_read(phil); goto return_obj; case 132: /* file write */ if (numargs != 2) goto argcerror; file_write(phil, args[1]); goto return_nil; case 133: if (numargs != 2) goto argcerror; if (! is_integer(args[1])) goto argterror; phil->file_mode = int_value(args[1]); goto return_nil; case 134: errp = "file size"; goto not_implemented; case 135: errp = "file at:"; goto not_implemented; case 140: errp = "die violently should be trapped by interp"; goto return_error; case 142: errp = "block execute should be trapped by interp"; goto return_error; case 143: /* newProcess (withArguments:) */ if (numargs < 1) goto argcerror; if (! is_block(args[0])) goto argterror; if (numargs == 1) resultobj = (object *) block_execute( (interpreter *) 0, (block *) args[0], 0, args); else if (numargs == 2) resultobj = (object *) block_execute( (interpreter *) 0, (block *) args[0], args[1]->size, &(args[1]->inst_var[0])); else goto argcerror; goto return_obj; case 145: errp = "sender interp should be trapped by interp"; goto return_error; case 148: /* enqueue interpreter */ if (numargs != 1) goto argcerror; if (! is_interpreter(args[0])) goto argterror; enqueue_process((interpreter *) args[0]); goto return_nil; case 149: /* dequeue interpreter */ if (numargs != 1) goto argcerror; if (! is_interpreter(args[0])) goto argterror; dequeue_process((interpreter *) args[0]); goto return_nil; case 150: /* class edit */ leftp = symbol_value(aClass->file_name); if (! lexedit(leftp)) lexinclude(leftp); goto return_nil; case 151: /* superclass of a class */ if (! aClass->super_class) goto return_nil; resultobj = (object *) aClass->super_class; if (! is_symbol(resultobj)) goto return_nil; resultobj = lookup_class(symbol_value(resultobj)); if (! resultobj) goto return_nil; goto return_obj; case 152: /* class name */ resultobj = aClass->class_name; leftp = symbol_value(resultobj); resultobj = new_str(leftp); goto return_obj; case 153: /* new */ if (numargs != 2) goto argcerror; if (args[1] == o_nil) resultobj = new_inst(aClass); else resultobj = new_sinst(aClass, args[1]); goto return_obj; case 154: /* respondsTo */ prnt_messages(aClass); goto return_nil; case 155: /* respondsTo: aMessage */ if (numargs != 2) goto argcerror; if (! is_symbol(args[1])) goto argterror; leftint = responds_to(symbol_value(args[1]), aClass); goto return_boolean; case 156: /* class view */ leftp = symbol_value(aClass->file_name); lexedit(leftp); goto return_nil; case 157: /* class list */ class_list(aClass); goto return_nil; case 160: /* get class without histronics */ if (numargs != 1) goto argcerror; leftarg = args[0]; if (! is_symbol(leftarg)) goto argterror; leftp = symbol_value(leftarg); resultobj = lookup_class(leftp); if (resultobj == (object *) 0) { sprintf(strbuffer,"cannot find class %s", leftp); sassign(resultobj,new_str(strbuffer)); primitive(ERRPRINT,1,&resultobj); obj_dec(resultobj); goto return_nil; } goto return_obj; break; case 161: /* remove key */ if (numargs != 1) goto argcerror; leftarg = args[0]; if (! is_symbol(leftarg)) goto argterror; leftp = symbol_value(leftarg); resultobj = delete_class(leftp); if (resultobj == (object *) 0) { sprintf(strbuffer,"cannot delete class %s", leftp); sassign(resultobj,new_str(strbuffer)); primitive(ERRPRINT,1,&resultobj); obj_dec(resultobj); goto return_nil; } obj_dec(resultobj); goto return_nil; break; case 162: /* first */ if (numargs != 0) goto argcerror; resultobj = class_first(); if (resultobj == (object *) 0) goto return_nil; goto return_obj; break; case 163: /* next */ if (numargs != 0) goto argcerror; resultobj = class_next(); if (resultobj == (object *) 0) goto return_nil; goto return_obj; break; case 164: /* current */ if (numargs != 0) goto argcerror; leftp = class_current(); if (leftp == (char *) 0) goto return_nil; resultobj = new_sym(leftp); goto return_obj; break; case 165: /* size */ if (numargs != 0) goto argcerror; leftint = class_size(); goto return_integer; break; case 166: /* return file name of class */ if (numargs != 1) goto argcerror; if (! is_class(args[0])) goto argterror; aClass = (class *) args[0]; resultobj = aClass->file_name; goto return_obj; break; case 167: /* do a string as a unix command */ if (numargs != 1 ) goto argcerror; leftarg = args[0]; if (! is_string(leftarg)) goto argterror; leftp = string_value(leftarg); strcpy(strbuffer,leftp); leftint = system(strbuffer); goto return_integer; break; case 168: /* include a file */ if (numargs != 1 ) goto argcerror; leftarg = args[0]; if (! is_string(leftarg)) goto argterror; leftp = string_value(leftarg); lexread(leftp); goto return_nil; break; # ifdef MDWINDOWS /* MD windows interface; cases 200-219 */ case 200: /* housekeeping */ argval = int_value(args[0]); switch(argval) { case 0: Winit(0,0); break; case 1: Wcleanup(); break; case 2: Wcloseall(); break; case 7: Ding(); break; case 99: Wexit(0); break; default: goto argverror; } goto return_nil; case 201: /* mode toggles */ win = int_value(args[0]); argval = int_value(args[1]); argval2 = int_value(args[2]); switch(argval) { case 0: Woncursor(win,argval2); break; case 1: Wnewline(win,argval2); break; case 2: Wwrap(win,argval2); break; case 3: VisibleBell = argval2; break; default: goto argverror; } goto return_nil; case 202: /* window control */ win = int_value(args[0]); argval = int_value(args[1]); switch(argval) { case 0: Wclose(win); break; case 1: Wframe(win); break; case 2: Wfront(win); break; case 3: Wback(win); break; case 4: Whide(win); break; case 5: Wunhide(win); break; default: goto argverror; } goto return_nil; case 203: /* clears */ win = int_value(args[0]); argval = int_value(args[1]); argval2 = int_value(args[2]); argval3 = int_value(args[3]); if (argval == 0) { if (argval2 == 0) Wclear(win,argval3); else Wclearline(win,argval3); } else { if (argval2 == 0) WBclear(win,argval3); else WBclearline(win,argval3); } goto return_nil; case 204: /* cursor movement */ win = int_value(args[0]); argval = int_value(args[1]); argval2 = int_value(args[2]); argval3 = int_value(args[3]); switch(argval) { case 0: WAcursor(win,argval2,argval3); break; case 1: WBcursor(win,argval2,argval3); break; case 2: Wauxcursor(win,argval2,argval3); break; case 3: WWcursor(win,argval2,argval3); break; default: goto argverror; } goto return_nil; case 205: /* deletes */ win = int_value(args[0]); argval = int_value(args[1]); argval2 = int_value(args[2]); argval3 = int_value(args[3]); if (argval == 0) { if (argval2 == 0) Wdelchars(win,argval3); else if (argval2 == 1) Wdelcols(win,argval3); else Wdellines(win,argval3); } else { if (argval2 == 0) WBdelchars(win,argval3); else if (argval2 == 1) WBdelcols(win,argval3); else WBdellines(win,argval3); } goto return_nil; case 206: /* insert */ win = int_value(args[0]); argval = int_value(args[1]); argval2 = int_value(args[2]); argval3 = int_value(args[3]); if (argval == 0) { if (argval2 == 0) Winschars(win,argval3); else if (argval2 == 1) Winscols(win,argval3); else Winslines(win,argval3); } else { if (argval2 == 0) WBinschars(win,argval3); else if (argval2 == 1) WBinscols(win,argval3); else WBinslines(win,argval3); } goto return_nil; case 207: /* label window */ win = int_value(args[0]); leftp = string_value(args[1]); argval2 = int_value(args[2]); argval3 = int_value(args[3]); Wlabel(win,leftp,argval2,argval3); goto return_nil; case 208: /* move window */ win = int_value(args[0]); argval = int_value(args[1]); argval2 = int_value(args[2]); Wmove(win,argval,argval2); goto return_nil; case 209: /* open or link */ if (numargs == 4) { argval = int_value(args[0]); /* xorg */ argval2 = int_value(args[1]); /* yorg */ argval3 = int_value(args[2]); /* rows */ argval4 = int_value(args[3]); /* cols */ newin = Wopen(1,argval,argval2,argval4,argval3,0,0); } else if (numargs == 5) { win = int_value(args[0]); /* linkwin */ argval = int_value(args[1]); /* xorg */ argval2 = int_value(args[2]); /* yorg */ argval3 = int_value(args[3]); /* rows */ argval4 = int_value(args[4]); /* cols */ newin = Wlink(win,1,argval,argval2,argval4,argval3,0,0); } else goto argcerror; leftint = (int *) newin; goto return_integer; case 210: /* refresh/redraw */ argval = int_value(args[0]); argval2 = int_value(args[1]); if (argval2) ScreenGarbaged = 1; Wrefresh(argval); goto return_nil; case 211: /* set mode of line */ win = int_value(args[0]); argval2 = int_value(args[2]); if (int_value(args[1]) == 0) /* invert argument */ Wretroline(win,argval2,1); else Wretroline(win,argval2,0); goto return_nil; case 212: /* scroll amount */ win = int_value(args[0]); argval = int_value(args[1]); Wsetpopup(win,argval); goto return_nil; case 213: /* read character */ win = int_value(args[0]); argval = int_value(args[1]); argval2 = int_value(args[2]); switch(argval) { /* We ignore Wread's winonly argument */ case 0: leftint = Wread(win,argval2,0); break; case 1: leftint = WBread(win,argval2); break; case 2: leftint = WAread(win,argval2); break; default: break; } goto return_character; case 214: /* write character into window */ win = int_value(args[0]); screenchar = char_value(args[1]); /* note inverted arguments */ Wputc(screenchar,win); goto return_nil; case 215: /* write string into window */ win = int_value(args[0]); leftp = string_value(args[1]); /* note inverted arguments */ Wputs(leftp,win); goto return_nil; case 216: /* write character onto glass */ win = int_value(args[0]); screenchar = char_value(args[1]); argval2 = int_value(args[2]); /* note inverted arguments */ Waputc(screenchar,argval2,win); goto return_nil; case 217: /* write string onto glass */ win = int_value(args[0]); leftp = string_value(args[1]); argval2 = int_value(args[2]); /* note inverted arguments */ Waputs(leftp,argval2,win); goto return_nil; case 218: /* sleep for specified time */ argval = int_value(args[0]); sleep(argval); goto return_nil; case 219: /* reserved for future expansion */ case 220: /* reserved for future expansion */ case 221: /* reserved for future expansion */ case 222: /* reserved for future expansion */ case 223: /* reserved for future expansion */ case 224: /* reserved for future expansion */ # endif default: fprintf(stderr,"Primitive number %d not implemented", primnumber); goto return_nil; } /* return different types of objects */ return_obj: return(resultobj); return_nil: return(o_nil); return_integer: return(new_int(leftint)); return_character: return(new_char(leftint)); return_boolean: return(leftint ? o_true : o_false); float_check: if (errno == ERANGE || errno == EDOM) goto numerror; return_float: return(new_float(leftfloat)); return_string: return(new_str(strbuffer)); /* error conditions */ not_implemented: sprintf(strbuffer,"%s not implemented yet", errp); errp = strbuffer; goto return_error; argcerror: sprintf(strbuffer,"%d is wrong number of arguments for primitive %d", numargs, primnumber); errp = strbuffer; goto return_error; argterror: sprintf(strbuffer,"argument type not correct for primitive %d", primnumber); errp = strbuffer; goto return_error; # ifdef MDWINDOWS argverror: sprintf(strbuffer,"argument value of %d not legal for primitive %d", argval,primnumber); errp = strbuffer; goto return_error; # endif numerror: errp = "numerical error in primitive"; goto return_error; indexerror: errp = "primitive index error"; goto return_error; return_error: sassign(resultobj, new_str(errp)); primitive(ERRPRINT, 1, &resultobj); obj_dec(resultobj); goto return_nil; } static prnt_radix(n, r, buffer) int n, r; char buffer[]; { char *p, *q, buffer2[10]; int i, s; if (n < 0) {n = - n; s = 1;} else s = 0; p = buffer2; *p++ = '\0'; while (n) { i = n % r; *p++ = i + ((i < 10) ? '0' : ('A' - 10)); n = n / r; } sprintf(buffer,"%d%sr", r, s); for (q = buffer; *q; q++); if (s) *q++ = '-'; for (*p = '0' ; *p ; ) *q++ = *--p; *q = '\0'; } /* generalit - numerical generality */ static int generality(aNumber) object *aNumber; { int i; if (is_integer(aNumber)) i = 1; else if (is_float(aNumber)) i = 2; else i = 3; return(i); } /* cant_happen - report that an impossible condition has occured */ cant_happen(n) int n; { char *s; switch(n) { case 1: s = "out of memory allocation space"; break; case 2: s = "array size less than zero"; break; case 3: s = "block return from call should not occur"; break; case 4: s = "attempt to make instance of non class"; break; case 5: s = "case error in new integer or string"; break; case 6: s = "decrement on unknown built in object"; break; case 7: s = "cannot find class Object"; break; case 8: s = "primitive free of object of wrong type"; break; case 9: s = "internal interpreter error"; break; case 11: s = "block execute on non-block"; break; case 12: s = "out of symbol space"; break; case 14: s = "out of standard bytecode space"; break; case 15: s = "process queue error"; break; case 16: s = "attempt to free symbol"; break; default: s = "unknown, but impossible nonetheless, condition"; break; } fprintf(stderr,"Can't happen number %d: %s\n", n, s); n = n / 0; /* on vax, this will force a core dump */ exit(1); } SHAR_EOF if test 55496 -ne "`wc -c < 'primitive.c'`" then echo shar: error transmitting "'primitive.c'" '(should have been 55496 characters)' fi fi # end of overwriting check if test -f '8queen.st' then echo shar: will not over-write existing file "'8queen.st'" else cat << \SHAR_EOF > '8queen.st' Class Main [ main | lq | lq <- nil. (1 to: 8) do: [:i | lq <- Queen new ; setColumn: i neighbor: lq]. lq first. lq printBoard. lq next. lq printBoard. ] Class Queen | row column neighbor | [ setColumn: aNumber neighbor: aQueen column <- aNumber. neighbor <- aQueen | first (neighbor notNil) ifTrue: [neighbor first]. row <- 1. ^ self testPosition | next (row = 8) ifTrue: [((neighbor isNil) or: [neighbor next isNil]) ifTrue: [ ^ nil ]. row <- 0 ]. row <- row + 1. ^ self testPosition | testPosition (neighbor isNil) ifTrue: [ ^ row ]. (neighbor checkRow: row column: column) ifTrue: [ ^ self next ] ifFalse: [ ^ row ] | checkRow: testRow column: testColumn | columnDifference | columnDifference <- testColumn - column. (((row = testRow) or: [row + columnDifference = testRow]) or: [row - columnDifference = testRow]) ifTrue: [^ true]. (neighbor notNil) ifTrue: [^ neighbor checkRow: testRow column: testColumn] ifFalse: [ ^ false ] | printBoard (neighbor notNil) ifTrue: [ neighbor printBoard ]. ('column ', column printString, ' row ', row printString) print ] SHAR_EOF if test 1161 -ne "`wc -c < '8queen.st'`" then echo shar: error transmitting "'8queen.st'" '(should have been 1161 characters)' fi fi # end of overwriting check if test -f 'abgen.st' then echo shar: will not over-write existing file "'abgen.st'" else cat << \SHAR_EOF > 'abgen.st' Class AbstractGenerator :Generator | baseGenerator initBlock control transform | [ gen: aGenerator init: aBlock control: controlBlock transform: transformBlock baseGenerator <- aGenerator. initBlock <- aBlock. control <- controlBlock. transform <- transformBlock | first | item | initBlock value. item <- baseGenerator first. (item isNil) ifTrue: [^nil] ifFalse: [^ self computeValue: item ] | next ^ self computeValue: (baseGenerator next) | computeValue: aValue ^ Switch new: (control value: aValue) ; case: 1 do: [^ nil] ; case: 2 do: [^ self next] ; case: 3 do: [^ transform value: aValue ] ; case: 4 do: [^ self first ] ; default: ['compute value' print. aValue print] ] SHAR_EOF if test 727 -ne "`wc -c < 'abgen.st'`" then echo shar: error transmitting "'abgen.st'" '(should have been 727 characters)' fi fi # end of overwriting check if test -f 'generator.st' then echo shar: will not over-write existing file "'generator.st'" else cat << \SHAR_EOF > 'generator.st' Class Generator :Collection [ select: aBlock ^ AbstractGenerator new ; gen: self init: [] control: [:x | (x isNil) ifTrue: [1] ifFalse: [(aBlock value: x) ifTrue: [3] ifFalse: [2] ] ] transform: [:x | x ] | collect: aBlock ^ AbstractGenerator new ; gen: self init: [] control: [:x | (x isNil) ifTrue: [1] ifFalse: [3]] transform: aBlock | until: aBlock ^ AbstractGenerator new ; gen: self init: [] control: [:x | ((x isNil) or: [ aBlock value: x ]) ifTrue: [1] ifFalse: [3] ] transform: [:x | x ] | while: aBlock ^ AbstractGenerator new ; gen: self init: [] control: [:x | ((x notNil) and: [ aBlock value: x]) ifTrue: [3] ifFalse: [1] ] transform: [:x | x ] | first: limit | counter | ^ AbstractGenerator new ; gen: self init: [counter <- 0] control: [:x | ((x notNil) and: [(counter <- counter + 1) <= limit]) ifTrue: [3] ifFalse: [1] ] transform: [:x | x] | repeated ^ AbstractGenerator new ; gen: self init: [] control: [:x | (x isNil) ifTrue: [4] ifFalse: [3] ] transform: [:x | x] ] SHAR_EOF if test 1152 -ne "`wc -c < 'generator.st'`" then echo shar: error transmitting "'generator.st'" '(should have been 1152 characters)' fi fi # end of overwriting check if test -f 'primes.st' then echo shar: will not over-write existing file "'primes.st'" else cat << \SHAR_EOF > 'primes.st' Class Primes :Generator | primeGenerator lastPrime | [ first primeGenerator <- 2 to: 20. ^ lastPrime <- primeGenerator first | next primeGenerator <- Factor new; gen: primeGenerator factor: lastPrime. ^ lastPrime <- primeGenerator next ] Class Factor | baseGenerator myFactor | [ gen: aGen factor: aFactor baseGenerator <- aGen. myFactor <- aFactor | next | possible | [ (possible <- baseGenerator next) notNil ] whileTrue: [ (possible \\ myFactor ~= 0) ifTrue: [ ^ possible ] ]. ^ nil ] SHAR_EOF if test 531 -ne "`wc -c < 'primes.st'`" then echo shar: error transmitting "'primes.st'" '(should have been 531 characters)' fi fi # end of overwriting check if test -f 'switch.st' then echo shar: will not over-write existing file "'switch.st'" else cat << \SHAR_EOF > 'switch.st' Class Switch | key found | [ new: aKey found <- false. key <- aKey | case: test do: aBlock (key = test) ifTrue: [found <- true. aBlock value] | default: aBlock found ifFalse: aBlock ] SHAR_EOF if test 196 -ne "`wc -c < 'switch.st'`" then echo shar: error transmitting "'switch.st'" '(should have been 196 characters)' fi fi # end of overwriting check if test -f 'cursin.c' then echo shar: will not over-write existing file "'cursin.c'" else cat << \SHAR_EOF > 'cursin.c' #include <stdio.h> #include <curses.h> #include <setjmp.h> #include <sgtty.h> #include <fcntl.h> #include <errno.h> # include "cursin.h" # define fnull ((forest)0) # define cnull ((char)0) /* written by Gary Levin, minor modifications by Kelvin Nilsen */ /* forest is the binary representation of a labeled tree in_label is the label of the incoming branch (null for root) translation is the translation of the string formed by the labels from the root to the leaf (null for non-leaves) */ typedef struct Fnode * forest; struct Fnode { forest first_child, sibling; char in_label; enum log_symbol translation; }; forest str_to_forest(); forest makeFnode(); bool not_init = TRUE; bool cursin_error = FALSE; bool use_defaults = FALSE; forest translate_tree; log_char back_char; /* cursinit() initialize the cursor input processor */ cursinit(){ char buffer[20]; char *p; forest f; int cnt; not_init = FALSE; f = fnull; p=buffer; printf("%s",tgetstr("ks", &p)); f = str_to_forest("\04",f,Leof); /* ^D */ p = buffer; if (tgetstr("ku", &p) && !use_defaults) f = str_to_forest(buffer,f,Lu); else f = str_to_forest("\5",f,Lu); /* ^E */ p = buffer; if (tgetstr("kd", &p) && !use_defaults) f = str_to_forest(buffer,f,Ld); else f = str_to_forest("\30",f,Ld); /* ^X */ p = buffer; if (tgetstr("kl", &p) && !use_defaults) f = str_to_forest(buffer,f,Ll); else f = str_to_forest("\32",f,Ll); /* ^Z */ p = buffer; if (tgetstr("kb", &p) && !use_defaults) f = str_to_forest(buffer,f,Lb); else f = str_to_forest("\10",f,Lb); /* ^H */ p = buffer; if (tgetstr("kr", &p) && !use_defaults) f = str_to_forest(buffer,f,Lr); else f = str_to_forest("\03",f,Lr); /* ^C */ p = buffer; if (tgetstr("kh", &p) && !use_defaults) f = str_to_forest(buffer,f,Lh); else f = str_to_forest("\07",f,Lh); /* ^G */ cnt = tgetnum("kn"); if (cnt > 0 && !use_defaults) { p=buffer; f = str_to_forest(tgetstr("k0",&p),f,Lfr); } else f = str_to_forest("\06",f,Lfr); /* ^F */ if (cnt > 1 && !use_defaults) { p=buffer; f = str_to_forest(tgetstr("k1",&p),f,Lfl); } else f = str_to_forest("\01",f,Lfl); /* ^A */ if (cnt > 2 && !use_defaults) { p=buffer; f = str_to_forest(tgetstr("k2",&p),f,Leol); } else f = str_to_forest("\24",f,Leol); /* ^T */ if (cnt > 3 && !use_defaults) { p=buffer; f = str_to_forest(tgetstr("k3",&p),f,Ldc); } else f = str_to_forest("\177",f,Ldc); /* rubout */ if (cnt > 4 && !use_defaults) { p=buffer; f = str_to_forest(tgetstr("k4",&p),f,Ldw); } else f = str_to_forest("\27",f,Ldw); /* ^W */ if (cnt > 5 && !use_defaults) { p=buffer; f = str_to_forest(tgetstr("k5",&p),f,Ldl); } else f = str_to_forest("\14",f,Ldl); /* ^L */ if (cnt > 6 && !use_defaults) { p=buffer; f = str_to_forest(tgetstr("k6",&p),f,Ldeol); } else f = str_to_forest("\31",f,Ldeol); /* ^Y */ translate_tree = f; if( cursin_error && !use_defaults ) { cursin_error = FALSE; use_defaults = TRUE; cleanup(); cursinit(); } else if (cursin_error) cant_happen(30); } /* str_to_forest(s,f,c) returns the forest that results from adding a path for S to F with translation C. prints error message and calls die if S is contained in any path already in F or if S extends a previous leaf (this would indicate that some paths are prefixes) */ forest str_to_forest(s,f,c) char * s; forest f; enum log_symbol c; { forest root; if( *s == cnull ) return(f); root = f; /* f:= &Fnode (among sibs of root) with in_label = *s, fnull o.w. */ while( f != fnull && f->in_label != *s ) { f = f->sibling; } if( *(s+1) != cnull ){ if( f != fnull ) { if( f->first_child == fnull ) cursin_error = TRUE; else f->first_child = str_to_forest(s+1, f->first_child, c); return( root ); } else return( makeFnode( str_to_forest(s+1,fnull,c), root, *s, lnull)); } else{ if( f == fnull ) return makeFnode( fnull, root, *s, c); if(f->translation == c) return root; cursin_error = TRUE; return root; } } /* makeFnode allocates a Fnode and initializes the fields */ forest makeFnode(first,sib,in_c,trans) forest first,sib; char in_c; enum log_symbol trans; { forest temp; temp = (forest) malloc( sizeof * temp ); if( temp==0 ) cursin_error = TRUE; temp-> first_child = first; temp-> sibling = sib; temp-> in_label = in_c; temp-> translation = trans; return( temp ); } static char workc = 0; static forest workt; /* cursin() read the next logical character using getch (see curses) */ log_char cursin() { char c; log_char retv; if (workt) /* then we previously jumped away from input */ { workc = input(); /* finish the input */ retv = look_up(); workt = 0; return retv; } else { c = input(); workc = c; workt = translate_tree; retv = look_up(); workt = 0; return retv; } } /* look_up(c,f) if C is not one of the in_labels for the roots of forest F, return C as a non-logical character otherwise if C is the in_label of a leaf, return the translation as a logical character otherwise lookup the rest of the input in the children of C */ log_char look_up() { log_char lc; while( workt != fnull && workt->in_label != workc ){ workt = workt->sibling; } if( workt == fnull) { lc.logical = FALSE; lc.symbol = workc; return( lc ); } if( workt->first_child == fnull ){ lc.logical = TRUE; lc.symbol = (char) workt->translation; return( lc ); } workt = workt->first_child; workc = input(); return look_up(); } cleanup(f) forest f; { if (f != fnull) { cleanup(f->first_child); cleanup(f->sibling); free(f); } } extern int block; /* should we block or jump out? */ extern int inisstd; /* input is stdin? */ extern FILE *fdstack[]; extern int fdtop; extern jmp_buf lin_top; extern int errno; /** input - input a character, may jump out if not ready */ input() { static int c; long numchars; static int eof_found = FALSE; if (eof_found) longjmp(lin_top, 1); /* return -1 */ if (!inisstd) /* isatty? */ { if (((c = fgetc(fdstack[fdtop])) == EOF) || c == 'D'-'@') { fclose(fdstack[fdtop--]); if (fdtop < 0) { eof_found = TRUE; longjmp(lin_top, 1); /* return -1 */ } inisstd = (fdstack[fdtop] == stdin); return input(); } else return c; } else { if (!block) { int fil_flags; fil_flags = fcntl(0, F_GETFL, 0); fcntl(0, F_SETFL, fil_flags | FNDELAY); if (read(0, &c, 1) != 1) { int sav_err; sav_err = errno; fcntl(0, F_SETFL, fil_flags); if (sav_err == EWOULDBLOCK) longjmp(lin_top, 2); /* return 0 */ else /* assume eof */ { eof_found = TRUE; longjmp(lin_top, 1); /* return -1 */ } } fcntl(0, F_SETFL, fil_flags); } else if (read(0, &c, 1) != 1) { eof_found = -1; longjmp(lin_top, 1); /* return -1 */ } if (c == 'D'-'@') { eof_found = -1; longjmp(lin_top, 1); /* return -1 */ } return c; } } SHAR_EOF if test 7201 -ne "`wc -c < 'cursin.c'`" then echo shar: error transmitting "'cursin.c'" '(should have been 7201 characters)' fi fi # end of overwriting check if test -f 'cursin.h' then echo shar: will not over-write existing file "'cursin.h'" else cat << \SHAR_EOF > 'cursin.h' typedef struct{ bool logical; char symbol; } log_char; typedef log_char * ptr_log_char; extern log_char cursin(); extern push_back(); extern log_char look_up(); /* Logical characters (may be represented by */ /* multiple character sequences) */ /* */ /* Lb = backspace, Lh = home, */ /* Lu, Ld, Ll, Lr are the arrows keys */ enum log_symbol { lnull, Leof, Lb, Ld, Lh, Ll, Lr, Lu, Lfr, Lfl, Leol, Ldc, Ldw, Ldl, Ldeol }; SHAR_EOF if test 451 -ne "`wc -c < 'cursin.h'`" then echo shar: error transmitting "'cursin.h'" '(should have been 451 characters)' fi fi # end of overwriting check if test -f 'defs.h' then echo shar: will not over-write existing file "'defs.h'" else cat << \SHAR_EOF > 'defs.h' #define RTARROW Lr #define LTARROW Ll #define UPARROW Lu #define DNARROW Ld #define FRTARROW Lfr #define FLTARROW Lfl #define MVEOL Leol #define MVBOL Lh #define DCHAR Ldc #define DPCHAR Lb #define DWORD Ldw #define DLINE Ldl #define DEOLINE Ldeol #define LEOF Leof #define MAX_HIST 8192 #define MAX_INSTR 512 SHAR_EOF if test 312 -ne "`wc -c < 'defs.h'`" then echo shar: error transmitting "'defs.h'" '(should have been 312 characters)' fi fi # end of overwriting check if test -f 'env.h' then echo shar: will not over-write existing file "'env.h'" else cat << \SHAR_EOF > 'env.h' /* Little Smalltalk execution environment definitions. The Little Smalltalk system is tailored to various machines by changing defined constants. These constants, and their meanings, are as follows: GAMMA defined if gamma is part of the math library FACTMAX maximum integer value for which a factorial can be computed by repeated multiplication without overflow. INLINE generate inline code for increments or decrements - produces larger, but faster, code. MDWINDOWS defined if the maryland windows package is used OPEN42 defined if berkeley style (3 argument) opens are used In addition to defining constants, the identifier type ``undefined character'' needs to be defined. Bytecodes are stored using this datatype. On machines which do not support this datatype directly, macros need to be defined that convert normal chars into unsigned chars. unsigned chars are defined by a typedef for ``uchar'' and a pair of macros that convert an int into a uchar and vice-versa. In order to simplify installation on systems to which the Little Smalltalk system has already been ported, various ``meta-defines'' are recognized. By defining one of these symbols, the correct definitions for other symbols will automatically be generated. The currently recognized meta-defines are as follows: BERK42 Vax Berkeley 4.2 DECPRO Dec Professional 350 running Venix PDP1170 PdP 11/70 RIDGE Ridge ROS 3.1 Finally, a few path names have to be compiled into the code. These path names are the following: TEMPFILE - a temporary file name in mktemp format PARSER - the location of the parser PRELUDE - the location of the standard prelude in ascii format FAST - the location of the standard prelude in saved format */ # define TEMPFILE "/usr/tmp/stXXXXXX" # define PARSER "/usr/budd/st80/bin/parse" # define PRELUDE "/usr/budd/st80/prelude/standard" # define FAST "/usr/budd/st80/prelude/stdsave" /* meta-define */ # define BERK42 /*------------------------------ VAX Berkeley 4.2 definition */ # ifdef BERK42 # define GAMMA /* gamma value is known */ # define FACTMAX 12 # define OPEN42 /* use 4.2 style opens */ typedef unsigned char uchar; # define itouc(x) ((uchar) x) # define uctoi(x) ((int) x) /* # define MDWINDOWS */ # endif /* BERK42 definition */ /* ---------------------------------------RIDGE ROS 3.1 definition */ # ifdef RIDGE # define GAMMA /* gamma value is known */ # define FACTMAX 12 # define OPEN42 /* use 4.2 style opens */ typedef unsigned char uchar; # define itouc(x) ((uchar) x) # define uctoi(x) ((int) x) # endif /* RIDGE definition */ /* --------------------------------------------DEC PRO definitions */ # ifdef DECPRO /* GAMMA, OPEN42 not defined */ # define FACTMAX 6 /* unsigned characters not supported, but can be simulated */ typedef char uchar; # define itouc(x) ((uchar) x) # define uctoi(x) (unsigned) (x >= 0 ? x : x + 256) # endif /* DECPRO definition */ /* --------------------------------------------PDP11/70 definitions */ # ifdef PDP1170 /* GAMMA, OPEN42 not defined */ # define FACTMAX 6 /* unsigned characters not supported, but can be simulated */ typedef char uchar; # define itouc(x) ((uchar) x) # define uctoi(x) (unsigned) (x >= 0 ? x : x + 256) # endif /* PDP1170 definition */ /******************************************************************/ /* the following are pretty much independent of any system */ # define INLINE /* produce in line code for incs and decs */ /*# define MDWINDOWS*/ /* maryland windows package available */ SHAR_EOF if test 3525 -ne "`wc -c < 'env.h'`" then echo shar: error transmitting "'env.h'" '(should have been 3525 characters)' fi fi # end of overwriting check if test -f 'his.c' then echo shar: will not over-write existing file "'his.c'" else cat << \SHAR_EOF > 'his.c' #include <stdio.h> #include <sgtty.h> #include <ctype.h> #include <curses.h> #include "cursin.h" #include "pat.h" #include "defs.h" /* taken from curses.h and modified */ #define cbreak() (_tty.sg_flags|=CBREAK, _pfast=_rawmode=TRUE, stty(_tty_ch,&_tty)) #define nocbreak() (_tty.sg_flags&=~CBREAK,_rawmode=FALSE,_pfast=!(_tty.sg_flags&CRMOD),stty(_tty_ch,&_tty)) extern char spat[]; char *fix_line(); /* what is the basic unit of manipulation by the history manager? A complete instruction (this may be multiple lines) How do we deal with commands that wrap around? Move the whole word to the next line, indent, and place a '\' in the last column of the preceding line. Implicitly, reform paragraphs? No, users may want to be able to control where the line breaks. always assume nothing on screen beneath current position has any significance some terminals permit the placement of characters in the bottom right without scrolling, others scroll automatically. Two solutions: Always explicitly scroll anytime anyone wants to put a character in the questionable position. After putting a character in the questionable position, always check to see what the current cursor is. I like the first option better, it allows me to always do the same thing, regardless of the current terminal type. */ /* keep global variables for */ int totrows, totcols; /* total number of rows, columns on terminal */ char history[MAX_HIST]; /* history buffer */ char *sohist = history; char *eohist = history; int his_cnt = 0; /* how many characters in history */ static char *cur_his; /* points to current focus of interest within history buffer */ #define hnext(p) (p+1 >= history+MAX_HIST)? history: p+1 #define hprev(p) (p > history)? p-1: history+MAX_HIST-1 char termbuf[1024]; setup() { char *cp, *getenv(); if (tgetent(termbuf, getenv("TERM")) != 1) cant_happen(31); totrows = tgetnum("li"); totcols = tgetnum("co"); if (totrows == -1 || totcols == -1) cant_happen(32); cursinit(); initscr(); clear(); /* clear the screen */ raw(); /* set to raw mode */ noecho(); /* don't implicitly echo characters */ scrollok(stdscr, TRUE); move(0,0); refresh(); } finish() { noraw(); echo(); endwin(); } /* update, starting on specified row, rewrite the instruction in its entirety, leaving cursor over specified character, assume the instruction conforms to the following: The first line has no more than 71 characters Subsequent lines have no more than 63 characters No more than 24 lines total. Each character except '\n' occupy a single position on terminal screen All but last line are terminated with '\' Returns the row number of the start of the instruction, as it now stands. */ update(text, top_row, cursor) char *text; int top_row; char *cursor; /* index of cursor position within text. - if index of new line or null terminator, then position cursor after last character of line */ { int nurow, nucol; register int i, j; nurow = -1; for(i=0; ; i++) { int indent; move(top_row+i, 0); if (i) indent = 12; else indent = 8; while (isspace(*text)) text++; for(j=indent; j--; ) addch(' '); for(j=0; ; j++) { if (nurow == -1 && text >= cursor) { nurow = i; nucol = j + indent; } /* should we adjust cursor? */ if (*text == '\n') addch('\\'); if (*text) addch(*text); else { if (i + top_row >= totrows) top_row -= totrows + 1 -(i + top_row); clrtobot(); move(nurow + top_row, nucol); refresh(); return top_row; } if (*text++ == '\n') break; } } } char ins_buf[1024]; /* edit the current command line, after printing its current state on the terminal */ get_instruction() { static char *workbuf; static char *textp; register char *scp, *dcp; static int ccnt; static int processing = 0; static int top_row; workbuf = ins_buf; if (!processing) { int crow, ccol; cur_his = eohist; ccnt = 0; workbuf[0] = '\0'; textp = workbuf; getyx(stdscr, crow, ccol); top_row = crow; processing = TRUE; } for(;;) { log_char c; top_row = update(workbuf, top_row, textp); c = cursin(); if (c.logical) { switch((enum log_symbol) c.symbol) { case LEOF: cant_happen(33); case RTARROW: if (*textp) textp++; else beep(); break; case LTARROW: if (textp > workbuf) textp--; else beep(); break; case UPARROW: *textp = '\0'; ccnt = uphist(workbuf); textp = workbuf; break; case DNARROW: *textp = '\0'; ccnt = dnhist(workbuf); textp = workbuf; break; case FRTARROW: if (!*textp) { beep(); break; } textp++; for( ; *textp && !isspace(*textp); ) textp++; /* skip current word */ for( ; *textp && isspace(*textp); ) textp++; /* and space that follows */ break; case FLTARROW: if (textp <= workbuf) { beep(); break; } textp--; for( ; textp > workbuf && isspace(*textp); ) textp--; /* skip space */ for( ; textp > workbuf && !isspace(*(textp-1)); ) textp--; /* and preceding word */ break; case MVEOL: while (*textp) textp++; break; case MVBOL: textp = workbuf; break; case DCHAR: if (!*textp) { beep(); break; } dcp = textp; scp = textp+1; ccnt--; while (*dcp++ = *scp++) ; textp = fix_line(workbuf, textp); break; case DPCHAR: if (textp <= workbuf) beep(); else { textp--; dcp = textp; scp = textp+1; ccnt--; while (*dcp++ = *scp++) ; textp = fix_line(workbuf, textp); } break; case DWORD: if (!*textp) { beep(); break; } dcp = textp; for(scp=textp+1; *scp && !isspace(*scp); ) scp++; while (*scp && isspace(*scp)) scp++; while (*dcp++ = *scp++) ; /* check for lines too long */ textp = fix_line(workbuf, textp); ccnt = strlen(workbuf); break; case DLINE: textp = workbuf; ccnt = 0; *textp = '\0'; break; case DEOLINE: for(scp=textp; *scp; scp++) ; *textp = '\0'; ccnt = strlen(workbuf); break; default: cant_happen(34); } } else { if (c.symbol == '\r') c.symbol = '\n'; if (c.symbol == '\n') { if ((textp > workbuf && *(textp-1) != '\\') || (textp == workbuf)) { char tbuf[MAX_INSTR]; int length; for( ; *textp; ) textp++; /* move to eol */ top_row = update(workbuf, top_row, textp); processing = FALSE; addch('\n'); addhistory(workbuf); /* insert '\' before each nuline to make parser happy */ length = strlen(workbuf) + 1; length = MAX_INSTR - length; for(scp = workbuf, dcp = tbuf; *dcp++ = *scp++; ) ; for(scp = tbuf, dcp = workbuf; *scp; ) { if (*scp == '\n') { *dcp++ = '\\'; if (!length--) cant_happen(39); } *dcp++ = *scp++; } *dcp = '\0'; return 1; } else if (ccnt + 4 < MAX_INSTR) { *(textp-1) = '\n'; c.symbol = ' '; } else beep(); /* fall through to add space */ } if (isprint(c.symbol) && ccnt+4 < MAX_INSTR) { /* open up a hole */ for(scp = textp; *scp; ) scp++; dcp = scp+1; for( ; scp >= textp; ) *dcp-- = *scp--; *textp++ = c.symbol; textp = fix_line(workbuf, textp); ccnt = strlen(workbuf); } else beep(); } } } /* if any line of instruction is too long, fix it, return new cp */ char *fix_line(buf, cp) register char *buf, *cp; { register int i; int max_chars; char *start_row, *oldcp; /* find beginning of line */ oldcp = cp; if (cp > buf) cp--; /* if i'm on a newline, ignore it */ while (cp >= buf && *cp != '\n') cp--; if (cp < buf) max_chars = 71; else max_chars = 67; /* cp now-points to beginning of current line */ /* count the characters */ start_row = cp++; while (isspace(*cp) && *cp != '\n') cp++; /* don't count space at start of line */ for(i=0; *cp && *cp != '\n'; cp++) if (++i == max_chars) { /* split the line */ /* because we keep a running total, we only split once. */ register char *scp, *dcp; char *savcp; savcp = cp--; /* character pointed to by cp must be moved to next line, replace it with '\' */ /* look for preceding word break */ /* leave room for '\' */ if (oldcp >= savcp) oldcp++; while (cp > start_row && !isspace(*cp)) cp--; while (cp > start_row && isspace(*cp)) cp--; /* add to beginning of space */ if (cp == start_row) { /* single word occupies entire line */ for(scp = savcp; *scp; scp++) ; dcp = scp + 1; while (scp >= savcp) *dcp-- = *scp--; *savcp++ = '\n'; } else { for(scp = savcp; *scp; scp++) ; dcp = scp + 1; cp++; /* break before spaces */ while (scp >= cp) *dcp-- = *scp--; *cp++ = '\n'; } break; } return oldcp; } beep() { putchar('G'-'@'); } /* invoke history system to locate preceding line with pattern specified by buf, place replacement string in same buf, return # of lines in new buf */ uphist(buf) char *buf; { register char *tcp; char *sbuf; sbuf = buf; if (!*buf) /* duplicate last line */ strcpy(buf, ".*"); if (makepat(buf) != MYOK) { beep(); /* bad pattern */ makepat(".*"); } for(;;) { if (cur_his == sohist) { beep(); *sbuf = '\0'; return 0; } else /* move to preceding line */ { buf = sbuf; cur_his = hprev(cur_his); /* ignore null */ cur_his = hprev(cur_his); while (*cur_his) cur_his = hprev(cur_his); cur_his = hnext(cur_his); /* copy current line onto buf */ for (tcp = cur_his; *tcp; tcp = hnext(tcp)) *buf++ = *tcp; *buf++ = '\0'; if (match(sbuf, spat)) return strlen(sbuf); } } } /* invoke history system to locate following line with pattern specified by buf, place replacement string in same buf, return # of lines in new buf */ dnhist(buf) char *buf; { register char *tcp; char *sbuf; sbuf = buf; if (!*buf) strcpy(buf, ".*"); if (makepat(buf) != MYOK) { beep(); makepat(".*"); } for(;;) { if (cur_his == eohist) { *sbuf = '\0'; beep(); return 0; } else { /* move to next line */ buf = sbuf; while (*cur_his) cur_his = hnext(cur_his); cur_his = hnext(cur_his); if (cur_his == eohist) { *sbuf = '\0'; beep(); return 0; } else { for(tcp = cur_his; *tcp; ) { *buf++ = *tcp; tcp = hnext(tcp); } *buf++ = '\0'; } if (match(sbuf, spat)) return strlen(sbuf); } } } /* add line to history, if necessary delete lines from beginning of buffer to make room. */ addhistory(line) char *line; { while (*line) adch(*line++); adch('\0'); } adch(c) char c; { if (his_cnt == MAX_HIST) fre_his(); *eohist = c; his_cnt++; eohist = hnext(eohist); } fre_his() { while (*sohist) { sohist = hnext(sohist); his_cnt--; } sohist = hnext(sohist); /* eat up null terminator */ his_cnt--; } SHAR_EOF if test 11304 -ne "`wc -c < 'his.c'`" then echo shar: error transmitting "'his.c'" '(should have been 11304 characters)' fi fi # end of overwriting check if test -f 'line.c' then echo shar: will not over-write existing file "'line.c'" else cat << \SHAR_EOF > 'line.c' /* Little Smalltalk line grabber - does lowest level input for command lines. */ # include <stdio.h> # include <setjmp.h> # include "object.h" # include "primitive.h" # define MAXINCLUDE 10 # define MAXBUFFER 2000 /* text buffer */ FILE *fdstack[MAXINCLUDE]; int fdtop = -1; int inisstd = 0; /* set file - set a file on the file descriptor stack */ set_file(fd) FILE *fd; { if ((++fdtop) > MAXINCLUDE) cant_happen(20); fdstack[fdtop] = fd; if (fd == stdin) inisstd = 1; else inisstd = 0; } jmp_buf lin_top; int block; /* line-grabber - read a line of text do blocked i/o if blocked is nonzero, otherwise do non-blocking i/o */ /* return 0 if line is complete, 1 if complete line, -1 if end of input */ int line_grabber(lblock) int lblock; { int ret, row, col; block = lblock; if (ret = setjmp(lin_top)) return ret-2; else { get_instruction(); return 1; } } SHAR_EOF if test 895 -ne "`wc -c < 'line.c'`" then echo shar: error transmitting "'line.c'" '(should have been 895 characters)' fi fi # end of overwriting check if test -f 'main.c' then echo shar: will not over-write existing file "'main.c'" else cat << \SHAR_EOF > 'main.c' #include <stdio.h> #include <curses.h> #include "defs.h" extern char ins_buf[]; main() { char workbuf[MAX_INSTR]; int crow, ccol, ret_val; int num_schedules; set_file(stdin); setup(); num_schedules = 0; do { if ((ret_val = line_grabber(0)) == 1) { printw("\n\rgot:\n"); printw(ins_buf); printw("\nwith %d schedules\n\r", num_schedules); num_schedules = 0; } else if (ret_val == -1) break; else num_schedules++; } while(ret_val != -1); finish(); printf("\n"); } cant_happen(num) int num; { fprintf(stderr, "can't happen #%d\n", num); finish(); exit(1); } SHAR_EOF if test 599 -ne "`wc -c < 'main.c'`" then echo shar: error transmitting "'main.c'" '(should have been 599 characters)' fi fi # end of overwriting check if test -f 'object.h' then echo shar: will not over-write existing file "'object.h'" else cat << \SHAR_EOF > 'object.h' /* Little Smalltalk object definitions */ # include "env.h" /* for objects the inst_var array is actually made as large as necessary (as large as the size field). since C does not do subscript bounds checking array indexing can be used */ struct obj_struct { int ref_count; int size; struct class_struct *class; struct obj_struct *super_obj; struct obj_struct *inst_var[1]; }; /* for classes c_size = CLASSSIZE class_name and super_class should be SYMBOLs containing the names of the class and superclass, respectively. c_inst_vars should be an array of symbols, containing the names of the instance variables context size is the size of the context that should be created each time a message is sent to objects of this class. message_names should be an array of symbols, corresponding to the messages accepted by objects of this class. methods should be an array of arrays, each element being a two element array of bytecodes and literals. */ struct class_struct { int c_ref_count; int c_size; struct obj_struct *class_name; struct obj_struct *super_class; struct obj_struct *file_name; struct obj_struct *c_inst_vars; int context_size; struct obj_struct *message_names; struct obj_struct *methods; }; typedef struct class_struct class; typedef struct obj_struct object; /* objects with non-object value (classes, integers, etc) have a negative size field, the particular value being used to indicate the type of object (the class field cannot be used for this purpose can all classes, even those for built in objects, can be redefined) check_bltin is a macro that tests the size field for a particular value. it is used to define other macros, such as is_class, that test each particular type of object. The following classes are builtin Block ByteArray Char Class Float Integer Interpreter String Symbol */ # define BLOCKSIZE -83 # define BYTEARRAYSIZE -567 # define CHARSIZE -33 # define CLASSSIZE -3 # define FILESIZE -5 # define FLOATSIZE -31415 # define INTEGERSIZE -17 # define INTERPSIZE -15 # define STRINGSIZE -258 # define SYMBOLSIZE -14 # define is_bltin(x) (((object *) x)->size < 0) # define check_bltin(obj, type) (((object *) obj)->size == type) # define is_block(x) check_bltin(x, BLOCKSIZE) # define is_bytearray(x) check_bltin(x, BYTEARRAYSIZE) # define is_character(x) check_bltin(x, CHARSIZE) # define is_class(x) check_bltin(x, CLASSSIZE) # define is_file(x) check_bltin(x, FILESIZE) # define is_float(x) check_bltin(x, FLOATSIZE) # define is_integer(x) check_bltin(x, INTEGERSIZE) # define is_interpreter(x) check_bltin(x, INTERPSIZE) # define is_string(x) check_bltin(x, STRINGSIZE) # define is_symbol(x) check_bltin(x, SYMBOLSIZE) /* mstruct is used (via casts) to store linked lists of structures of various types for memory saving and recovering */ struct mem_struct { struct mem_struct *mlink; }; typedef struct mem_struct mstruct; /* sassign assigns val to obj, which should not have a valid value in it already. assign decrements an existing val field first, then assigns. note this will not work for assign(x,x) if x ref count is 1. */ # define sassign(obj, val) obj_inc((object *) (obj = val)) # define assign(obj, val) {obj_dec((object *) obj); sassign(obj, val);} # define structalloc(type) (type *) o_alloc(sizeof(type)) /* if INLINE is defined ( see env.h) , inline code will be generated for object increments. inline code is generally faster, but larger */ # ifdef INLINE # define obj_inc(x) n_incs++, (x)->ref_count++ # endif extern int n_incs, n_decs; extern char *o_alloc(); extern object *new_inst(), *new_sinst(); extern object *new_obj(); extern object *new_array(); extern object *primitive(); extern object *o_nil; extern object *o_true; extern object *o_false; extern int debug; SHAR_EOF if test 3941 -ne "`wc -c < 'object.h'`" then echo shar: error transmitting "'object.h'" '(should have been 3941 characters)' fi fi # end of overwriting check if test -f 'pat.c' then echo shar: will not over-write existing file "'pat.c'" else cat << \SHAR_EOF > 'pat.c' #include <stdio.h> #include <curses.h> #include <ctype.h> #include "pat.h" #define DEBUG 0 #define MAXCHARS 128 #define ADDBUF(c) addbuf(c) char spat[MAXCHARS]; /* holds pattern to be searched */ /* SUGGESTED CALLING SEQUENCE: if (makepat(buf) != 0) error("bad pattern"); ... if (match(s, spat)) then this is the line you want */ char *s; /* current focus of interest in input pattern */ static char *p = spat; /* not sure what this does */ #define DODASH(a,b) if (dodash( a, b ) == MYERR ) return MYERR char *cur_line; /* points to beginning of pattern to match */ char *amatch(); /* makepat - make pattern, terminate at delim returns MYERR if pattern is invalid, otherwise returns address of character immediately following delimiter */ makepat(arg) register char *arg; { register char *lastp, *lp; #if DEBUG fprintf(stderr, "makepat\n"); #endif p = spat; /* overwrite old pattern */ lastp = p; for ( s = arg ; *s != '\0'; ++s) { lp = p; if (*s == ANY) { ADDBUF(ANY); } else if (*s == BOL && s == arg) { ADDBUF(BOL); } else if (*s == EOL && *(s+1) == '\0') { ADDBUF(EOL); } else if (*s == NULINE) { ADDBUF('\n'); } else if (*s == CCL) { if (getccl() == MYERR) return MYERR; } else if (*s == CLOSURE && s != arg && *(s-1) != CLOSURE ) { lp = lastp; if (*lp == BOL || *lp == EOL || *lp == CLOSURE) return(MYERR); if (stclos(lastp) == MYERR) return(MYERR); } else { ADDBUF(CHAR); if ((*s == ESCAPE) && ( *(s+1) != '\0' )) { ADDBUF(*++s); } else { ADDBUF(*s); } } lastp = lp; } if (*s != '\0') /* terminated early */ return(MYERR); ADDBUF('\0'); return MYOK; } /* stclos - insert closure character before last pattern element */ stclos( lastp ) register char *lastp; { register char *q; #if DEBUG fprintf(stderr, "stclos\n"); #endif ADDBUF('\0'); /* check for available space */ for ( q = p - 1; q > lastp; --q ) q[0] = q[-1]; *q = CLOSURE; return MYOK; } /* getccl - create pattern node for CCL or NCCL */ static getccl() { #if DEBUG fprintf(stderr, "getccl\n"); #endif if (*++s == NOT) { ADDBUF(NCCL); ++s; } else { ADDBUF(CCL); } ADDBUF('\0'); /* initialize character class counter */ return filset(); } /* filset - expand set given at s into pattern at p */ filset() { register char *psave; char *index(); static char digits[] = "0123456789"; static char lowalf[] = "abcdefghijklmnopqrstuvwxyz"; static char upalf[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; #if DEBUG fprintf(stderr, "filset\n"); #endif psave = p - 1; /* psave points to character count within CCL */ for ( ; *s != CCLEND && *s != '\0'; ++s) { if (*s == ESCAPE && *(s+1) != '\0') { addmaybe(*++s,psave); } else if (*s != '-') { addmaybe(*s,psave); } else if (p == psave || s[1] == CCLEND) { addmaybe('-',psave); } else if (index(digits,p[-1]) > 0) { DODASH(digits,psave); } else if (index(lowalf,p[-1]) > 0) { DODASH(lowalf,psave); } else if (index(upalf,p[-1]) > 0) { DODASH(upalf,psave); } else { addmaybe('-',psave); } } if (*s != CCLEND) return(MYERR); return(MYOK); } /* dodash - expand s[-1]-s[1] into pat from valid */ dodash(valid, start) register char *valid; register char *start; { register char *k, *limit; char *index(); #if DEBUG fprintf(stderr, "dodash\n"); #endif ++s; if ( *s == '\0' ) return MYERR; limit = index(valid,*s); k = index( valid, *( p-1 )); if ( k > limit ) { addmaybe('-',start); addmaybe(*s,start); return MYOK; } for( k++; k <= limit; ++k ) addmaybe(*k,start); return MYOK; } /* addmaybe - add character c to character class if not already there */ addmaybe( c, start ) char c; register char *start; { #if DEBUG fprintf(stderr, "addmaybe\n"); #endif if ( locate( &c, start-1 )) return; (*start)++; ADDBUF(c); } /* match - find match anywhere on line */ match( s, pat ) register char *s, *pat; { #if DEBUG fprintf(stderr, "match\n"); #endif cur_line = s; for( ; *s != '\0'; s++ ) { if ( amatch( s, pat )) return TRUE; } return FALSE; } /* amatch - look for a match starting at s */ /* returns a pointer to the next character of s to be parsed */ /* or 0 if not found */ char * amatch(s,p) register char *s, *p; { register char *t, *cptr; char *cmatch(), *amatch(); #if DEBUG fprintf(stderr, "amatch\n"); #endif for ( ; *p != '\0'; p += patsiz(p)) if (*p == CLOSURE) { ++p; for (t = s; *t != '\0'; ++t) if (cmatch(t,p) == NULL) break; /* t now points to character that made us fail */ /* try to match rest of pattern against rest of input */ /* shrink the closure by 1 after each failure */ for (p += patsiz(p) ; t >= s; --t) if ( cptr = amatch(t,p)) return cptr; return 0; } else { if ((s = cmatch(s,p)) == NULL) return 0; } return s; } /* patsiz - returns size of pattern at p */ static patsiz(p) register char *p; { #if DEBUG fprintf(stderr, "patsiz\n"); #endif switch( *p ) { case CHAR: return 2; case BOL: case EOL: case ANY: return 1; case CLOSURE: return 1 + patsiz(p+1); case CCL: case NCCL: return *(p+1) + 2; default: cant_happen(35); } } /* cmatch - try to match a single element of the pattern */ static char * cmatch(s,p) register char *s, *p; { char *index(); register int bump; #if DEBUG fprintf(stderr, "cmatch\n"); #endif bump = -1; switch (*p) { case CHAR: if (*s == p[1]) bump = 1; break; case BOL: if (s == cur_line) bump = 0; break; case ANY: if (*s != '\0' && *s != '\n') bump = 1; break; case EOL: if (*s == '\0' || *s == '\n' ) bump = 0; break; case CCL: if (locate(s,p) == 1) bump = 1; break; case NCCL: if (*s != '\0' && locate( s,p ) == 0) bump = 1; break; default: cant_happen(36); } return ( bump >= 0 )? s + bump: NULL; } /* locate - locate the character *s in the character class starting at p */ locate(s,p) register char *s, *p; { register int count; #if DEBUG fprintf(stderr, "locate\n"); #endif count = *++p; while (count-- > 0) if (*s == *++p) return(1); return 0; } addbuf(c) register char c; { #if DEBUG fprintf(stderr, "addbuf\n"); #endif if ( p >= &spat[MAXCHARS]) cant_happen(37); else *p++ = c; } SHAR_EOF if test 6346 -ne "`wc -c < 'pat.c'`" then echo shar: error transmitting "'pat.c'" '(should have been 6346 characters)' fi fi # end of overwriting check if test -f 'pat.h' then echo shar: will not over-write existing file "'pat.h'" else cat << \SHAR_EOF > 'pat.h' #define CHAR 'a' #define BOL '^' #define EOL '$' #define NULINE '@' #define ANY '.' #define CCL '[' #define CCLEND ']' #define NCCL 'n' #define NOT '^' #define CLOSURE '*' #define ESCAPE '\\' #define MYOK 0 #define MYERR -1 SHAR_EOF if test 253 -ne "`wc -c < 'pat.h'`" then echo shar: error transmitting "'pat.h'" '(should have been 253 characters)' fi fi # end of overwriting check if test -f 'primitive.h' then echo shar: will not over-write existing file "'primitive.h'" else cat << \SHAR_EOF > 'primitive.h' /* Little Smalltalk primitive definitions (only a subset of primitives are described here, basically those used by the courier and other systems routines. All other primitives are known only by number) */ # define EQTEST 7 # define GAMMAFUN 77 # define SYMEQTEST 91 # define SYMPRINT 94 # define FINDCLASS 99 # define GROW 113 # define BLKRETERROR 127 # define REFCOUNTERROR 128 # define NORESPONDERROR 129 # define RAWPRINT 120 # define PRINT 121 # define ERRPRINT 123 # define DIEPRIMITIVE 140 # define BLOCKEXECUTE 142 # define GETSENDER 145 SHAR_EOF if test 554 -ne "`wc -c < 'primitive.h'`" then echo shar: error transmitting "'primitive.h'" '(should have been 554 characters)' fi fi # end of overwriting check if test -f 'prob.st' then echo shar: will not over-write existing file "'prob.st'" else cat << \SHAR_EOF > 'prob.st' Class DiscreteProbability | randnum | [ initialize randnum <- Random new | next ^ self inverseDistribution: randnum next | computeSample: m outOf: n m > n ifTrue: [^ 0.0] ^ n factorial / (n - m) factorial ] Class Geometric :DiscreteProbability | prob | [ mean: m prob <- m | mean ^ 1.0 / prob | variance ^ (1.0 - prob) / prob * prob | density: x x > 0 ifTrue: [^prob * ((1.0-prob) raisedTo: x-1)] ifFalse: [^1.0] | inverseDistribution: x ^ (x ln / (1.0 - prob) ln) ceiling ] Class Binomial :DiscreteProbability | number prob | [ events: num mean: p (p between: 0.0 and: 1.0) ifFalse: [self error: 'mean must be > 0']. number <- num. prob <- p | mean ^ prob | variance ^ prob * (1 - prob) | density: x (x between: 0.0 and number) ifTrue: [^((self computeSample: x outOf: number) / (self computeSample: x outOf: x)) * (prob raisedTo: x) * ((1 - prob) raisedTo: number - x)] ifFalse: [^0.0] | inverseDistribution: x x <= prob ifTrue: [^ 1] ifFalse: [^ 0] | next | t | t <- 0. number timesRepeat: [t <- t + super next]. ^ t ] SHAR_EOF if test 1118 -ne "`wc -c < 'prob.st'`" then echo shar: error transmitting "'prob.st'" '(should have been 1118 characters)' fi fi # end of overwriting check if test -f 'prob.uniform' then echo shar: will not over-write existing file "'prob.uniform'" else cat << \SHAR_EOF > 'prob.uniform' Class ProbabilityDistribution :Stream [ new "create instance" ^ self basicNew | next "random sampling" ^ self inverseDistribution: U next | density: x "is the density func" self subclassResponsibility | distribution: aCollection "cum prob func, arg range of vals" self subclassResponsibility | inverseDistribution: x self subclassResponsibility | computeSample: m outOf: n m > n ifTrue: [^0.0] ^ n factorial / (n - m) factorial ] Class ContinuousProbability :ProbabilityDistribution [ distribution: aCollection | t aStream x1 x2 y1 y2 | t <- 0.0. aStream <- ReadStream on: aCollection. x2 <- aStream next. y2 <- self density: x2. [x1 <- x2. x2 <- aStream next] whileTrue: [y1 <- y2. y2 <- self density: x2. t <- t + ((x2 - x1) * (y2 + y1))]. ^ t * 0.5 ] Class Uniform :ContinuousProbability | startNumber stopNumber | [ from: begin to: end begin > end ifTrue: [self error "illegal interval"] ifFalse: [^ self new setStart: begin toEnd: end] | mean ^ (startNumber + stopNumber) / 2 | variance ^ (stopNumber + startNumber) squared / 12 | density: x (x between: startNumber and: stopNumber) ifTrue: [^1.0 / (stopNumber - startNumber)] ifFalse: [^0] | inverseDistribution: x ^ startNumber + (x * (stopNumber - startNumber)) | setStart: begin toEnd: end startNumber <- begin. stopNumber <- end ] SHAR_EOF if test 1396 -ne "`wc -c < 'prob.uniform'`" then echo shar: error transmitting "'prob.uniform'" '(should have been 1396 characters)' fi fi # end of overwriting check if test -f 'sim.1' then echo shar: will not over-write existing file "'sim.1'" else cat << \SHAR_EOF > 'sim.1' Class Simulation :Object | currentTime action aProbDist totalProfit | [ initialize currentTime <- 0.0. totalProfit <- 0 | scheduleArrivalOf: actionBlock accordingTo: aProbabilityDistribution action <- actionBlock. aProbDist <- aProbabilityDistribution | startUp self initialize. self defineArrivalSchedule | proceed currentTime <- currentTime + aProbDist next. action value | time ^ currentTime | thisProfit: aNumber totalProfit <- totalProfit + aNumber | reportProfit totalProfit print | defineArrivalSchedule | customer profit | self scheduleArrivalOf: [customer <- Visitor new init. profit <- customer numberScoops * 40 / 100. self thisProfit: profit] accordingTo: Random new ] Class Visitor :Object | random | [ init random <- Random new | numberScoops | scoops | scoops <- 1 / (random next). ^ scoops ] SHAR_EOF if test 876 -ne "`wc -c < 'sim.1'`" then echo shar: error transmitting "'sim.1'" '(should have been 876 characters)' fi fi # end of overwriting check if test -f 'sim.2' then echo shar: will not over-write existing file "'sim.2'" else cat << \SHAR_EOF > 'sim.2' Class Simulation :Object | currentTime eventQueue numberChairs newVisitor superVisitor numberServed visitorProbDist missedGroup totalProfit profitMargin coneCost | [ startUp self initialize. self defineArrivalSchedule. superVisitor <- SimulationObject new init. eventQueue at: self timeNextVisitor put: (newVisitor value: superVisitor) | initialize currentTime <- 0.0. numberChairs <- 12. profitMargin <- 0.75. coneCost <- 0.70. totalProfit <- 0. numberServed <- 0. missedGroup <- 0. eventQueue <- Dictionary new | defineArrivalSchedule self scheduleArrivalOf: [:superV | Visitor new initialize: superV] accordingTo: (Geometric new initialize mean: 24 / 60) | scheduleArrivalOf: aVisitor accordingTo: aProbabilityDistribution newVisitor <- aVisitor. visitorProbDist <- aProbabilityDistribution | timeNextVisitor ^ currentTime + visitorProbDist next | time ^ currentTime | proceed | visitor minTime | eventQueue at: self timeNextVisitor put: (newVisitor value: superVisitor). minTime <- 999999. eventQueue keysDo: [:x | x < minTime ifTrue: [minTime <- x] ]. visitor <- eventQueue removeKey: minTime ifAbsent: (self error: 'no visitor in eventQueue'). self incrTime: minTime. (visitor entering) ifTrue: [(visitor groupSize <= numberChairs) ifTrue: [self tasks: visitor] ifFalse: [self missed: visitor groupSize] ] ifFalse: [self releaseChairs: visitor groupSize] | incrTime: aNumber currentTime <- currentTime + aNumber | tasks: aVisitor self served: aVisitor groupSize. self takeChairs: aVisitor groupSize. self thisProfit: aVisitor groupSize * 1.5 * coneCost * profitMargin. "1.5 cones/person" eventQueue at: currentTime + aVisitor time put: aVisitor | served: aNumber numberServed <- numberServed + aNumber | takeChairs: aNumber numberChairs <- numberChairs - aNumber | releaseChairs: aNumber numberChairs <- numberChairs + aNumber | missed: aNumber missedGroup <- missedGroup + aNumber | report 'total profit' print. totalProfit print. 'number of people served' print. numberServed print. 'number of people turned away' print. missedGroup print | thisProfit: aNumber totalProfit <- totalProfit + aNumber ] Class Visitor :SimulationObject | sizeGroup wait alreadyEaten | [ initialize: superClass sizeGroup <- superClass size. wait <- superClass wait: sizeGroup. alreadyEaten <- false | entering (alreadyEaten == false) ifTrue: [alreadyEaten <- true. ^ true]. ^ false | time ^ wait | groupSize ^ sizeGroup ] Class SimulationObject :Object | sizeDist waitDist | [ init sizeDist <- Binomial new initialize events: 5 mean: 0.4. waitDist <- Random new "uniform distribution" | size ^ sizeDist next | wait: sizeGroup "uniform distribution from 1 to 6" ^ waitDist next * sizeGroup * 6 ] SHAR_EOF if test 2927 -ne "`wc -c < 'sim.2'`" then echo shar: error transmitting "'sim.2'" '(should have been 2927 characters)' fi fi # end of overwriting check if test -f 'sim.3' then echo shar: will not over-write existing file "'sim.3'" else cat << \SHAR_EOF > 'sim.3' Class Simulation :Object | currentTime eventQueue resources newVisitor superVisitor visitorProbDist | [ startUp self initialize. self defineArrivalSchedule. superVisitor <- SimulationObject new init. self addNextEvent | initialize currentTime <- 0.0. eventQueue <- Dictionary new | initResources: aNumber resources <- aNumber | scheduleArrivalOf: aVisitor accordingTo: aProbabilityDistribution newVisitor <- aVisitor. visitorProbDist <- aProbabilityDistribution | timeNextVisitor ^ currentTime + visitorProbDist next | time ^ currentTime | proceed | visitor minTime | minTime <- 999999. eventQueue keysDo: [:x | x < minTime ifTrue: [minTime <- x] ]. visitor <- eventQueue removeKey: minTime ifAbsent: (self error: 'no visitor in eventQueue'). currentTime <- minTime. self tasks: visitor. self addNextEvent | addNextEvent eventQueue at: self timeNextVisitor put: (newVisitor value: superVisitor) | delay: visitor for: time eventQueue at: currentTime + time put: visitor | numResources ^ resources | takeResources: aNumber resources <- resources - aNumber | releaseResources: aNumber resources <- resources + aNumber ] Class IceCreamStore :Simulation | numberChairs missedGroup servedGroup totalProfit profitMargin coneCost | [ initialize super initialize. servedGroup <- 0. missedGroup <- 0. totalProfit <- 0. profitMargin <- 0.75. coneCost <- 0.70. numberChairs <- 8. super initResources: numberChairs | defineArrivalSchedule super scheduleArrivalOf: [:superV | Visitor new initialize: superV] accordingTo: (Geometric new initialize mean: 14 / 60) "expect 18 parties per hour" | tasks: visitor (visitor entering) ifTrue: [(visitor groupSize <= super numResources) ifTrue: [self getIceCream: visitor] ifFalse: [self missed: visitor groupSize] ] ifFalse: [self releaseChairs: visitor groupSize] | getIceCream: aVisitor self served: aVisitor groupSize. self takeChairs: aVisitor groupSize. self thisProfit: aVisitor groupSize * 1.5 * coneCost * profitMargin. "1.5 cones/person" super delay: aVisitor for: aVisitor time | takeChairs: aNumber super takeResources: aNumber | releaseChairs: aNumber super releaseResources: aNumber | missed: aNumber missedGroup <- missedGroup + aNumber | served: aNumber servedGroup <- servedGroup + aNumber | thisProfit: aNumber totalProfit <- totalProfit + aNumber | report 'total profit' print. totalProfit print. 'number of people served' print. servedGroup print. 'number of people turned away' print. missedGroup print ] SHAR_EOF if test 2693 -ne "`wc -c < 'sim.3'`" then echo shar: error transmitting "'sim.3'" '(should have been 2693 characters)' fi fi # end of overwriting check if test -f 'simulat.result' then echo shar: will not over-write existing file "'simulat.result'" else cat << \SHAR_EOF > 'simulat.result' time: 35 profit: 13.38 served: 17 turned away: 23 SHAR_EOF if test 50 -ne "`wc -c < 'simulat.result'`" then echo shar: error transmitting "'simulat.result'" '(should have been 50 characters)' fi fi # end of overwriting check if test -f 'visitor.st' then echo shar: will not over-write existing file "'visitor.st'" else cat << \SHAR_EOF > 'visitor.st' Class SimulationObject :Object | sizeDist waitDist | [ init sizeDist <- Binomial new initialize events: 5 mean: 0.4. waitDist <- Random new "uniform distribution" | size ^ sizeDist next | wait: sizeGroup "uniform distribution from 1 to 6" ^ waitDist next * sizeGroup * 6 ] Class Visitor :SimulationObject | sizeGroup wait alreadyEaten | [ initialize: superClass sizeGroup <- superClass size. wait <- superClass wait: sizeGroup. alreadyEaten <- false | entering (alreadyEaten == false) ifTrue: [alreadyEaten <- true. ^ true]. ^ false | time ^ wait | groupSize ^ sizeGroup ] SHAR_EOF if test 617 -ne "`wc -c < 'visitor.st'`" then echo shar: error transmitting "'visitor.st'" '(should have been 617 characters)' fi fi # end of overwriting check cd .. # End of shell archive exit 0