earlw@pesnta.UUCP (Earl Wallace) (06/13/85)
#! /bin/sh # # This is an another posting of the Little Smalltalk source, the last posting # of this source went out in 5 parts and they were too big (>200k) for most # sites so I redid the whole mess to keep the files around the 50k range. # # The complete set is now 20 parts. # # P.S. - If you don't receive all 20 parts within 5 days, drop me a line. # Also, I have the Rand sources of May 1984, if someone has a more # updated copy, I'll be happy to post them (or YOU can post them :-)) # # -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/primitive.h # projects/prob.st # projects/prob.uniform # projects/sim.1 # projects/sim.2 # projects/sim.3 # projects/simulat.result # projects/simulation.bun # projects/switch.st # projects/visitor.st # sources/Makefile # sources/array.c # sources/block.c # sources/block.h # sources/byte.c # sources/byte.h # sources/class.c # sources/cldict.c # sources/courier.c # sources/disclaim # This archive created: Thu Jun 13 11:32:46 1985 # By: Earl Wallace (Perkin-Elmer Data Systems Group / Customer Service) export PATH; PATH=/bin:$PATH if test -f 'projects/primitive.h' then echo shar: will not over-write existing file "'projects/primitive.h'" else cat << \SHAR_EOF > 'projects/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 < 'projects/primitive.h'`" then echo shar: error transmitting "'projects/primitive.h'" '(should have been 554 characters)' fi fi # end of overwriting check if test -f 'projects/prob.st' then echo shar: will not over-write existing file "'projects/prob.st'" else cat << \SHAR_EOF > 'projects/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 < 'projects/prob.st'`" then echo shar: error transmitting "'projects/prob.st'" '(should have been 1118 characters)' fi fi # end of overwriting check if test -f 'projects/prob.uniform' then echo shar: will not over-write existing file "'projects/prob.uniform'" else cat << \SHAR_EOF > 'projects/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 < 'projects/prob.uniform'`" then echo shar: error transmitting "'projects/prob.uniform'" '(should have been 1396 characters)' fi fi # end of overwriting check if test -f 'projects/sim.1' then echo shar: will not over-write existing file "'projects/sim.1'" else cat << \SHAR_EOF > 'projects/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 < 'projects/sim.1'`" then echo shar: error transmitting "'projects/sim.1'" '(should have been 876 characters)' fi fi # end of overwriting check if test -f 'projects/sim.2' then echo shar: will not over-write existing file "'projects/sim.2'" else cat << \SHAR_EOF > 'projects/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 < 'projects/sim.2'`" then echo shar: error transmitting "'projects/sim.2'" '(should have been 2927 characters)' fi fi # end of overwriting check if test -f 'projects/sim.3' then echo shar: will not over-write existing file "'projects/sim.3'" else cat << \SHAR_EOF > 'projects/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 < 'projects/sim.3'`" then echo shar: error transmitting "'projects/sim.3'" '(should have been 2693 characters)' fi fi # end of overwriting check if test -f 'projects/simulat.result' then echo shar: will not over-write existing file "'projects/simulat.result'" else cat << \SHAR_EOF > 'projects/simulat.result' time: 35 profit: 13.38 served: 17 turned away: 23 SHAR_EOF if test 50 -ne "`wc -c < 'projects/simulat.result'`" then echo shar: error transmitting "'projects/simulat.result'" '(should have been 50 characters)' fi fi # end of overwriting check if test -f 'projects/simulation.bun' then echo shar: will not over-write existing file "'projects/simulation.bun'" else cat << \SHAR_EOF > 'projects/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 < 'projects/simulation.bun'`" then echo shar: error transmitting "'projects/simulation.bun'" '(should have been 10103 characters)' fi fi # end of overwriting check if test -f 'projects/switch.st' then echo shar: will not over-write existing file "'projects/switch.st'" else cat << \SHAR_EOF > 'projects/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 < 'projects/switch.st'`" then echo shar: error transmitting "'projects/switch.st'" '(should have been 196 characters)' fi fi # end of overwriting check if test -f 'projects/visitor.st' then echo shar: will not over-write existing file "'projects/visitor.st'" else cat << \SHAR_EOF > 'projects/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 < 'projects/visitor.st'`" then echo shar: error transmitting "'projects/visitor.st'" '(should have been 617 characters)' fi fi # end of overwriting check if test -f 'sources/Makefile' then echo shar: will not over-write existing file "'sources/Makefile'" else cat << \SHAR_EOF > 'sources/Makefile' CFLAGS =-O LFLAGS =-n LIB = -lm BINDIR = ../bin PARSEDIR = ../parser Objects = main.o object.o line.o \ class.o number.o symbol.o string.o byte.o array.o file.o \ primitive.o syms.o cldict.o process.o interp.o block.o courier.o \ lex.o drive.o lexcmd.o Objects.c = main.c object.c line.c \ class.c number.c symbol.c string.c byte.c array.c file.c \ primitive.c syms.c cldict.c process.c interp.c block.c courier.c \ lex.c drive.c lexcmd.c MISC = disclaim Makefile *.h sstr.c symbols st: sstr drive.h cmds.h env.h $(Objects) cc ${CFLAGS} $(LFLAGS) -o st $(Objects) $(LIB) # the following is used by st make script for installation on the DecPro 350 # ld -o st -X -u __doprnt -u fltused -u fptrap -m \ # -lfpsim /lib/fcrt0.o $(Objects) -lm -lc install: st mv st $(BINDIR) bundle: $(MISC) $(Objects.c) rm -f drive.h cmds.h env.h bundle $(MISC) $(Objects.c) >../sources.bundle lint.out:$(Objects.c) lint $(Objects.c) syms.c: sstr symbols sstr -t symbols SYMTABMAX '# include "object.h"' '# include "symbol.h"' >syms.c sstr: sstr.c cc ${CFLAGS} $(LFLAGS) -o sstr sstr.c drive.h: $(PARSEDIR)/drive.h symbols cp $(PARSEDIR)/drive.h . cmds.h: $(PARSEDIR)/cmds.h symbols sstr symbols <$(PARSEDIR)/cmds.h >cmds.h env.h: $(PARSEDIR)/env.h cp $(PARSEDIR)/env.h . number.o: number.c number.h interp.o: drive.h cmds.h primitive.o: *.h main.o: *.h clean: -rm -f ${Objects} sstr drive.h cmds.h env.h SHAR_EOF if test 1410 -ne "`wc -c < 'sources/Makefile'`" then echo shar: error transmitting "'sources/Makefile'" '(should have been 1410 characters)' fi fi # end of overwriting check if test -f 'sources/array.c' then echo shar: will not over-write existing file "'sources/array.c'" else cat << \SHAR_EOF > 'sources/array.c' /* Little Smalltalk Array creation timothy a. budd 10/84 builds a new instance of class array. called mostly by the driver to construct array constants. */ /* The source code for the Little Smalltalk System may be freely copied provided that the source of all files is acknowledged and that this condition is copied with each file. The Little Smalltalk System is distributed without responsibility for the performance of the program and without any guarantee of maintenance. All questions concerning Little Smalltalk should be addressed to: Professor Tim Budd Department of Computer Science The University of Arizona Tucson, Arizona 85721 USA */ # include <stdio.h> # include "object.h" class *Array = (class *) 0; class *ArrayedCollection = (class *) 0; extern object *o_nil, *o_empty, *o_acollection; extern int started; /* gets set after reading std prelude */ /* new_iarray - internal form of new array */ object *new_iarray(size) int size; { object *new; if (size < 0) cant_happen(2); new = new_obj(Array, size, 0); if (! started) { sassign(new->super_obj, o_acollection); } else if (ArrayedCollection) sassign(new->super_obj, new_inst(ArrayedCollection)); return(new); } /* new_array - create a new array */ object *new_array(size, initial) int size, initial; { int i; object *new; if (size == 0) return(o_empty); new = new_iarray(size); if (initial) { for (i = 0; i < size; i++) sassign(new->inst_var[ i ], o_nil); } return(new); } SHAR_EOF if test 1500 -ne "`wc -c < 'sources/array.c'`" then echo shar: error transmitting "'sources/array.c'" '(should have been 1500 characters)' fi fi # end of overwriting check if test -f 'sources/block.c' then echo shar: will not over-write existing file "'sources/block.c'" else cat << \SHAR_EOF > 'sources/block.c' /* Little Smalltalk block creation and block return timothy a. budd, 10/84 */ /* The source code for the Little Smalltalk System may be freely copied provided that the source of all files is acknowledged and that this condition is copied with each file. The Little Smalltalk System is distributed without responsibility for the performance of the program and without any guarantee of maintenance. All questions concerning Little Smalltalk should be addressed to: Professor Tim Budd Department of Computer Science The University of Arizona Tucson, Arizona 85721 USA */ # include <stdio.h> # include "object.h" # include "drive.h" # include "interp.h" # include "block.h" # include "string.h" # include "primitive.h" # include "process.h" extern object *o_object; /* value of generic object */ static mstruct *fr_block = 0; /* free list of unused blocks */ int ca_block = 0; /* count block allocations */ /* cpyInterpreter - make a new copy of an existing interpreter */ static interpreter *cpyInterpreter(anInterpreter) interpreter *anInterpreter; { interpreter *new; new = cr_interpreter((interpreter *) 0, anInterpreter->receiver, anInterpreter->literals, anInterpreter->bytecodes, anInterpreter->context); if (anInterpreter->creator) new->creator = anInterpreter->creator; else new->creator = anInterpreter; new->currentbyte = anInterpreter->currentbyte; return(new); } /* new_block - create a new instance of class Block */ object *new_block(anInterpreter, argcount, arglocation) interpreter *anInterpreter; int argcount, arglocation; { block *new; if (fr_block) { new = (block *) fr_block; fr_block = fr_block->mlink; } else { new = structalloc(block); ca_block++; } new->b_ref_count = 0; new->b_size = BLOCKSIZE; sassign(new->b_interpreter, cpyInterpreter(anInterpreter)); new->b_numargs = argcount; new->b_arglocation = arglocation; return((object *) new); } /* free_block - return an unused block to the block free list */ free_block(b) block *b; { if (! is_block(b)) cant_happen(8); obj_dec((object *)(b->b_interpreter)); ((mstruct *) b)->mlink = fr_block; fr_block = (mstruct *) b; } /* block_execute - queue a block interpreter for execution */ interpreter *block_execute(sender, aBlock, numargs, args) interpreter *sender; block *aBlock; int numargs; object **args; { interpreter *newInt; object *tempobj; if (! is_block(aBlock)) cant_happen(11); if (numargs != aBlock->b_numargs) { sassign(tempobj, new_str("wrong number of arguments for block")); primitive(ERRPRINT, 1, &tempobj); obj_dec(tempobj); if (sender) { push_object(sender, o_nil); } return(sender); /* not sure about this ..... */ } /* we copy the interpreter so as to not destroy the original and to avoid memory pointer cycles */ newInt = cpyInterpreter(aBlock->b_interpreter); if (sender) assign(newInt->sender, sender); if (numargs) copy_arguments(newInt, aBlock->b_arglocation, numargs, args); return(newInt); } /* block_return - return an object from the context in which a block was created */ block_return(blockInterpreter, anObject) interpreter *blockInterpreter; object *anObject; { interpreter *backchain, *parent; interpreter *creatorblock; creatorblock = blockInterpreter->creator; for (backchain = blockInterpreter->sender; backchain; backchain = backchain->sender) { if (! is_interpreter(backchain)) break; if (backchain == creatorblock) { /* found creating context, back up one more */ parent = backchain->sender; if (parent) { if (! is_driver(parent)) push_object(parent, anObject); link_to_process(parent); } else { terminate_process(runningProcess); } return; } } /* no block found, issue error message */ primitive(BLKRETERROR, 1, (object **) &blockInterpreter); parent = blockInterpreter->sender; if (parent) { if (! is_driver(parent)) push_object(parent, anObject); link_to_process(parent); } else { terminate_process(runningProcess); } } SHAR_EOF if test 4045 -ne "`wc -c < 'sources/block.c'`" then echo shar: error transmitting "'sources/block.c'" '(should have been 4045 characters)' fi fi # end of overwriting check if test -f 'sources/block.h' then echo shar: will not over-write existing file "'sources/block.h'" else cat << \SHAR_EOF > 'sources/block.h' /* Little Smalltalk block definitions timothy a. budd, 10/84 */ /* for blocks b_size = BLOCKSIZE b_interpreter is an instance of interpreter that will actually execute the bytecodes for the block. b_numargs and b_arglocation are the number of arguments and the starting argument location in the context array. */ struct block_struct { int b_ref_count; int b_size; interpreter *b_interpreter; int b_numargs; int b_arglocation; } ; typedef struct block_struct block; extern object *new_block(); extern interpreter *block_execute(); SHAR_EOF if test 562 -ne "`wc -c < 'sources/block.h'`" then echo shar: error transmitting "'sources/block.h'" '(should have been 562 characters)' fi fi # end of overwriting check if test -f 'sources/byte.c' then echo shar: will not over-write existing file "'sources/byte.c'" else cat << \SHAR_EOF > 'sources/byte.c' /* Little Smalltalk bytearray manipulation. bytearrays are used almost entirely for storing bytecodes. timothy a. budd, 11/84 */ /* The source code for the Little Smalltalk System may be freely copied provided that the source of all files is acknowledged and that this condition is copied with each file. The Little Smalltalk System is distributed without responsibility for the performance of the program and without any guarantee of maintenance. All questions concerning Little Smalltalk should be addressed to: Professor Tim Budd Department of Computer Science The University of Arizona Tucson, Arizona 85721 USA */ # include <stdio.h> # include "object.h" # include "byte.h" /* bytearrays of less than MAXBSAVE are kept on a free list */ static mstruct *fr_bytearray[MAXBSAVE]; /* better be initialized to zero ! */ /* in order to avoid a large number of small mallocs, a table is used for the first new bytearrays. After the table becomes full, malloc is used to get more space. table should be large enough for the standard prelude, at least */ static uchar btable[MAXBTABSIZE]; int btabletop = 0; /* for the same reason, a number of bytearray bases are statically allocated and kept on a free list */ int ca_barray = 0; static mstruct *fr_bybase = 0; static bytearray by_init[MAXBYINIT]; byte_init() { int i; bytearray *p; mstruct *new; p = by_init; for (i = 0; i < MAXBYINIT; i++) { new = (mstruct *) p; new->mlink = fr_bybase; fr_bybase = new; p++; } } object *new_bytearray(values, size) uchar *values; int size; { bytearray *new; uchar *p, *q; if (size < MAXBSAVE && fr_bytearray[size]) { new = (bytearray *) fr_bytearray[size]; fr_bytearray[size] = fr_bytearray[size]->mlink; } else { if (fr_bybase) { new = (bytearray *) fr_bybase; fr_bybase = fr_bybase->mlink; } else { new = structalloc(bytearray); ca_barray++; } if ((btabletop + size) < MAXBTABSIZE) { new->a_bytes = &btable[btabletop]; btabletop += size; } else { new->a_bytes = (uchar *) o_alloc((unsigned) size); } } new->a_ref_count = 0; new->a_size = BYTEARRAYSIZE; new->a_bsize = size; for (p = new->a_bytes, q = values; size; size--) { *p++ = *q++; } return((object *) new); } free_bytearray(obj) bytearray *obj; { int size; if (! is_bytearray(obj)) cant_happen(8); size = obj->a_bsize; if (size < MAXBSAVE) { ((mstruct *) obj)->mlink = fr_bytearray[size]; fr_bytearray[size] = ((mstruct *) obj); } } SHAR_EOF if test 2517 -ne "`wc -c < 'sources/byte.c'`" then echo shar: error transmitting "'sources/byte.c'" '(should have been 2517 characters)' fi fi # end of overwriting check if test -f 'sources/byte.h' then echo shar: will not over-write existing file "'sources/byte.h'" else cat << \SHAR_EOF > 'sources/byte.h' /* Little Smalltalk Bytearray definitions */ struct byte_struct { int a_ref_count; int a_size; int a_bsize; uchar *a_bytes; } ; typedef struct byte_struct bytearray; # define byte_value(x) (((bytearray *)(x))->a_bytes) /* bytearrays of size less than MAXBSAVE are kept on a free list */ # define MAXBSAVE 50 /* in order to avoid a large number of small mallocs, especially while reading the standard prelude, a fixed area of MAXBTABSIZE is allocated and used for bytecodes until it is full. Thereafter bytecodes are allocated using malloc. This area should be large enough to hold at least all the bytecodes for the standard prelude. */ # define MAXBTABSIZE 5500 /* for the same reason, a number of bytearrays structs are statically allocated and placed on a free list */ # define MAXBYINIT 400 extern object *new_bytearray(); SHAR_EOF if test 855 -ne "`wc -c < 'sources/byte.h'`" then echo shar: error transmitting "'sources/byte.h'" '(should have been 855 characters)' fi fi # end of overwriting check if test -f 'sources/class.c' then echo shar: will not over-write existing file "'sources/class.c'" else cat << \SHAR_EOF > 'sources/class.c' /* Little Smalltalk class instance creation and deletion timothy a. budd 10/84 */ /* The source code for the Little Smalltalk System may be freely copied provided that the source of all files is acknowledged and that this condition is copied with each file. The Little Smalltalk System is distributed without responsibility for the performance of the program and without any guarantee of maintenance. All questions concerning Little Smalltalk should be addressed to: Professor Tim Budd Department of Computer Science The University of Arizona Tucson, Arizona 85721 USA */ # include <stdio.h> # include "object.h" # include "file.h" # include "number.h" # include "symbol.h" # include "string.h" # include "primitive.h" # define streq(x,y) (strcmp(x,y) == 0) extern class *Array, *ArrayedCollection; extern object *o_object, *o_empty, *o_number, *o_magnitude; extern object *o_smalltalk, *o_acollection; static mstruct *fr_class = 0; int ca_class = 0; /* count class allocations */ # define CLASSINITMAX 30 static class cl_table[CLASSINITMAX]; class_init() { class *p; mstruct *new; int i; for (p = cl_table, i = 0; i < CLASSINITMAX; i++, p++) { new = (mstruct *) p; new->mlink = fr_class; fr_class = new; } } class *new_class() { class *new; if (fr_class) { new = (class *) fr_class; fr_class = fr_class->mlink; } else { new = structalloc(class); ca_class++; } new->c_ref_count = 0; new->c_size = CLASSSIZE; sassign(new->file_name, o_nil); sassign(new->class_name, o_nil); new->super_class = (object *) 0; sassign(new->c_inst_vars, o_nil); new->context_size = 0; sassign(new->message_names, o_nil); sassign(new->methods, o_nil); return(new); } class *mk_class(classname, args) char *classname; object **args; { class *new; object *new_iarray(); new = new_class(); assign(new->class_name, args[0]); if (! streq(classname, "Object")) sassign(new->super_class, args[1]); assign(new->file_name, args[2]); assign(new->c_inst_vars, args[3]); assign(new->message_names, args[4]); assign(new->methods, args[5]); new->context_size = int_value(args[6]); new->stack_max = int_value(args[7]); if (streq(classname, "Array")) { assign(Array, new); assign(o_empty, new_iarray(0)); } else if (streq(classname, "ArrayedCollection")) { assign(ArrayedCollection, new); assign(o_acollection, new_inst(new)); assign(o_empty, new_iarray(0)); } else if (streq(classname, "False")) assign(o_false, new_inst(new)) else if (streq(classname, "Magnitude")) assign(o_magnitude, new_inst(new)) else if (streq(classname, "Number")) assign(o_number, new_inst(new)) else if (streq(classname, "Object")) assign(o_object, new_inst(new)) else if (streq(classname, "Smalltalk")) assign(o_smalltalk, new_inst(new)) else if (streq(classname, "True")) assign(o_true, new_inst(new)) else if (streq(classname, "UndefinedObject")) assign(o_nil, new_inst(new)) return(new); } /* new_sinst - new instance with explicit super object */ object *new_sinst(aclass, super) class *aclass; object *super; { object *new; char *classname, buffer[80]; if (! is_class(aclass)) cant_happen(4); classname = symbol_value(aclass->class_name); if ( streq(classname, "Block") || streq(classname, "Char") || streq(classname, "Class") || streq(classname, "Float") || streq(classname, "Integer") || streq(classname, "Process") || streq(classname, "Symbol") ) { sprintf(buffer,"%s: does not respond to new", classname); sassign(new, new_str(buffer)); primitive(ERRPRINT, 1, &new); obj_dec(new); if (super) /* get rid of unwanted object */ {obj_inc((object *) super); obj_dec((object *) super);} new = o_nil; } else if (streq(classname, "File")) { new = new_file(); if (super) /* get rid of unwanted object */ {obj_inc((object *) super); obj_dec((object *) super);} } else if (streq(classname, "String")) { new = new_str(""); if (super) assign(((string *) new)->s_super_obj, super); } else { new = new_obj(aclass, (aclass->c_inst_vars)->size, 1); if (super) sassign(new->super_obj, super); } return(new); } object *new_inst(aclass) class *aclass; { object *super, *sp_class_name, *lookup_class(); class *super_class; if (! is_class(aclass)) cant_happen(4); if (aclass == o_object->class) return(o_object); super = (object *) 0; sp_class_name = aclass->super_class; if (sp_class_name && is_symbol(sp_class_name)) { super_class = (class *) lookup_class(symbol_value(sp_class_name)); if (super_class && is_class(super_class)) super = new_inst(super_class); } return(new_sinst(aclass, super)); } free_class(c) class *c; { if (! is_class(c)) cant_happen(8); obj_dec(c->class_name); if (c->super_class) obj_dec((object *) c->super_class); obj_dec(c->file_name); obj_dec(c->c_inst_vars); obj_dec(c->message_names); obj_dec(c->methods); ((mstruct *) c )->mlink = fr_class; fr_class = (mstruct *) c; } SHAR_EOF if test 4976 -ne "`wc -c < 'sources/class.c'`" then echo shar: error transmitting "'sources/class.c'" '(should have been 4976 characters)' fi fi # end of overwriting check if test -f 'sources/cldict.c' then echo shar: will not over-write existing file "'sources/cldict.c'" else cat << \SHAR_EOF > 'sources/cldict.c' /* Little Smalltalk Internal class dictionary timothy a. budd, 10/84 In order to facilitate lookup, classes are kept in an internal data dictionary. Classes are inserted into this dictionary using a primtitive, and are removed by either being overridden, or being flushed at the end of execution. */ /* The source code for the Little Smalltalk System may be freely copied provided that the source of all files is acknowledged and that this condition is copied with each file. The Little Smalltalk System is distributed without responsibility for the performance of the program and without any guarantee of maintenance. All questions concerning Little Smalltalk should be addressed to: Professor Tim Budd Department of Computer Science The University of Arizona Tucson, Arizona 85721 USA */ # include <stdio.h> # include "object.h" # include "number.h" # include "symbol.h" # include "primitive.h" struct class_entry { /* structure for internal dictionary */ char *cl_name; object *cl_description; struct class_entry *cl_link; }; static struct class_entry *class_dictionary = 0; int ca_cdict = 0; static mstruct *fr_cdict = 0; /* class dictionary free list */ # define CDICTINIT 30 static struct class_entry cdsinit[CDICTINIT]; /* cdic_init - initialize the internal class dictionary */ cdic_init() { struct class_entry *p; mstruct *new; int i; for (p = cdsinit, i = 0; i < CDICTINIT; i++, p++) { new = (mstruct *) p; new->mlink = fr_cdict; fr_cdict = new; } } /* enter_class - enter a class into the internal class dictionary */ 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 */ if (fr_cdict) { p = (struct class_entry *) fr_cdict; fr_cdict = fr_cdict->mlink; } else { p = structalloc(struct class_entry); ca_cdict++; } p->cl_name = name; sassign(p->cl_description, description); p->cl_link = class_dictionary; class_dictionary = p; } /* lookup - take a name and find the associated class object */ 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); } /* free_all_classes - flush all references for the class dictionary */ free_all_classes() { struct class_entry *p; for (p = class_dictionary; p; p = p->cl_link) { obj_dec(p->cl_description); } } /* class_list - list all the subclasses of a class (recursively), indenting by a specified number of tab stops */ class_list(c, n) class *c; int n; { struct class_entry *p; object *prs[2]; class *q; char *name; /* first print out this class name */ if (! is_symbol(c->class_name)) return; sassign(prs[0], c->class_name); name = symbol_value(c->class_name); sassign(prs[1], new_int(n)); primitive(SYMPRINT, 2, prs); obj_dec(prs[0]); obj_dec(prs[1]); /* now find all subclasses and print them out */ for (p = class_dictionary; p; p = p->cl_link) { q = (class *) p->cl_description; if ((is_symbol(q->super_class)) && (strcmp(name, symbol_value(q->super_class)) == 0) ) class_list(q, n+1); } } SHAR_EOF if test 3326 -ne "`wc -c < 'sources/cldict.c'`" then echo shar: error transmitting "'sources/cldict.c'" '(should have been 3326 characters)' fi fi # end of overwriting check if test -f 'sources/courier.c' then echo shar: will not over-write existing file "'sources/courier.c'" else cat << \SHAR_EOF > 'sources/courier.c' /* Little Smalltalk courier - message passing interface timothy a. budd 10/84 */ /* The source code for the Little Smalltalk System may be freely copied provided that the source of all files is acknowledged and that this condition is copied with each file. The Little Smalltalk System is distributed without responsibility for the performance of the program and without any guarantee of maintenance. All questions concerning Little Smalltalk should be addressed to: Professor Tim Budd Department of Computer Science The University of Arizona Tucson, Arizona 85721 USA */ # include <stdio.h> # include "object.h" # include "interp.h" # include "string.h" # include "symbol.h" # include "primitive.h" # define streq(x,y) (strcmp(x,y) == 0) /* send_mess - find the method needed to respond to a message, create the proper context and interpreter for executing the method */ send_mess(sender, receiver, message, args, numargs) interpreter *sender; object *receiver, **args; char *message; int numargs; { object *robject, *method; register object *message_array; object *context, *fnd_super(), *fnd_class(); class *objclass; interpreter *anInterpreter; int i, maxc; for (robject = receiver; robject; ) { if (robject == (object *) 0) break; if (is_bltin(robject)) objclass = (class *) fnd_class(robject); else objclass = robject->class; if ((objclass == (class *) 0) || ! is_class(objclass)) break; message_array = objclass->message_names; for (i = 0; i < message_array->size; i++) { if (symbol_value(message_array->inst_var[i]) == message) { method = (objclass->methods)->inst_var[ i ]; goto do_cmd; } } if (is_bltin(robject)) robject = fnd_super(robject); else robject = robject->super_obj; } /* if we reach this point then no method has been found matching message */ sassign(robject, new_obj((class *) 0, 2, 0)); sassign(robject->inst_var[0], receiver); sassign(robject->inst_var[1], new_sym(message)); primitive(NORESPONDERROR, 2, &(robject->inst_var[0])); obj_dec(robject); /* generate a message passing trace */ backtrace(sender); /* return nil by default */ if (is_interpreter(sender)) push_object(sender, o_nil); link_to_process(sender); goto clean_up; /* do an interpreted method */ /* make a context and fill it in, make an interpeter and link it into process queue */ do_cmd: maxc = objclass->context_size; sassign(context, new_obj((class *)0, maxc, 0)); for (i = 0; i <= numargs; i++) sassign(context->inst_var[i], args[i]); for ( ; i < maxc ; i++ ) sassign(context->inst_var[i], o_nil); anInterpreter = cr_interpreter(sender, robject, method->inst_var[1], method->inst_var[0], context); link_to_process(anInterpreter); obj_dec(context); goto clean_up; /* clean up after yourself */ clean_up: return; } /* responds_to - see if a class responds to a message */ int responds_to(message, aClass) char *message; class *aClass; { object *message_names; int i; message_names = aClass->message_names; for (i = 0; i < message_names->size; i++) if (streq(symbol_value(message_names->inst_var[i]), message)) return(1); return(0); } /* backtrace - generate a backwards message passing trace */ static backtrace(current) interpreter *current; { while (is_interpreter(current->sender) && ! is_driver(current->sender)) { fnd_message(current->receiver, current->bytecodes); current = current->sender; } } /* fnd_message - find the message associated with an interpreter */ static fnd_message(receiver, bytecodes) object *receiver, *bytecodes; { int i; class *oclass; object *messar, *temp; char buffer[100]; oclass = (class *) fnd_class(receiver); messar = oclass->methods; for (i = 0; i < messar->size; i++) { if ((messar->inst_var[i])->inst_var[0] == bytecodes) { sprintf(buffer,"%s: backtrace. message %s", symbol_value(oclass->class_name), symbol_value( (oclass->message_names)->inst_var[i])); sassign(temp, new_str(buffer)); primitive(ERRPRINT, 1, &temp); obj_dec(temp); return; } } cant_happen(24); } /* prnt_messages - print all the messages a class responds to. needed because the messages names array for some of the classes is created before ArrayedCollection, and thus some do not respond to do: */ prnt_messages(aClass) class *aClass; { object *message_names; int i; message_names = aClass->message_names; for (i = 0; i < message_names->size; i++) primitive(SYMPRINT, 1, &message_names->inst_var[i]); } SHAR_EOF if test 4517 -ne "`wc -c < 'sources/courier.c'`" then echo shar: error transmitting "'sources/courier.c'" '(should have been 4517 characters)' fi fi # end of overwriting check if test -f 'sources/disclaim' then echo shar: will not over-write existing file "'sources/disclaim'" else cat << \SHAR_EOF > 'sources/disclaim' /* The source code for the Little Smalltalk System may be freely copied provided that the source of all files is acknowledged and that this condition is copied with each file. The Little Smalltalk System is distributed without responsibility for the performance of the program and without any guarantee of maintenance. All questions concerning Little Smalltalk should be addressed to: Professor Tim Budd Department of Computer Science The University of Arizona Tucson, Arizona 85721 USA */ SHAR_EOF if test 512 -ne "`wc -c < 'sources/disclaim'`" then echo shar: error transmitting "'sources/disclaim'" '(should have been 512 characters)' fi fi # end of overwriting check # End of shell archive exit 0