├── .project ├── LICENCE.md ├── Notes ├── README.md ├── build ├── README.md ├── bootstrap.sh ├── build.sh └── runtests.sh ├── filetree ├── .properties ├── Kernel-Classes │ ├── PCBehavior.class.st │ ├── PCClass.class.st │ ├── PCClassBuilder.class.st │ ├── PCMetaclass.class.st │ └── package.st ├── Kernel-Collections-Abstract │ ├── PCArrayedCollection.class.st │ ├── PCCollection.class.st │ ├── PCSequenceableCollection.class.st │ └── package.st ├── Kernel-Collections-Ordered │ ├── PCArray.class.st │ ├── PCByteArray.class.st │ ├── PCInterval.class.st │ ├── PCLinkedList.class.st │ ├── PCOrderedCollection.class.st │ ├── PCString.class.st │ ├── PCSymbol.class.st │ ├── PCValueLink.class.st │ └── package.st ├── Kernel-Collections-Unordered │ ├── PCAssociation.class.st │ ├── PCDictionary.class.st │ ├── PCSet.class.st │ └── package.st ├── Kernel-Methods │ ├── PCBlock.class.st │ ├── PCCompiledMethod.class.st │ ├── PCContext.class.st │ ├── PCMessage.class.st │ ├── PCMethodContext.class.st │ ├── PCMethodDictionary.class.st │ └── package.st ├── Kernel-Numeric │ ├── PCCharacter.class.st │ ├── PCInteger.class.st │ ├── PCLargeNegativeInteger.class.st │ ├── PCLargePositiveInteger.class.st │ ├── PCMagnitude.class.st │ ├── PCNumber.class.st │ ├── PCSmallInteger.class.st │ └── package.st ├── Kernel-Objects │ ├── PCFalse.class.st │ ├── PCObject.class.st │ ├── PCTrue.class.st │ ├── PCUndefinedObject.class.st │ └── package.st ├── Kernel-Optional-Graphics │ ├── PCBitBlt.class.st │ ├── PCForm.class.st │ ├── PCWordArray.class.st │ └── package.st ├── Kernel-Optional │ ├── PCFile.class.st │ ├── PCFloat.class.st │ ├── PCIdentityDictionary.class.st │ ├── PCIdentitySet.class.st │ ├── PCPoint.class.st │ ├── PCSemaphore.class.st │ └── package.st ├── Kernel-Processes │ ├── PCProcess.class.st │ ├── PCProcessList.class.st │ ├── PCProcessorScheduler.class.st │ └── package.st ├── Kernel-Streams │ ├── PCReadStream.class.st │ ├── PCWriteStream.class.st │ └── package.st └── Kernel-System │ ├── PCSystem.class.st │ └── package.st └── source ├── Kernel-Classes ├── PCBehavior.hz ├── PCClass.hz ├── PCClassBuilder.hz └── PCMetaclass.hz ├── Kernel-Collections-Abstract ├── PCArrayedCollection.hz ├── PCCollection.hz └── PCSequenceableCollection.hz ├── Kernel-Collections-Ordered ├── PCArray.hz ├── PCByteArray.hz ├── PCInterval.hz ├── PCLinkedList.hz ├── PCOrderedCollection.hz ├── PCString.hz ├── PCSymbol.hz └── PCValueLink.hz ├── Kernel-Collections-Unordered ├── PCAssociation.hz ├── PCDictionary.hz └── PCSet.hz ├── Kernel-Methods ├── PCBlock.hz ├── PCCompiledMethod.hz ├── PCContext.hz ├── PCMessage.hz ├── PCMethodContext.hz └── PCMethodDictionary.hz ├── Kernel-Numeric ├── PCCharacter.hz ├── PCInteger.hz ├── PCLargeNegativeInteger.hz ├── PCLargePositiveInteger.hz ├── PCMagnitude.hz ├── PCNumber.hz └── PCSmallInteger.hz ├── Kernel-Objects ├── PCFalse.hz ├── PCObject.hz ├── PCTrue.hz └── PCUndefinedObject.hz ├── Kernel-Optional-Graphics ├── PCBitBlt.hz ├── PCForm.hz └── PCWordArray.hz ├── Kernel-Optional ├── PCFile.hz ├── PCFloat.hz ├── PCIdentityDictionary.hz ├── PCIdentitySet.hz ├── PCPoint.hz └── PCSemaphore.hz ├── Kernel-Processes ├── PCProcess.hz ├── PCProcessList.hz └── PCProcessorScheduler.hz ├── Kernel-Streams ├── PCReadStream.hz └── PCWriteStream.hz └── Kernel-System └── PCSystem.hz /.project: -------------------------------------------------------------------------------- 1 | { 2 | 'srcDirectory' : 'filetree' 3 | } -------------------------------------------------------------------------------- /LICENCE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2013 Guillermo Polito 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. -------------------------------------------------------------------------------- /Notes: -------------------------------------------------------------------------------- 1 | Candle Light remarks 2 | 3 | instSize -> instanceSize 4 | 5 | instSpec -> instanceSpec ?? 6 | "missing comment" 7 | 8 | why do you need Class in 9 | Class PCBehavior>>... 10 | [ 11 | ] 12 | 13 | 14 | Metaclass 15 | name: #PCBehavior; 16 | instanceVariables: #(). 17 | 18 | 19 | ClassDescription does not exist 20 | 21 | I have to rethink 22 | 23 | Class PCMetaclass >> initMethodDict: newMethodDict 24 | [ 25 | "Initialize myself with the given method dictionary. Create but do not initialize my soleInstance." 26 | superclass := PCClass. 27 | methodDict := newMethodDict. 28 | format := PCClass format. "all metaclasses have the same format as PClass" 29 | soleInstance := self basicNew 30 | ] 31 | 32 | Would be nice to have Boolean 33 | 34 | Why this crap on Object 35 | 36 | Class PCObject >> putAscii: asciiValue 37 | [ 38 | "Put the given ascii character (0..255) to standard output. Do nothing if this primitive is not supported." 39 | 40 | 41 | ] 42 | 43 | Class PCObject >> putString: aString 44 | [ 45 | "Write the given string to the standard output stream." 46 | aString do: [ :ch | self putAscii: ch asciiValue ] 47 | ] 48 | 49 | Class PCObject >> putcr 50 | [ 51 | "Write a carriage return to the standard output stream." 52 | self putAscii: 13 53 | ] -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | PharoCandle 2 | =========== 3 | 4 | WARNING: This project contains the current development branch of PharoCandle. 5 | For a stable version, check other branches. 6 | 7 | PharoCandle is a minimal [Pharo](http://www.pharo.org) distribution, based on [MicroSqueak](http://web.media.mit.edu/~jmaloney/microsqueak/readme.txt), work of John Maloney. This distribution is currently for research purposes, but you can take it and use it for your own purposes. 8 | 9 | The main purpose of this project is the Bootstrap of a PharoCandle image using the sourcecode under the _source_ folder. In order to bootstrap, we need to install the bootstrap library into a Pharo environment. Look at _installation_ and _usage_ for more details. 10 | 11 | Installation 12 | ------------ 13 | 14 | In order to download the complete environment to bootsrap PharoCandle, there is only need for execute the following bash script on the master folder. 15 | ```bash 16 | build/build.sh 17 | ``` 18 | 19 | Once downloaded and built, a _results_ folder will be created. The results folder will contain a complete Pharo environment, with the following files: 20 | - pharo_vm: a folder containing the Pharo Virtual Machine 21 | - pharo and pharo_ui scripts to run the VM 22 | - PharoCandleBootstrap.image: Pharo 2.0 image file with the pharo candle project installed 23 | - PharoCandleBootstrap.changes: the changes log of the correspondent image with the same name 24 | - package-cache: a folder for caching Pharo's monticello packages 25 | 26 | Usage 27 | ----- 28 | 29 | To create a PharoCandle image from source code, we bootstrap it following the process described in [here](http://playingwithobjects.wordpress.com/2013/05/06/bootstrap-revival-the-basics/). To run the bootstrap you need to open the PharoCandleBootstrap.image with the VM supporting ui. That can be done in the command line with the following script: 30 | 31 | ```bash 32 | cd results 33 | pharo-ui PharoCandleBootstrap.image 34 | ``` 35 | 36 | The Pharo image will contain the Pharo 2.0 welcome workspace, and a workspace with the code to run the PharoCandleBootstrap. 37 | 38 | Load the sourcecode into the image: 39 | ```smalltalk 40 | seed := PharoCandleSeed new 41 | fromDirectoryNamed: '../source'; 42 | buildSeed. 43 | ``` 44 | 45 | Create an object space that will use an AST evaluator to run code during the bootstrap. An objectspace is an object enclosing the bootstrapped image. 46 | ```smalltalk 47 | objectSpace := OzObjectSpace onOzVM. 48 | objectSpace withExternalSymbolTable. "we need this to bootstrap" 49 | objectSpace worldConfiguration: OzPharoCandle world. 50 | objectSpace interpreter: (AtASTEvaluator new codeProvider: seed; yourself). 51 | ``` 52 | 53 | Create a PharoCandle builder, and tell it to bootstrap. Voilá, the objectSpace will be full 54 | ```smalltalk 55 | builder := PharoCandleBuilder new. 56 | builder objectSpace: objectSpace. 57 | builder kernelSpec: seed. 58 | builder buildKernel. 59 | ``` 60 | 61 | 62 | Browse the bootstrapped objectSpace by evaluating 63 | ```smalltalk 64 | objectSpace browse. 65 | ``` 66 | 67 | You can serialize the objectSpace into an image file (Cog format) by evaluating 68 | ```smalltalk 69 | objectSpace serializeInFileNamed: 'PharoCandle.image'. 70 | ``` 71 | 72 | PharoCandle's Overview 73 | ---------------------- 74 | 75 | PharoCandle is a minimal Pharo distribution containing only 49 classes. Those 49 classes define a whole Pharo kernel including classes such as PCString, PCObject, PCClass or PCSmallInteger. Additionally, it contains a minimal Collection library. PharoCandle classes are prefixed with 'PC' only for documentation purposes, but the prefix is not necessary for the bootstrap. 76 | 77 | When run, a PharoCandle image runs the method **PCSystem>>start**. This method satisfies the role of a main method of other languages. The current distribution's _start_ method is as: 78 | 79 | ```smalltalk 80 | PCSystem >> start 81 | self log: 'Welcome to Pharo Candle edition!'. 82 | self log: self tinyBenchmarks. 83 | self log: PCForm new primScreenSize printString. 84 | self beep. 85 | PCObject superclass ifNil: [ self quit ] 86 | ``` 87 | 88 | Currently, to run a PharoCandle distribution, a special VM is needed that allows the context switch between different images inside the same VM process. The ability for serializing an image into a file will be re-added soon. 89 | 90 | TODOs 91 | ---------------------- 92 | - Autogenerate this script :) -------------------------------------------------------------------------------- /build/README.md: -------------------------------------------------------------------------------- 1 | Build Scripts 2 | ============= 3 | 4 | These are build scripts for ease of configuration and installation. 5 | 6 | The _build.sh_ script downloads a pharo environment, installs the PharoCandle bootstrap code correspondent to this git version, and installs an exemplar script to bootstrap. 7 | 8 | The _runtests.sh_ script downloads a pharo environment, installs the latest PharoCandle bootstrap code, and run the tests on it writing the result in _junit like xml_ files for opening with the Jenkins plugin. -------------------------------------------------------------------------------- /build/bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | #Setup arguments 5 | RESULTS_FOLDER="results" 6 | if [ $# == 0 ]; then 7 | VERSION=bleedingEdge 8 | else 9 | VERSION=$1 10 | fi 11 | 12 | 13 | #Work in temporal directory 14 | if [ -a $RESULTS_FOLDER ]; then 15 | echo "cannot create directory named \""$RESULTS_FOLDER"\": file already exists" 16 | exit 1 17 | fi 18 | 19 | mkdir $RESULTS_FOLDER 20 | cd $RESULTS_FOLDER 21 | 22 | #Load image for this project 23 | 24 | wget -O - guillep.github.io/files/get/OzVmLatest | bash 25 | wget -O - get.pharo.org/30 | bash 26 | wget http://files.pharo.org/sources/PharoV30.sources 27 | ./oz Pharo.image save PharoCandleBootstrap --delete-old 28 | 29 | 30 | 31 | #Load stable version of the monticello configuration, according to this git sources 32 | REPO=http://smalltalkhub.com/mc/Guille/Seed/main 33 | ./oz PharoCandleBootstrap.image config $REPO ConfigurationOfHazelnut --install=$VERSION 34 | 35 | echo "Configuration Loaded. Opening script..." 36 | 37 | echo -e " 38 | objectSpace := PharoCandleBuilder2 bootstrap: '../source'. 39 | objectSpace serializeInFileNamed: 'PharoCandle.image'. 40 | Smalltalk snapshot: false andQuit: true. 41 | " > ./script.st 42 | 43 | ./oz PharoCandleBootstrap.image script.st 44 | rm script.st 45 | rm PharoDebug.log 46 | echo "Script created and loaded. Finished! :D" -------------------------------------------------------------------------------- /build/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | #Setup arguments 5 | RESULTS_FOLDER="results" 6 | if [ $# == 0 ]; then 7 | VERSION=bleedingEdge 8 | else 9 | VERSION=$1 10 | fi 11 | 12 | 13 | #Work in temporal directory 14 | if [ -a $RESULTS_FOLDER ]; then 15 | echo "cannot create directory named \""$RESULTS_FOLDER"\": file already exists" 16 | exit 1 17 | fi 18 | 19 | mkdir $RESULTS_FOLDER 20 | cd $RESULTS_FOLDER 21 | 22 | #Load image for this project 23 | 24 | wget -O - guillep.github.io/files/get/OzVmLatest | bash 25 | wget -O - get.pharo.org/30 | bash 26 | wget http://files.pharo.org/sources/PharoV30.sources 27 | ./oz Pharo.image save PharoCandleBootstrap --delete-old 28 | 29 | 30 | 31 | #Load stable version of the monticello configuration, according to this git sources 32 | REPO=http://smalltalkhub.com/mc/Guille/Seed/main 33 | ./oz PharoCandleBootstrap.image config $REPO ConfigurationOfHazelnut --install=$VERSION 34 | 35 | echo "Configuration Loaded. Opening script..." 36 | 37 | echo -e " 38 | Workspace openContents: 'objectSpace := PharoCandleBuilder2 bootstrap: ''../source''. 39 | objectSpace serializeInFileNamed: ''PharoCandle.image''.'. 40 | Smalltalk snapshot: true andQuit: true." > ./script.st 41 | 42 | ./oz PharoCandleBootstrap.image script.st 43 | rm script.st 44 | rm PharoDebug.log 45 | echo "Script created and loaded. Finished! :D" 46 | -------------------------------------------------------------------------------- /build/runtests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | RESULTS_FOLDER="results" 5 | #Work in temporal directory 6 | if [ -a $RESULTS_FOLDER ]; then 7 | echo "cannot create directory named \""$RESULTS_FOLDER"\": file already exists" 8 | exit 1 9 | fi 10 | 11 | mkdir $RESULTS_FOLDER 12 | cd $RESULTS_FOLDER 13 | 14 | #Load image for this project 15 | 16 | wget -O - guillep.github.io/files/get/OzVmLatest | bash 17 | wget -O - get.pharo.org/30 | bash 18 | wget http://files.pharo.org/sources/PharoV30.sources 19 | ./oz Pharo.image save PharoCandleBootstrap --delete-old 20 | 21 | 22 | 23 | #Load stable version of the monticello configuration, according to this git sources 24 | REPO=http://smalltalkhub.com/mc/Guille/Seed/main 25 | ./oz PharoCandleBootstrap.image config $REPO ConfigurationOfHazelnut --install=bleedingEdge 26 | 27 | echo "Configuration Loaded. running tests" 28 | 29 | ./oz PharoCandleBootstrap.image test --junit-xml-output "Seed.*" 30 | 31 | echo "Script created and loaded. Finished! :D" -------------------------------------------------------------------------------- /filetree/.properties: -------------------------------------------------------------------------------- 1 | { 2 | #format : #tonel 3 | } -------------------------------------------------------------------------------- /filetree/Kernel-Classes/PCClass.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCClass, 3 | #superclass : #PCBehavior, 4 | #instVars : [ 5 | 'name', 6 | 'instVarNames', 7 | 'classVariables' 8 | ], 9 | #category : 'Kernel-Classes' 10 | } 11 | 12 | { #category : #'as yet unclassified' } 13 | PCClass >> classSide [ 14 | ^ self class 15 | ] 16 | 17 | { #category : #'as yet unclassified' } 18 | PCClass >> classVariables [ 19 | "Answer the dictionary of class variables that I share with my sole instance, or nil if I have none." 20 | 21 | ^ classVariables 22 | ] 23 | 24 | { #category : #'as yet unclassified' } 25 | PCClass >> classVariables: aDictionary [ 26 | "Answer the dictionary of class variables that I share with my sole instance, or nil if I have none." 27 | 28 | ^ classVariables := aDictionary 29 | ] 30 | 31 | { #category : #'as yet unclassified' } 32 | PCClass >> initFrom: aPharoClass methodDict: newMethodDict [ 33 | "Fill in my instance variables from the given Class using the given MethodDictionary." 34 | 35 | superclass := PCObject. "corrected later" 36 | methodDict := newMethodDict. 37 | format := aPharoClass format. 38 | name := (aPharoClass name copyFrom: 2 to: aPharoClass name size) 39 | asSymbol. "omit leading M" 40 | instVarNames := aPharoClass instVarNames. 41 | classVariables := aPharoClass classPool. 42 | instVarNames size = 0 43 | ifTrue: [ instVarNames := nil ]. 44 | classVariables size = 0 45 | ifTrue: [ classVariables := nil ] 46 | ] 47 | 48 | { #category : #'as yet unclassified' } 49 | PCClass >> instVarNames [ 50 | "Answer an Array of the receiver's instance variable names." 51 | 52 | instVarNames ifNil: [ ^ #() ]. 53 | ^ instVarNames 54 | ] 55 | 56 | { #category : #'as yet unclassified' } 57 | PCClass >> instVarNames: anArray [ 58 | instVarNames := anArray 59 | ] 60 | 61 | { #category : #'as yet unclassified' } 62 | PCClass >> isMeta [ 63 | ^ false 64 | ] 65 | 66 | { #category : #'as yet unclassified' } 67 | PCClass >> name [ 68 | ^ name 69 | ] 70 | 71 | { #category : #'as yet unclassified' } 72 | PCClass >> name: aSymbol [ 73 | name := aSymbol 74 | ] 75 | 76 | { #category : #'as yet unclassified' } 77 | PCClass >> newClassBuilderForSubclass: subclassName instanceVariableNames: instVarNames classVariableNames: classVarNames [ 78 | ^ PCClassBuilder new 79 | superclass: self; 80 | name: subclassName; 81 | instVarNames: instVarNames; 82 | classVariableNames: classVarNames; 83 | yourself 84 | ] 85 | 86 | { #category : #'as yet unclassified' } 87 | PCClass >> subclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames [ 88 | ^ (self 89 | newClassBuilderForSubclass: subclassName 90 | instanceVariableNames: someInstVarNames 91 | classVariableNames: classVarNames) build 92 | ] 93 | 94 | { #category : #'as yet unclassified' } 95 | PCClass >> theNonMetaClass [ 96 | ^ self 97 | ] 98 | 99 | { #category : #'as yet unclassified' } 100 | PCClass >> variableByteSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames [ 101 | ^ (self 102 | newClassBuilderForSubclass: subclassName 103 | instanceVariableNames: someInstVarNames 104 | classVariableNames: classVarNames) 105 | beBytes; 106 | build 107 | ] 108 | 109 | { #category : #'as yet unclassified' } 110 | PCClass >> variableSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames [ 111 | ^ (self 112 | newClassBuilderForSubclass: subclassName 113 | instanceVariableNames: someInstVarNames 114 | classVariableNames: classVarNames) 115 | beVariable; 116 | build 117 | ] 118 | 119 | { #category : #'as yet unclassified' } 120 | PCClass >> variableWordSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames [ 121 | ^ (self 122 | newClassBuilderForSubclass: subclassName 123 | instanceVariableNames: someInstVarNames 124 | classVariableNames: classVarNames) 125 | beWords; 126 | build 127 | ] 128 | 129 | { #category : #'as yet unclassified' } 130 | PCClass >> weakSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames [ 131 | ^ (self 132 | newClassBuilderForSubclass: subclassName 133 | instanceVariableNames: someInstVarNames 134 | classVariableNames: classVarNames) 135 | beWeak; 136 | build 137 | ] 138 | -------------------------------------------------------------------------------- /filetree/Kernel-Classes/PCClassBuilder.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCClassBuilder, 3 | #superclass : #PCObject, 4 | #instVars : [ 5 | 'superclass', 6 | 'name', 7 | 'instVarNames', 8 | 'classVariablesNames', 9 | 'formats' 10 | ], 11 | #category : 'Kernel-Classes' 12 | } 13 | 14 | { #category : #'as yet unclassified' } 15 | PCClassBuilder >> beBytes [ 16 | self isCompiledMethodClassIndex 17 | ifTrue: [ ^ self beCompiledMethod ]. 18 | ^ formats := #(#variable #bytes) 19 | ] 20 | 21 | { #category : #'as yet unclassified' } 22 | PCClassBuilder >> beCompiledMethod [ 23 | ^ formats := #(#compiledMethod #variable #bytes) 24 | ] 25 | 26 | { #category : #'as yet unclassified' } 27 | PCClassBuilder >> bePointers [ 28 | ^ formats := #(#pointers) 29 | ] 30 | 31 | { #category : #'as yet unclassified' } 32 | PCClassBuilder >> beVariable [ 33 | ^ formats := #(#variable #pointers) 34 | ] 35 | 36 | { #category : #'as yet unclassified' } 37 | PCClassBuilder >> beWeak [ 38 | ^ formats := #(#weak #variable #pointers) 39 | ] 40 | 41 | { #category : #'as yet unclassified' } 42 | PCClassBuilder >> beWords [ 43 | ^ formats := #(#variable #words) 44 | ] 45 | 46 | { #category : #'as yet unclassified' } 47 | PCClassBuilder >> build [ 48 | | metaclass theClass supermetaclass | 49 | supermetaclass := superclass 50 | ifNil: [ PCClass ] 51 | ifNotNil: [ superclass class ]. 52 | metaclass := PCMetaclass new. 53 | metaclass superclass: supermetaclass. 54 | metaclass setFormat: supermetaclass format. 55 | theClass := metaclass basicNew initialize. 56 | theClass superclass: superclass. 57 | theClass setFormat: self newClassFormat. 58 | theClass instVarNames: instVarNames asArray. 59 | theClass name: name. 60 | theClass classVariables: PCDictionary new. 61 | self classVariableNames 62 | do: [ :varName | theClass classVariables at: varName put: nil ]. 63 | metaclass soleInstance: theClass. 64 | ^ theClass 65 | ] 66 | 67 | { #category : #'as yet unclassified' } 68 | PCClassBuilder >> classVariableNames [ 69 | ^ classVariablesNames 70 | ] 71 | 72 | { #category : #'as yet unclassified' } 73 | PCClassBuilder >> classVariableNames: anArray [ 74 | classVariablesNames := anArray 75 | ] 76 | 77 | { #category : #'as yet unclassified' } 78 | PCClassBuilder >> compactClassIndex [ 79 | ^ self compactClassIndexFor: name 80 | ] 81 | 82 | { #category : #'as yet unclassified' } 83 | PCClassBuilder >> compactClassIndexFor: aClassName [ 84 | ^ #(#PCCompiledMethod nil #PCArray #PCLargeNegativeInteger #PCLargePositiveInteger #PCFloat nil #PCAssociation #PCPoint #PCRectangle #PCString #PCBlock nil #PCMethodContext nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil) 85 | indexOf: aClassName 86 | ifAbsent: [ 0 ] "#PCBitmap" 87 | ] 88 | 89 | { #category : #'as yet unclassified' } 90 | PCClassBuilder >> initialize [ 91 | super initialize. 92 | instVarNames := ''. 93 | classVariablesNames := ''. 94 | superclass := PCObject. 95 | self bePointers 96 | ] 97 | 98 | { #category : #'as yet unclassified' } 99 | PCClassBuilder >> instSize [ 100 | ^ (superclass ifNil: [ 0 ] ifNotNil: [ superclass instSize ]) 101 | + instVarNames size 102 | ] 103 | 104 | { #category : #'as yet unclassified' } 105 | PCClassBuilder >> instVarNames: anArray [ 106 | instVarNames := anArray 107 | ] 108 | 109 | { #category : #'as yet unclassified' } 110 | PCClassBuilder >> isCompiledMethod [ 111 | ^ formats includes: #compiledMethod 112 | ] 113 | 114 | { #category : #'as yet unclassified' } 115 | PCClassBuilder >> isCompiledMethodClassIndex [ 116 | ^ (self compactClassIndexFor: name) 117 | == (self compactClassIndexFor: #PCCompiledMethod) 118 | ] 119 | 120 | { #category : #'as yet unclassified' } 121 | PCClassBuilder >> isPointers [ 122 | ^ formats includes: #pointers 123 | ] 124 | 125 | { #category : #'as yet unclassified' } 126 | PCClassBuilder >> isVariable [ 127 | ^ formats includes: #variable 128 | ] 129 | 130 | { #category : #'as yet unclassified' } 131 | PCClassBuilder >> isWeak [ 132 | ^ formats includes: #weak 133 | ] 134 | 135 | { #category : #'as yet unclassified' } 136 | PCClassBuilder >> isWords [ 137 | ^ formats includes: #words 138 | ] 139 | 140 | { #category : #'as yet unclassified' } 141 | PCClassBuilder >> name: aName [ 142 | name := aName 143 | ] 144 | 145 | { #category : #'as yet unclassified' } 146 | PCClassBuilder >> newClassFormat [ 147 | "<2 bits of size><5 bits of compact class index><4 bits of inst spec><6 bits of size><1 bit with a 0>" 148 | 149 | | size1 instSpec size2 compactClassIndex | 150 | size1 := (self instSize + 1) // 64 bitAnd: 16r3. 151 | instSpec := self isCompiledMethod 152 | ifTrue: [ 12 ] 153 | ifFalse: [ self isWeak 154 | ifTrue: [ 4 ] 155 | ifFalse: [ self isPointers 156 | ifTrue: [ self isVariable 157 | ifTrue: [ self instSize > 0 158 | ifTrue: [ 3 ] 159 | ifFalse: [ 2 ] ] 160 | ifFalse: [ self instSize > 0 161 | ifTrue: [ 1 ] 162 | ifFalse: [ 0 ] ] ] 163 | ifFalse: [ self isWords 164 | ifTrue: [ 6 ] 165 | ifFalse: [ 8 ] ] ] ]. 166 | size2 := (self instSize + 1) \\ 64 bitAnd: 16r3F. 167 | compactClassIndex := self compactClassIndex. 168 | ^ (size1 bitShift: 16) + (compactClassIndex bitShift: 11) 169 | + (instSpec bitShift: 7) + (size2 bitShift: 1) 170 | ] 171 | 172 | { #category : #'as yet unclassified' } 173 | PCClassBuilder >> superclass: aClass [ 174 | superclass := aClass 175 | ] 176 | -------------------------------------------------------------------------------- /filetree/Kernel-Classes/PCMetaclass.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCMetaclass, 3 | #superclass : #PCBehavior, 4 | #instVars : [ 5 | 'soleInstance' 6 | ], 7 | #category : 'Kernel-Classes' 8 | } 9 | 10 | { #category : #'as yet unclassified' } 11 | PCMetaclass >> initMethodDict: newMethodDict [ 12 | "Initialize myself with the given method dictionary. Create but do not initialize my soleInstance." 13 | 14 | superclass := PCClass. 15 | methodDict := newMethodDict. 16 | format := PCClass format. "all metaclasses have the same format as PClass" 17 | soleInstance := self basicNew 18 | ] 19 | 20 | { #category : #'as yet unclassified' } 21 | PCMetaclass >> isMeta [ 22 | ^ true 23 | ] 24 | 25 | { #category : #'as yet unclassified' } 26 | PCMetaclass >> name [ 27 | "Answer my name, either 'Metaclass' or the name of my class followed by ' class'." 28 | 29 | soleInstance 30 | ifNil: [ ^ 'Metaclass' ] 31 | ifNotNil: [ ^ soleInstance name , ' class' ] 32 | ] 33 | 34 | { #category : #'as yet unclassified' } 35 | PCMetaclass >> new [ 36 | "Each metaclass should have exactly one instance." 37 | 38 | self cannotInstantiate 39 | ] 40 | 41 | { #category : #'as yet unclassified' } 42 | PCMetaclass >> soleInstance: aClass [ 43 | soleInstance := aClass 44 | ] 45 | 46 | { #category : #'as yet unclassified' } 47 | PCMetaclass >> theNonMetaClass [ 48 | "Answer my only instance." 49 | 50 | ^ soleInstance 51 | ] 52 | -------------------------------------------------------------------------------- /filetree/Kernel-Classes/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-Classes' } 2 | -------------------------------------------------------------------------------- /filetree/Kernel-Collections-Abstract/PCArrayedCollection.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCArrayedCollection, 3 | #superclass : #PCSequenceableCollection, 4 | #category : 'Kernel-Collections-Abstract' 5 | } 6 | 7 | { #category : #'as yet unclassified' } 8 | PCArrayedCollection class >> new [ 9 | "Answer a new instance of me, with size = 0." 10 | 11 | ^ self new: 0 12 | ] 13 | 14 | { #category : #'as yet unclassified' } 15 | PCArrayedCollection class >> with: anObject [ 16 | "Answer a new instance of me, containing only anObject." 17 | 18 | | newCollection | 19 | newCollection := self new: 1. 20 | newCollection at: 1 put: anObject. 21 | ^ newCollection 22 | ] 23 | 24 | { #category : #'as yet unclassified' } 25 | PCArrayedCollection class >> with: firstObject with: secondObject [ 26 | "Answer a new instance of me containing the two arguments as elements." 27 | 28 | | newCollection | 29 | newCollection := self new: 2. 30 | newCollection at: 1 put: firstObject. 31 | newCollection at: 2 put: secondObject. 32 | ^ newCollection 33 | ] 34 | 35 | { #category : #'as yet unclassified' } 36 | PCArrayedCollection class >> with: firstObject with: secondObject with: thirdObject [ 37 | "Answer a new instance of me, containing the three arguments as elements." 38 | 39 | | newCollection | 40 | newCollection := self new: 3. 41 | newCollection at: 1 put: firstObject. 42 | newCollection at: 2 put: secondObject. 43 | newCollection at: 3 put: thirdObject. 44 | ^ newCollection 45 | ] 46 | 47 | { #category : #'as yet unclassified' } 48 | PCArrayedCollection >> add: newObject [ 49 | self shouldNotImplement 50 | ] 51 | 52 | { #category : #'as yet unclassified' } 53 | PCArrayedCollection >> mergeFirst: first middle: middle last: last into: dst by: aBlock [ 54 | "Private! Merge the sorted ranges [first..middle] and [middle+1..last] of the receiver into the range [first..last] of dst." 55 | 56 | | i1 i2 val1 val2 out | 57 | i1 := first. 58 | i2 := middle + 1. 59 | val1 := self at: i1. 60 | val2 := self at: i2. 61 | out := first - 1. "will be pre-incremented" "select 'lower' half of the elements based on comparator" 62 | [ i1 <= middle and: [ i2 <= last ] ] 63 | whileTrue: [ (aBlock value: val2 value: val1) 64 | ifTrue: [ dst at: (out := out + 1) put: val2. 65 | i2 := i2 + 1. 66 | i2 <= last 67 | ifTrue: [ val2 := self at: i2 ] ] 68 | ifFalse: [ dst at: (out := out + 1) put: val1. 69 | val1 := self at: (i1 := i1 + 1) ] ]. "copy the remaining elements" 70 | i1 <= middle 71 | ifTrue: [ dst 72 | replaceFrom: out + 1 73 | to: last 74 | with: self 75 | startingAt: i1 ] 76 | ifFalse: [ dst 77 | replaceFrom: out + 1 78 | to: last 79 | with: self 80 | startingAt: i2 ] 81 | ] 82 | 83 | { #category : #'as yet unclassified' } 84 | PCArrayedCollection >> mergeSortFrom: startIndex to: stopIndex by: aBlock [ 85 | "Sort the given range of indices using the mergesort algorithm. Mergesort is a worst-case O(N log N) sorting algorithm that usually does only half as many comparisons as heapsort or quicksort." 86 | 87 | "Details: recursively split the range to be sorted into two halves, mergesort each half, then merge the two halves together. An extra copy of the data is used as temporary storage and successive merge phases copy data back and forth between the receiver and this copy. The recursion is set up so that the final merge is performed into the receiver, resulting in the receiver being completely sorted." 88 | 89 | | temp | 90 | self size <= 1 91 | ifTrue: [ ^ self ]. "nothing to do" 92 | startIndex = stopIndex 93 | ifTrue: [ ^ self ]. 94 | (startIndex >= 1 and: [ startIndex < stopIndex ]) 95 | ifFalse: [ self error: 'bad start index' ]. 96 | stopIndex <= self size 97 | ifFalse: [ self error: 'bad stop index' ]. 98 | temp := self basicCopy. 99 | self 100 | mergeSortFrom: startIndex 101 | to: stopIndex 102 | src: temp 103 | dst: self 104 | by: aBlock 105 | ] 106 | 107 | { #category : #'as yet unclassified' } 108 | PCArrayedCollection >> mergeSortFrom: first to: last src: src dst: dst by: aBlock [ 109 | "Private! Split the range to be sorted in half, sort each half, and merge the two half-ranges into dst." 110 | 111 | | middle | 112 | first = last 113 | ifTrue: [ ^ self ]. 114 | middle := (first + last) // 2. 115 | self 116 | mergeSortFrom: first 117 | to: middle 118 | src: dst 119 | dst: src 120 | by: aBlock. 121 | self 122 | mergeSortFrom: middle + 1 123 | to: last 124 | src: dst 125 | dst: src 126 | by: aBlock. 127 | src 128 | mergeFirst: first 129 | middle: middle 130 | last: last 131 | into: dst 132 | by: aBlock 133 | ] 134 | 135 | { #category : #'as yet unclassified' } 136 | PCArrayedCollection >> size [ 137 | "Primitive. Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Primitive is specified here to override MSequenceableCollection size. Essential. See Object documentation whatIsAPrimitive. " 138 | 139 | 140 | ^ self basicSize 141 | ] 142 | 143 | { #category : #'as yet unclassified' } 144 | PCArrayedCollection >> sort [ 145 | "Sort this array into ascending order using the '<' operator." 146 | 147 | self mergeSortFrom: 1 to: self size by: [ :el1 :el2 | el1 < el2 ] 148 | ] 149 | 150 | { #category : #'as yet unclassified' } 151 | PCArrayedCollection >> sort: aBlock [ 152 | "Sort this array using the given comparision block. The block should take two arguments and return true if the first element should precede the second in the sorted result." 153 | 154 | self mergeSortFrom: 1 to: self size by: aBlock 155 | ] 156 | -------------------------------------------------------------------------------- /filetree/Kernel-Collections-Abstract/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-Collections-Abstract' } 2 | -------------------------------------------------------------------------------- /filetree/Kernel-Collections-Ordered/PCArray.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCArray, 3 | #superclass : #PCArrayedCollection, 4 | #category : 'Kernel-Collections-Ordered' 5 | } 6 | 7 | { #category : #'as yet unclassified' } 8 | PCArray >> asArray [ 9 | "Answer with the receiver itself." 10 | 11 | ^ self 12 | ] 13 | 14 | { #category : #'as yet unclassified' } 15 | PCArray >> asDictionary [ 16 | | dictionary | 17 | dictionary := PCDictionary new. 18 | self do: [ :each | dictionary add: each ]. 19 | ^ dictionary 20 | ] 21 | 22 | { #category : #'as yet unclassified' } 23 | PCArray >> elementsExchangeIdentityWith: otherArray [ 24 | "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array." 25 | 26 | 27 | self primitiveFailed 28 | ] 29 | 30 | { #category : #'as yet unclassified' } 31 | PCArray >> hash [ 32 | "Make sure that equal (=) arrays hash equally." 33 | 34 | self size = 0 35 | ifTrue: [ ^ 17171 ]. 36 | ^ (self at: 1) hash + (self at: self size) hash 37 | ] 38 | 39 | { #category : #'as yet unclassified' } 40 | PCArray >> printOn: aStream [ 41 | aStream nextPutAll: '#('. 42 | self 43 | do: [ :each | 44 | each printOn: aStream. 45 | aStream space ]. 46 | aStream nextPut: $) 47 | ] 48 | 49 | { #category : #'as yet unclassified' } 50 | PCArray >> replaceFrom: start to: stop with: replacement startingAt: repStart [ 51 | "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." 52 | 53 | 54 | super 55 | replaceFrom: start 56 | to: stop 57 | with: replacement 58 | startingAt: repStart 59 | ] 60 | -------------------------------------------------------------------------------- /filetree/Kernel-Collections-Ordered/PCByteArray.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCByteArray, 3 | #superclass : #PCArrayedCollection, 4 | #type : #bytes, 5 | #category : 'Kernel-Collections-Ordered' 6 | } 7 | 8 | { #category : #'as yet unclassified' } 9 | PCByteArray >> asByteArray [ 10 | ^ self 11 | ] 12 | 13 | { #category : #'as yet unclassified' } 14 | PCByteArray >> asString [ 15 | "Answer the receiver converted to a String." 16 | 17 | ^ (PCString new: self size) 18 | replaceFrom: 1 19 | to: self size 20 | with: self 21 | startingAt: 1 22 | ] 23 | 24 | { #category : #'as yet unclassified' } 25 | PCByteArray >> replaceFrom: startIndex to: stopIndex with: source startingAt: srcStartIndex [ 26 | "Primitive. Destructively replace the elements from startIndex to stopIndex in the receiver with the elements starting at srcStartIndex in the source collection. Answer the receiver. Range checks are performed in the primitive. Optional. See Object documentation whatIsAPrimitive." 27 | 28 | 29 | super 30 | replaceFrom: startIndex 31 | to: stopIndex 32 | with: source 33 | startingAt: srcStartIndex 34 | ] 35 | -------------------------------------------------------------------------------- /filetree/Kernel-Collections-Ordered/PCInterval.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCInterval, 3 | #superclass : #PCSequenceableCollection, 4 | #instVars : [ 5 | 'start', 6 | 'stop', 7 | 'step' 8 | ], 9 | #category : 'Kernel-Collections-Ordered' 10 | } 11 | 12 | { #category : #'as yet unclassified' } 13 | PCInterval class >> from: startInteger to: stopInteger [ 14 | "Answer an instance of me, starting at startNumber, ending at stopNumber, and with an interval increment of 1." 15 | 16 | ^ self basicNew setFrom: startInteger to: stopInteger by: 1 17 | ] 18 | 19 | { #category : #'as yet unclassified' } 20 | PCInterval class >> from: startInteger to: stopInteger by: stepInteger [ 21 | "Answer an instance of me, starting at startNumber, ending at stopNumber, and with an interval increment of stepNumber." 22 | 23 | ^ self basicNew setFrom: startInteger to: stopInteger by: stepInteger 24 | ] 25 | 26 | { #category : #'as yet unclassified' } 27 | PCInterval >> = anInterval [ 28 | "Answer true if my species and anInterval species are equal, and 29 | if our starts, steps and sizes are equal." 30 | 31 | self species == anInterval species 32 | ifTrue: [ ^ start = anInterval first 33 | and: [ step = anInterval increment and: [ self size = anInterval size ] ] ] 34 | ifFalse: [ ^ false ] 35 | ] 36 | 37 | { #category : #'as yet unclassified' } 38 | PCInterval >> add: newObject [ 39 | "Adding to an Interval is not allowed." 40 | 41 | self shouldNotImplement 42 | ] 43 | 44 | { #category : #'as yet unclassified' } 45 | PCInterval >> at: anInteger [ 46 | "Answer the anInteger'th element." 47 | 48 | (anInteger >= 1 and: [ anInteger <= self size ]) 49 | ifTrue: [ ^ start + (step * (anInteger - 1)) ] 50 | ifFalse: [ self errorSubscriptBounds: anInteger ] 51 | ] 52 | 53 | { #category : #'as yet unclassified' } 54 | PCInterval >> at: anInteger put: anObject [ 55 | "Storing into an Interval is not allowed." 56 | 57 | self error: 'you can not store into an interval' 58 | ] 59 | 60 | { #category : #'as yet unclassified' } 61 | PCInterval >> collect: aBlock [ 62 | | nextValue result | 63 | result := self species new: self size. 64 | nextValue := start. 65 | 1 to: result size do: [ :i | 66 | result at: i put: (aBlock value: nextValue). 67 | nextValue := nextValue + step ]. 68 | ^ result 69 | ] 70 | 71 | { #category : #'as yet unclassified' } 72 | PCInterval >> do: aBlock [ 73 | | aValue | 74 | aValue := start. 75 | step < 0 76 | ifTrue: [ [ stop <= aValue ] 77 | whileTrue: [ aBlock value: aValue. 78 | aValue := aValue + step ] ] 79 | ifFalse: [ [ stop >= aValue ] 80 | whileTrue: [ aBlock value: aValue. 81 | aValue := aValue + step ] ] 82 | ] 83 | 84 | { #category : #'as yet unclassified' } 85 | PCInterval >> first [ 86 | "Refer to the comment in SequenceableCollection|first." 87 | 88 | ^ start 89 | ] 90 | 91 | { #category : #'as yet unclassified' } 92 | PCInterval >> hash [ 93 | "Hash is reimplemented because = is implemented." 94 | 95 | ^ (((start hash bitShift: 2) bitOr: stop hash) bitShift: 1) 96 | bitOr: self size 97 | ] 98 | 99 | { #category : #'as yet unclassified' } 100 | PCInterval >> includes: aNumber [ 101 | ^ aNumber between: self first and: self last 102 | ] 103 | 104 | { #category : #'as yet unclassified' } 105 | PCInterval >> increment [ 106 | "Answer the receiver's interval increment." 107 | 108 | ^ step 109 | ] 110 | 111 | { #category : #'as yet unclassified' } 112 | PCInterval >> last [ 113 | "Refer to the comment in SequenceableCollection|last." 114 | 115 | ^ stop - ((stop - start) \\ step) 116 | ] 117 | 118 | { #category : #'as yet unclassified' } 119 | PCInterval >> printOn: aStream [ 120 | aStream nextPut: $(. 121 | start printOn: aStream. 122 | aStream nextPutAll: ' to: '. 123 | stop printOn: aStream. 124 | step ~= 1 125 | ifTrue: [ aStream nextPutAll: ' by: '. 126 | step printOn: aStream ]. 127 | aStream nextPut: $) 128 | ] 129 | 130 | { #category : #'as yet unclassified' } 131 | PCInterval >> remove: newObject [ 132 | "Removing from an Interval is not allowed." 133 | 134 | self error: 'elements cannot be removed from an Interval' 135 | ] 136 | 137 | { #category : #'as yet unclassified' } 138 | PCInterval >> setFrom: startInteger to: stopInteger by: stepInteger [ 139 | start := startInteger. 140 | stop := stopInteger. 141 | step := stepInteger 142 | ] 143 | 144 | { #category : #'as yet unclassified' } 145 | PCInterval >> size [ 146 | step < 0 147 | ifTrue: [ start < stop 148 | ifTrue: [ ^ 0 ] 149 | ifFalse: [ ^ (stop - start) // step + 1 ] ] 150 | ifFalse: [ stop < start 151 | ifTrue: [ ^ 0 ] 152 | ifFalse: [ ^ (stop - start) // step + 1 ] ] 153 | ] 154 | 155 | { #category : #'as yet unclassified' } 156 | PCInterval >> species [ 157 | ^ PCArray 158 | ] 159 | -------------------------------------------------------------------------------- /filetree/Kernel-Collections-Ordered/PCSymbol.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCSymbol, 3 | #superclass : #PCString, 4 | #type : #bytes, 5 | #category : 'Kernel-Collections-Ordered' 6 | } 7 | 8 | { #category : #'as yet unclassified' } 9 | PCSymbol class >> new: size [ 10 | "Symbols are unique. You can create a new Symbol from a String using 'asSymbol'." 11 | 12 | self cannotInstantiate 13 | ] 14 | 15 | { #category : #'as yet unclassified' } 16 | PCSymbol >> = anObject [ 17 | ^ self == anObject 18 | ] 19 | 20 | { #category : #'as yet unclassified' } 21 | PCSymbol >> asString [ 22 | "Answer a string containing my characters." 23 | 24 | | sz result | 25 | sz := self size. 26 | result := PCString new: sz. 27 | result 28 | replaceFrom: 1 29 | to: sz 30 | with: self 31 | startingAt: 1. 32 | ^ result 33 | ] 34 | 35 | { #category : #'as yet unclassified' } 36 | PCSymbol >> asSymbol [ 37 | ^ self 38 | ] 39 | 40 | { #category : #'as yet unclassified' } 41 | PCSymbol >> at: anInteger put: anObject [ 42 | "You cannot modify the receiver." 43 | 44 | self errorNoModification 45 | ] 46 | 47 | { #category : #'as yet unclassified' } 48 | PCSymbol >> basicCopy [ 49 | "Answer myself because Symbols are unique." 50 | 51 | 52 | ] 53 | 54 | { #category : #'as yet unclassified' } 55 | PCSymbol >> errorNoModification [ 56 | self error: 'Symbols can not be modified.' 57 | ] 58 | 59 | { #category : #'as yet unclassified' } 60 | PCSymbol >> hash [ 61 | ^ self identityHash 62 | ] 63 | 64 | { #category : #'as yet unclassified' } 65 | PCSymbol >> initFrom: aString [ 66 | "Warning! Use only to initialize new Symbols. Symbols are assumed to be immutable there after." 67 | 68 | self size = aString size 69 | ifFalse: [ self error: 'size mismatch' ]. 70 | super 71 | replaceFrom: 1 72 | to: self size 73 | with: aString 74 | startingAt: 1 75 | ] 76 | 77 | { #category : #'as yet unclassified' } 78 | PCSymbol >> printOn: aStream [ 79 | aStream nextPutAll: self 80 | ] 81 | 82 | { #category : #'as yet unclassified' } 83 | PCSymbol >> replaceFrom: start to: stop with: replacement startingAt: repStart [ 84 | self errorNoModification 85 | ] 86 | 87 | { #category : #'as yet unclassified' } 88 | PCSymbol >> species [ 89 | ^ PCString 90 | ] 91 | -------------------------------------------------------------------------------- /filetree/Kernel-Collections-Ordered/PCValueLink.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCValueLink, 3 | #superclass : #PCObject, 4 | #instVars : [ 5 | 'nextLink', 6 | 'value' 7 | ], 8 | #category : 'Kernel-Collections-Ordered' 9 | } 10 | 11 | { #category : #'as yet unclassified' } 12 | PCValueLink class >> value: aValue [ 13 | ^ self new value: aValue 14 | ] 15 | 16 | { #category : #'as yet unclassified' } 17 | PCValueLink >> = anotherObject [ 18 | ^ self species == anotherObject species 19 | and: [ self value = anotherObject value 20 | and: [ self nextLink == anotherObject nextLink ] ] 21 | ] 22 | 23 | { #category : #'as yet unclassified' } 24 | PCValueLink >> asLink [ 25 | ^ self 26 | ] 27 | 28 | { #category : #'as yet unclassified' } 29 | PCValueLink >> hash [ 30 | ^ self value hash bitXor: nextLink identityHash 31 | ] 32 | 33 | { #category : #'as yet unclassified' } 34 | PCValueLink >> nextLink [ 35 | ^ nextLink 36 | ] 37 | 38 | { #category : #'as yet unclassified' } 39 | PCValueLink >> nextLink: aLink [ 40 | nextLink := aLink 41 | ] 42 | 43 | { #category : #'as yet unclassified' } 44 | PCValueLink >> printOn: aStream [ 45 | aStream nextPutAll: 'ValueLink('. 46 | value printOn: aStream. 47 | aStream nextPut: $) 48 | ] 49 | 50 | { #category : #'as yet unclassified' } 51 | PCValueLink >> value [ 52 | ^ value 53 | ] 54 | 55 | { #category : #'as yet unclassified' } 56 | PCValueLink >> value: aValue [ 57 | value := aValue 58 | ] 59 | -------------------------------------------------------------------------------- /filetree/Kernel-Collections-Ordered/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-Collections-Ordered' } 2 | -------------------------------------------------------------------------------- /filetree/Kernel-Collections-Unordered/PCAssociation.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCAssociation, 3 | #superclass : #PCMagnitude, 4 | #instVars : [ 5 | 'key', 6 | 'value' 7 | ], 8 | #category : 'Kernel-Collections-Unordered' 9 | } 10 | 11 | { #category : #'as yet unclassified' } 12 | PCAssociation class >> key: newKey value: newValue [ 13 | "Answer a new Association with the given key and value." 14 | 15 | ^ self new key: newKey value: newValue 16 | ] 17 | 18 | { #category : #'as yet unclassified' } 19 | PCAssociation >> < aLookupKey [ 20 | "Sort by keys." 21 | 22 | ^ key < aLookupKey key 23 | ] 24 | 25 | { #category : #'as yet unclassified' } 26 | PCAssociation >> = anAssociation [ 27 | "True if the receiver and argument have equal keys." 28 | 29 | self species = anAssociation species 30 | ifTrue: [ ^ key = anAssociation key ] 31 | ifFalse: [ ^ false ] 32 | ] 33 | 34 | { #category : #'as yet unclassified' } 35 | PCAssociation >> hash [ 36 | "Hash is reimplemented because = is implemented." 37 | 38 | ^ key hash 39 | ] 40 | 41 | { #category : #'as yet unclassified' } 42 | PCAssociation >> key [ 43 | ^ key 44 | ] 45 | 46 | { #category : #'as yet unclassified' } 47 | PCAssociation >> key: anObject [ 48 | key := anObject 49 | ] 50 | 51 | { #category : #'as yet unclassified' } 52 | PCAssociation >> key: aKey value: anObject [ 53 | key := aKey. 54 | value := anObject 55 | ] 56 | 57 | { #category : #'as yet unclassified' } 58 | PCAssociation >> printOn: aStream [ 59 | "Print in the format (key->value)." 60 | 61 | aStream nextPut: $(. 62 | key printOn: aStream. 63 | aStream nextPutAll: '->'. 64 | value printOn: aStream. 65 | aStream nextPut: $) 66 | ] 67 | 68 | { #category : #'as yet unclassified' } 69 | PCAssociation >> value [ 70 | ^ value 71 | ] 72 | 73 | { #category : #'as yet unclassified' } 74 | PCAssociation >> value: anObject [ 75 | value := anObject 76 | ] 77 | -------------------------------------------------------------------------------- /filetree/Kernel-Collections-Unordered/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-Collections-Unordered' } 2 | -------------------------------------------------------------------------------- /filetree/Kernel-Methods/PCBlock.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCBlock, 3 | #superclass : #PCObject, 4 | #instVars : [ 5 | 'outerContext', 6 | 'startpc', 7 | 'nargs' 8 | ], 9 | #category : 'Kernel-Methods' 10 | } 11 | 12 | { #category : #'as yet unclassified' } 13 | PCBlock >> asContext [ 14 | "Create a MethodContext that is ready to execute self. Assumes self takes no args (if it does the args will be nil)" 15 | 16 | ^ self asContextWithSender: nil 17 | ] 18 | 19 | { #category : #'as yet unclassified' } 20 | PCBlock >> asContextWithSender: aContext [ 21 | "Inner private support method for evaluation. Do not use unless you know what you're doing." 22 | 23 | ^ (PCMethodContext newForMethod: outerContext method) 24 | setSender: aContext 25 | receiver: outerContext receiver 26 | method: outerContext method 27 | closure: self 28 | startpc: startpc; 29 | privRefresh 30 | ] 31 | 32 | { #category : #'as yet unclassified' } 33 | PCBlock >> home [ 34 | ^ outerContext home 35 | ] 36 | 37 | { #category : #'as yet unclassified' } 38 | PCBlock >> ifError: errorHandlerBlock [ 39 | "Evaluate the block represented by the receiver. If an error occurs the given handler block is evaluated. The handler block can be either a zero- or two-argument block; if the latter, then the error message and receiver are supplied to it as parameters. Answer the value returned by the handler block if the receiver gets an error." 40 | 41 | "Warning: The receiver should not contain an explicit return since that would leave an obsolete error handler hanging around." 42 | 43 | "Examples: 44 | [1 whatsUpDoc] ifError: [:err :rcvr | ^ 'huh?']. 45 | [1 whatsUpDoc] ifError: ['huh']. 46 | [1 / 0] ifError: [:err :rcvr | 47 | 'division by 0' = err 48 | ifTrue: [^ Float infinity] 49 | ifFalse: [self error: err]] 50 | " 51 | 52 | | activeProcess lastHandler val | 53 | activeProcess := Processor activeProcess. 54 | lastHandler := activeProcess errorHandler. 55 | activeProcess 56 | errorHandler: [ :aString :aReceiver | 57 | activeProcess errorHandler: lastHandler. 58 | errorHandlerBlock numArgs = 0 59 | ifTrue: [ ^ errorHandlerBlock value ]. 60 | ^ errorHandlerBlock value: aString value: aReceiver ]. 61 | val := self value. 62 | activeProcess errorHandler: lastHandler. 63 | ^ val 64 | ] 65 | 66 | { #category : #'as yet unclassified' } 67 | PCBlock >> method [ 68 | ^ self home method 69 | ] 70 | 71 | { #category : #'as yet unclassified' } 72 | PCBlock >> msecs [ 73 | "Answer the number of milliseconds it took to evaluate this block." 74 | 75 | | startMSecs | 76 | startMSecs := PCSystem milliseconds. 77 | self value. 78 | ^ PCSystem milliseconds - startMSecs 79 | ] 80 | 81 | { #category : #'as yet unclassified' } 82 | PCBlock >> numArgs [ 83 | ^ nargs 84 | ] 85 | 86 | { #category : #'as yet unclassified' } 87 | PCBlock >> numCopiedValues [ 88 | "Answer the number of copied values of the receiver. Since these are 89 | stored in the receiver's indexable fields this is the receiver's basic size. 90 | Primitive. Answer the number of indexable variables in the receiver. 91 | This value is the same as the largest legal subscript." 92 | 93 | 94 | ^ self basicSize 95 | ] 96 | 97 | { #category : #'as yet unclassified' } 98 | PCBlock >> outerContext [ 99 | ^ outerContext 100 | ] 101 | 102 | { #category : #'as yet unclassified' } 103 | PCBlock >> value [ 104 | "Evaluate this block without any arguments." 105 | 106 | 107 | ^ self valueWithArguments: #() 108 | ] 109 | 110 | { #category : #'as yet unclassified' } 111 | PCBlock >> value: arg [ 112 | "Evaluate this block with one argument." 113 | 114 | 115 | ^ self valueWithArguments: (PCArray with: arg) 116 | ] 117 | 118 | { #category : #'as yet unclassified' } 119 | PCBlock >> value: arg1 value: arg2 [ 120 | "Evaluate this block with two arguments." 121 | 122 | 123 | ^ self valueWithArguments: (PCArray with: arg1 with: arg2) 124 | ] 125 | 126 | { #category : #'as yet unclassified' } 127 | PCBlock >> valueWithArguments: anArray [ 128 | "Primitive. Evaluate the block represented by the receiver. The argument is an Array whose elements are the arguments for the block. Fail if the length of the Array is not the same as the the number of arguments that the block was expecting. Fail if the block is already being executed. Essential. See Object documentation whatIsAPrimitive." 129 | 130 | 131 | anArray size = nargs 132 | ifTrue: [ self 133 | error: 'Attempt to evaluate a block that is already being evaluated.' ] 134 | ifFalse: [ self 135 | error: 'This block requires ' , nargs printString , ' arguments.' ] 136 | ] 137 | -------------------------------------------------------------------------------- /filetree/Kernel-Methods/PCCompiledMethod.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCCompiledMethod, 3 | #superclass : #PCByteArray, 4 | #type : #bytes, 5 | #category : 'Kernel-Methods' 6 | } 7 | 8 | { #category : #'as yet unclassified' } 9 | PCCompiledMethod >> frameSize [ 10 | "Answer the size of temporary frame needed to run the receiver." 11 | 12 | "NOTE: Versions 2.7 and later use two sizes of contexts." 13 | 14 | (self header bitAnd: 16r20000) = 0 15 | ifTrue: [ ^ 16 ] 16 | ifFalse: [ ^ 56 ] 17 | ] 18 | 19 | { #category : #'as yet unclassified' } 20 | PCCompiledMethod >> header [ 21 | "Answer the method header word containing information about the form of this method (e.g., number of literals) and the context needed to run it." 22 | 23 | ^ self objectAt: 1 24 | ] 25 | 26 | { #category : #'as yet unclassified' } 27 | PCCompiledMethod >> initialPC [ 28 | "Answer the program counter for my first bytecode." 29 | 30 | ^ 4 * (self numLiterals + 1) + 1 31 | ] 32 | 33 | { #category : #'as yet unclassified' } 34 | PCCompiledMethod >> isCompiledMethod [ 35 | ^ true 36 | ] 37 | 38 | { #category : #'as yet unclassified' } 39 | PCCompiledMethod >> numLiterals [ 40 | "Answer the number of literals used by the receiver." 41 | 42 | ^ (self header bitShift: -9) bitAnd: 16rFF 43 | ] 44 | 45 | { #category : #'as yet unclassified' } 46 | PCCompiledMethod >> numTemps [ 47 | "Answer the number of temporary variables used by this method." 48 | 49 | ^ (self header bitShift: -18) bitAnd: 16r3F 50 | ] 51 | 52 | { #category : #'as yet unclassified' } 53 | PCCompiledMethod >> objectAt: index [ 54 | "Primitive. Answer the method header (if index = 1) or a literal (if index > 1) from the receiver. Essential. See Object documentation whatIsAPrimitive." 55 | 56 | 57 | self primitiveFailed 58 | ] 59 | 60 | { #category : #'as yet unclassified' } 61 | PCCompiledMethod >> objectAt: index put: value [ 62 | "Primitive. Store the value argument into a literal in the receiver. An index of 2 corresponds to the first literal. Fails if the index is less than 2 or greater than the number of literals. Answer the value as the result. Normally only the compiler sends this message because only the compiler stores values in CompiledMethods. Essential. See Object documentation whatIsAPrimitive." 63 | 64 | 65 | self primitiveFailed 66 | ] 67 | -------------------------------------------------------------------------------- /filetree/Kernel-Methods/PCContext.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCContext, 3 | #superclass : #PCObject, 4 | #instVars : [ 5 | 'sender', 6 | 'pc', 7 | 'stackp' 8 | ], 9 | #category : 'Kernel-Methods' 10 | } 11 | 12 | { #category : #'as yet unclassified' } 13 | PCContext class >> newForMethod: aMethod [ 14 | "This is the only method for creating new contexts, other than by using the clone primitive. Any other attempts, such as inherited methods like shallowCopy, should be avoided or must at least be rewritten to determine the proper size for the method that will use this context. This is because asking a context its size (even basicSize!) will not return the actual object size but only the number of fields currently accessible, as determined by stackp." 15 | 16 | ^ super basicNew: aMethod frameSize 17 | ] 18 | 19 | { #category : #'as yet unclassified' } 20 | PCContext >> blockCopy: numArgs [ 21 | "Primitive. Distinguish a block of code from its enclosing method by creating a new BlockContext for that block. The compiler inserts into all methods that contain blocks the bytecodes to send the message blockCopy:. Do not use blockCopy: in code that you write! Only the compiler can decide to send the message blockCopy:. Fail if numArgs is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." 22 | 23 | 24 | ^ (PCBlock newForMethod: self home method) 25 | home: self home 26 | startpc: pc + 2 27 | nargs: numArgs 28 | ] 29 | 30 | { #category : #'as yet unclassified' } 31 | PCContext >> isContextPart [ 32 | ^ true 33 | ] 34 | 35 | { #category : #'as yet unclassified' } 36 | PCContext >> sender [ 37 | "Answer the context that sent the message that created the receiver." 38 | 39 | ^ sender 40 | ] 41 | -------------------------------------------------------------------------------- /filetree/Kernel-Methods/PCMessage.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCMessage, 3 | #superclass : #PCObject, 4 | #instVars : [ 5 | 'selector', 6 | 'arguments', 7 | 'lookupClass' 8 | ], 9 | #category : 'Kernel-Methods' 10 | } 11 | 12 | { #category : #'as yet unclassified' } 13 | PCMessage >> arguments [ 14 | "Answer the message arguments array." 15 | 16 | ^ arguments 17 | ] 18 | 19 | { #category : #'as yet unclassified' } 20 | PCMessage >> lookupClass [ 21 | "Answer the message lookupClass." 22 | 23 | ^ lookupClass 24 | ] 25 | 26 | { #category : #'as yet unclassified' } 27 | PCMessage >> printOn: aStream [ 28 | "Refer to the comment in Object|printOn:." 29 | 30 | super printOn: aStream. 31 | aStream 32 | nextPutAll: ' selector: ' , selector printString; 33 | nextPutAll: ' args: ' , arguments printString 34 | ] 35 | 36 | { #category : #'as yet unclassified' } 37 | PCMessage >> selector [ 38 | "Answer the message selector." 39 | 40 | ^ selector 41 | ] 42 | 43 | { #category : #'as yet unclassified' } 44 | PCMessage >> sentTo: anObject [ 45 | "Answer the result of sending this message to the given object." 46 | 47 | lookupClass == nil 48 | ifTrue: [ ^ anObject perform: selector withArguments: arguments ] 49 | ifFalse: [ ^ anObject 50 | perform: selector 51 | withArguments: arguments 52 | inSuperclass: lookupClass ] 53 | ] 54 | -------------------------------------------------------------------------------- /filetree/Kernel-Methods/PCMethodContext.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCMethodContext, 3 | #superclass : #PCContext, 4 | #instVars : [ 5 | 'method', 6 | 'closureOrNil', 7 | 'receiver' 8 | ], 9 | #category : 'Kernel-Methods' 10 | } 11 | 12 | { #category : #'as yet unclassified' } 13 | PCMethodContext >> asContext [ 14 | ^ self 15 | ] 16 | 17 | { #category : #'as yet unclassified' } 18 | PCMethodContext >> home [ 19 | "Answer the context in which the receiver was defined." 20 | 21 | closureOrNil == nil 22 | ifTrue: [ ^ self ]. 23 | ^ closureOrNil outerContext home 24 | ] 25 | 26 | { #category : #'as yet unclassified' } 27 | PCMethodContext >> method [ 28 | ^ method 29 | ] 30 | 31 | { #category : #'as yet unclassified' } 32 | PCMethodContext >> privRefresh [ 33 | "Reinitialize the receiver so that it is in the state it was at its creation." 34 | 35 | closureOrNil 36 | ifNotNil: [ pc := closureOrNil startpc. 37 | self stackp: closureOrNil numArgs + closureOrNil numCopiedValues. 38 | 1 to: closureOrNil numCopiedValues do: 39 | [ :i | self tempAt: closureOrNil numArgs + i put: (closureOrNil at: i) ] ] 40 | ifNil: [ pc := method initialPC. 41 | self stackp: method numTemps. 42 | method numArgs + 1 to: method numTemps do: [ :i | self tempAt: i put: nil ] ] 43 | ] 44 | 45 | { #category : #'as yet unclassified' } 46 | PCMethodContext >> removeSelf [ 47 | "Nil the receiver pointer and answer its former value." 48 | 49 | | result | 50 | result := receiver. 51 | receiver := nil. 52 | ^ result 53 | ] 54 | 55 | { #category : #'as yet unclassified' } 56 | PCMethodContext >> setSender: s receiver: r method: m closure: c startpc: startpc [ 57 | "Create the receiver's initial state." 58 | 59 | sender := s. 60 | receiver := r. 61 | method := m. 62 | closureOrNil := c. 63 | pc := startpc. 64 | stackp := 0 65 | ] 66 | 67 | { #category : #'as yet unclassified' } 68 | PCMethodContext >> stackp: newStackp [ 69 | "Storing into the stack pointer is a potentially dangerous thing. 70 | This primitive stores nil into any cells that become accessible as a result, 71 | and it performs the entire operation atomically." 72 | 73 | "Once this primitive is implemented, failure code should cause an error" 74 | 75 | 76 | self error: 'stackp store failure' 77 | ] 78 | 79 | { #category : #'as yet unclassified' } 80 | PCMethodContext >> tempAt: index put: value [ 81 | "Store the argument, value, as the temporary variable whose index is the 82 | argument, index. Primitive. Assumes receiver is indexable. Answer the 83 | value of an indexable element in the receiver. Fail if the argument index 84 | is not an Integer or is out of bounds. Essential. See Object documentation 85 | whatIsAPrimitive. Override the default at:put: primitive to give latitude to 86 | the VM in context management." 87 | 88 | 89 | 90 | ] 91 | -------------------------------------------------------------------------------- /filetree/Kernel-Methods/PCMethodDictionary.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCMethodDictionary, 3 | #superclass : #PCDictionary, 4 | #category : 'Kernel-Methods' 5 | } 6 | 7 | { #category : #'as yet unclassified' } 8 | PCMethodDictionary class >> new: nElements [ 9 | "Create a Dictionary large enough to hold nElements without growing." 10 | 11 | "NOTE: The basic size MUST be a power of 2. It is VITAL (see grow) that size gets doubled if nElements is a power of 2." 12 | 13 | | size | 14 | size := 1 bitShift: nElements highBit. 15 | ^ (self basicNew: size) init: size 16 | ] 17 | 18 | { #category : #'as yet unclassified' } 19 | PCMethodDictionary >> add: anAssociation [ 20 | ^ self at: anAssociation key put: anAssociation value 21 | ] 22 | 23 | { #category : #'as yet unclassified' } 24 | PCMethodDictionary >> associationsDo: aBlock [ 25 | | key | 26 | tally = 0 27 | ifTrue: [ ^ self ]. 28 | 1 to: self basicSize do: [ :i | 29 | (key := self basicAt: i) 30 | ifNotNil: [ aBlock value: key -> (array at: i) ] ] 31 | ] 32 | 33 | { #category : #'as yet unclassified' } 34 | PCMethodDictionary >> at: key ifAbsent: aBlock [ 35 | | index | 36 | index := self findElementOrNil: key. 37 | (self basicAt: index) == nil 38 | ifTrue: [ ^ aBlock value ]. 39 | ^ array at: index 40 | ] 41 | 42 | { #category : #'as yet unclassified' } 43 | PCMethodDictionary >> at: key put: value [ 44 | "Set the value at key to be value." 45 | 46 | | index | 47 | index := self findElementOrNil: key. 48 | (self basicAt: index) == nil 49 | ifTrue: [ tally := tally + 1. 50 | self basicAt: index put: key ]. 51 | array at: index put: value. 52 | self fullCheck. 53 | ^ value 54 | ] 55 | 56 | { #category : #'as yet unclassified' } 57 | PCMethodDictionary >> copy [ 58 | "Copy my values array." 59 | 60 | ^ self basicCopy withArray: array basicCopy 61 | ] 62 | 63 | { #category : #'as yet unclassified' } 64 | PCMethodDictionary >> do: aBlock [ 65 | tally = 0 66 | ifTrue: [ ^ self ]. 67 | 1 to: self basicSize do: [ :i | (self basicAt: i) ifNotNil: [ aBlock value: (array at: i) ] ] 68 | ] 69 | 70 | { #category : #'as yet unclassified' } 71 | PCMethodDictionary >> grow [ 72 | | newSelf key | 73 | newSelf := self species new: self basicSize. "This will double the size" 74 | 1 to: self basicSize do: [ :i | 75 | key := self basicAt: i. 76 | key == nil 77 | ifFalse: [ newSelf at: key put: (array at: i) ] ]. 78 | self become: newSelf 79 | ] 80 | 81 | { #category : #'as yet unclassified' } 82 | PCMethodDictionary >> includesKey: aSymbol [ 83 | "This override assumes that pointsTo is a fast primitive." 84 | 85 | ^ super pointsTo: aSymbol 86 | ] 87 | 88 | { #category : #'as yet unclassified' } 89 | PCMethodDictionary >> keyAt: index [ 90 | ^ self basicAt: index 91 | ] 92 | 93 | { #category : #'as yet unclassified' } 94 | PCMethodDictionary >> keyAtIdentityValue: value ifAbsent: exceptionBlock [ 95 | "Answer the key whose value equals the argument, value. If there is none, answer the result of evaluating exceptionBlock." 96 | 97 | | k | 98 | 1 to: self basicSize do: [ :i | 99 | value == (array at: i) 100 | ifTrue: [ (k := self basicAt: i) ifNotNil: [ ^ k ] ] ]. 101 | ^ exceptionBlock value 102 | ] 103 | 104 | { #category : #'as yet unclassified' } 105 | PCMethodDictionary >> keysDo: aBlock [ 106 | | key | 107 | tally = 0 108 | ifTrue: [ ^ self ]. 109 | 1 to: self basicSize do: [ :i | (key := self basicAt: i) ifNotNil: [ aBlock value: key ] ] 110 | ] 111 | 112 | { #category : #'as yet unclassified' } 113 | PCMethodDictionary >> removeKey: key ifAbsent: errorBlock [ 114 | "Pharo Candle does not support method removal." 115 | 116 | self shouldNotImplement 117 | ] 118 | 119 | { #category : #'as yet unclassified' } 120 | PCMethodDictionary >> scanFor: anObject [ 121 | "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 122 | 123 | | element start finish | 124 | start := anObject basicIdentityHash \\ array size + 1. 125 | finish := array size. "Search from (hash mod size) to the end." 126 | start to: finish do: [ :index | 127 | ((element := self basicAt: index) == nil or: [ element == anObject ]) 128 | ifTrue: [ ^ index ] ]. "Search from 1 to where we started." 129 | 1 to: start - 1 do: [ :index | 130 | ((element := self basicAt: index) == nil or: [ element == anObject ]) 131 | ifTrue: [ ^ index ] ]. 132 | ^ 0 "No match AND no empty slot" 133 | ] 134 | 135 | { #category : #'as yet unclassified' } 136 | PCMethodDictionary >> swap: oneIndex with: otherIndex [ 137 | | element | 138 | element := self basicAt: oneIndex. 139 | self basicAt: oneIndex put: (self basicAt: otherIndex). 140 | self basicAt: otherIndex put: element. 141 | super swap: oneIndex with: otherIndex 142 | ] 143 | -------------------------------------------------------------------------------- /filetree/Kernel-Methods/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-Methods' } 2 | -------------------------------------------------------------------------------- /filetree/Kernel-Numeric/PCLargeNegativeInteger.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCLargeNegativeInteger, 3 | #superclass : #PCLargePositiveInteger, 4 | #type : #bytes, 5 | #category : 'Kernel-Numeric' 6 | } 7 | 8 | { #category : #'as yet unclassified' } 9 | PCLargeNegativeInteger >> abs [ 10 | ^ self negated 11 | ] 12 | 13 | { #category : #'as yet unclassified' } 14 | PCLargeNegativeInteger >> negated [ 15 | ^ self copyto: (PCLargePositiveInteger new: self digitLength) 16 | ] 17 | 18 | { #category : #'as yet unclassified' } 19 | PCLargeNegativeInteger >> negative [ 20 | "Answer whether the receiver is mathematically negative." 21 | 22 | ^ true 23 | ] 24 | 25 | { #category : #'as yet unclassified' } 26 | PCLargeNegativeInteger >> normalize [ 27 | "Check for leading zeroes and return shortened copy if so" 28 | 29 | | sLen val len oldLen minVal | 30 | "First establish len = significant length" 31 | len := oldLen := self digitLength. 32 | [ len = 0 33 | ifTrue: [ ^ 0 ]. 34 | (self digitAt: len) = 0 ] whileTrue: [ len := len - 1 ]. "Now check if in SmallInteger range" 35 | sLen := 4. "SmallInteger minVal digitLength" 36 | len <= sLen 37 | ifTrue: [ minVal := PCSmallInteger minVal. 38 | (len < sLen or: [ (self digitAt: sLen) < minVal lastDigit ]) 39 | ifTrue: [ val := 0. 40 | len to: 1 by: -1 do: [ :i | val := val * 256 - (self digitAt: i) ]. 41 | ^ val ]. 42 | "If high digit less, then can be small" 43 | 1 to: sLen do: [ :i"If all digits same, then = minVal" 44 | | 45 | (self digitAt: i) = (minVal digitAt: i) 46 | ifFalse: [ len < oldLen 47 | ifTrue: [ ^ self growto: len ] 48 | ifFalse: [ ^ self ] ] 49 | "Not so; return self shortened" ]. 50 | ^ minVal ]. "Return self, or a shortened copy" 51 | len < oldLen 52 | ifTrue: [ ^ self growto: len ] 53 | ifFalse: [ ^ self ] 54 | ] 55 | 56 | { #category : #'as yet unclassified' } 57 | PCLargeNegativeInteger >> printOn: aStream base: b [ 58 | "Refer to the comment in Integer|printOn:base:." 59 | 60 | aStream nextPut: $-. 61 | super printOn: aStream base: b 62 | ] 63 | 64 | { #category : #'as yet unclassified' } 65 | PCLargeNegativeInteger >> sign [ 66 | "Optimization. Answer -1 since receiver is less than 0." 67 | 68 | ^ -1 69 | ] 70 | -------------------------------------------------------------------------------- /filetree/Kernel-Numeric/PCMagnitude.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCMagnitude, 3 | #superclass : #PCObject, 4 | #category : 'Kernel-Numeric' 5 | } 6 | 7 | { #category : #'as yet unclassified' } 8 | PCMagnitude >> < aMagnitude [ 9 | "Answer whether the receiver is less than the argument." 10 | 11 | ^ self subclassResponsibility 12 | ] 13 | 14 | { #category : #'as yet unclassified' } 15 | PCMagnitude >> <= aMagnitude [ 16 | "Answer whether the receiver is less than or equal to the argument." 17 | 18 | ^ (self > aMagnitude) not 19 | ] 20 | 21 | { #category : #'as yet unclassified' } 22 | PCMagnitude >> = aMagnitude [ 23 | "Compare the receiver with the argument and answer with true if the 24 | receiver is equal to the argument. Otherwise answer false." 25 | 26 | ^ self subclassResponsibility 27 | ] 28 | 29 | { #category : #'as yet unclassified' } 30 | PCMagnitude >> > aMagnitude [ 31 | "Answer whether the receiver is greater than the argument." 32 | 33 | ^ aMagnitude < self 34 | ] 35 | 36 | { #category : #'as yet unclassified' } 37 | PCMagnitude >> >= aMagnitude [ 38 | "Answer whether the receiver is greater than or equal to the argument." 39 | 40 | ^ (self < aMagnitude) not 41 | ] 42 | 43 | { #category : #'as yet unclassified' } 44 | PCMagnitude >> between: min and: max [ 45 | "Answer whether the receiver is less than or equal to the argument, max, 46 | and greater than or equal to the argument, min." 47 | 48 | ^ self >= min and: [ self <= max ] 49 | ] 50 | 51 | { #category : #'as yet unclassified' } 52 | PCMagnitude >> hash [ 53 | "Hash must be redefined whenever = is redefined." 54 | 55 | ^ self subclassResponsibility 56 | ] 57 | 58 | { #category : #'as yet unclassified' } 59 | PCMagnitude >> max: aMagnitude [ 60 | "Answer the receiver or the argument, whichever has the greater 61 | magnitude." 62 | 63 | self > aMagnitude 64 | ifTrue: [ ^ self ] 65 | ifFalse: [ ^ aMagnitude ] 66 | ] 67 | 68 | { #category : #'as yet unclassified' } 69 | PCMagnitude >> min: aMagnitude [ 70 | "Answer the receiver or the argument, whichever has the lesser 71 | magnitude." 72 | 73 | self < aMagnitude 74 | ifTrue: [ ^ self ] 75 | ifFalse: [ ^ aMagnitude ] 76 | ] 77 | -------------------------------------------------------------------------------- /filetree/Kernel-Numeric/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-Numeric' } 2 | -------------------------------------------------------------------------------- /filetree/Kernel-Objects/PCFalse.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCFalse, 3 | #superclass : #PCTrue, 4 | #category : 'Kernel-Objects' 5 | } 6 | 7 | { #category : #'as yet unclassified' } 8 | PCFalse >> & aBoolean [ 9 | "Answer true if both the receiver AND the argument are true. Unlike and:, the argument is always evaluted." 10 | 11 | ^ false 12 | ] 13 | 14 | { #category : #'as yet unclassified' } 15 | PCFalse >> and: alternativeBlock [ 16 | "Answer true if both the receiver AND the result of evaluating the given block are true. Only evaluate the given block if the receiver is true." 17 | 18 | ^ false 19 | ] 20 | 21 | { #category : #'as yet unclassified' } 22 | PCFalse >> ifFalse: falseBlock [ 23 | "If the receiver is false, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because the expression is compiled in-line." 24 | 25 | ^ falseBlock value 26 | ] 27 | 28 | { #category : #'as yet unclassified' } 29 | PCFalse >> ifTrue: trueBlock [ 30 | "If the receiver is true, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the true is not a boolean. Execution does not actually reach here because the expression is compiled in-line." 31 | 32 | ^ nil 33 | ] 34 | 35 | { #category : #'as yet unclassified' } 36 | PCFalse >> ifTrue: trueBlock ifFalse: falseBlock [ 37 | "If the receiver is true, answer the result of evaluating trueBlock. Otherwise, answer the result of evaluating falseBlock. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because this message is compiled in-line." 38 | 39 | ^ falseBlock value 40 | ] 41 | 42 | { #category : #'as yet unclassified' } 43 | PCFalse >> not [ 44 | "Answer the negation of the receiver." 45 | 46 | ^ true 47 | ] 48 | 49 | { #category : #'as yet unclassified' } 50 | PCFalse >> or: alternativeBlock [ 51 | "Answer true if either the receiver OR the argument are true. Only evaluate the given block if the receiver is false." 52 | 53 | ^ alternativeBlock value 54 | ] 55 | 56 | { #category : #'as yet unclassified' } 57 | PCFalse >> printOn: aStream [ 58 | aStream nextPutAll: 'false' 59 | ] 60 | 61 | { #category : #'as yet unclassified' } 62 | PCFalse >> | aBoolean [ 63 | "Answer true if either the receiver OR the argument are true. Unlike or:, the argument is always evaluted." 64 | 65 | ^ aBoolean 66 | ] 67 | -------------------------------------------------------------------------------- /filetree/Kernel-Objects/PCTrue.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCTrue, 3 | #superclass : #PCObject, 4 | #category : 'Kernel-Objects' 5 | } 6 | 7 | { #category : #'as yet unclassified' } 8 | PCTrue class >> new [ 9 | "There is a single unique instance of each boolean." 10 | 11 | self cannotInstantiate 12 | ] 13 | 14 | { #category : #'as yet unclassified' } 15 | PCTrue >> & alternativeObject [ 16 | "Answer true if both the receiver AND the argument are true. Unlike and:, the argument is always evaluted." 17 | 18 | ^ alternativeObject 19 | ] 20 | 21 | { #category : #'as yet unclassified' } 22 | PCTrue >> and: alternativeBlock [ 23 | "Answer true if both the receiver AND the result of evaluating the given block are true. Only evaluate the given block if the receiver is true." 24 | 25 | ^ alternativeBlock value 26 | ] 27 | 28 | { #category : #'as yet unclassified' } 29 | PCTrue >> basicCopy [ 30 | "There is the only one instance of me, so answer myself." 31 | 32 | ^ self 33 | ] 34 | 35 | { #category : #'as yet unclassified' } 36 | PCTrue >> ifFalse: falseBlock [ 37 | "If the receiver is false, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because the expression is compiled in-line." 38 | 39 | ^ nil 40 | ] 41 | 42 | { #category : #'as yet unclassified' } 43 | PCTrue >> ifTrue: trueBlock [ 44 | "If the receiver is true, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the true is not a boolean. Execution does not actually reach here because the expression is compiled in-line." 45 | 46 | ^ trueBlock value 47 | ] 48 | 49 | { #category : #'as yet unclassified' } 50 | PCTrue >> ifTrue: trueBlock ifFalse: falseBlock [ 51 | "If the receiver is true, answer the result of evaluating trueBlock. Otherwise, answer the result of evaluating falseBlock. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because this message is compiled in-line." 52 | 53 | ^ trueBlock value 54 | ] 55 | 56 | { #category : #'as yet unclassified' } 57 | PCTrue >> not [ 58 | "Answer the negation of the receiver." 59 | 60 | ^ false 61 | ] 62 | 63 | { #category : #'as yet unclassified' } 64 | PCTrue >> or: alternativeBlock [ 65 | "Answer true if either the receiver OR the argument are true. Only evaluate the given block if the receiver is false." 66 | 67 | ^ true 68 | ] 69 | 70 | { #category : #'as yet unclassified' } 71 | PCTrue >> printOn: aStream [ 72 | aStream nextPutAll: 'true' 73 | ] 74 | 75 | { #category : #'as yet unclassified' } 76 | PCTrue >> | aBoolean [ 77 | "Answer true if either the receiver OR the argument are true. Unlike or:, the argument is always evaluted." 78 | 79 | ^ true 80 | ] 81 | -------------------------------------------------------------------------------- /filetree/Kernel-Objects/PCUndefinedObject.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCUndefinedObject, 3 | #superclass : #PCObject, 4 | #category : 'Kernel-Objects' 5 | } 6 | 7 | { #category : #'as yet unclassified' } 8 | PCUndefinedObject class >> new [ 9 | "There is a single unique instance of me." 10 | 11 | self cannotInstantiate 12 | ] 13 | 14 | { #category : #'as yet unclassified' } 15 | PCUndefinedObject >> basicCopy [ 16 | "There is the only one instance of me, so answer myself." 17 | 18 | ^ self 19 | ] 20 | 21 | { #category : #'as yet unclassified' } 22 | PCUndefinedObject >> ifNil: aBlock [ 23 | "A convenient test, in conjunction with Object ifNil:" 24 | 25 | ^ aBlock value 26 | ] 27 | 28 | { #category : #'as yet unclassified' } 29 | PCUndefinedObject >> ifNil: nilBlock ifNotNil: ifNotNilBlock [ 30 | "Evaluate the block for nil because I'm == nil" 31 | 32 | ^ nilBlock value 33 | ] 34 | 35 | { #category : #'as yet unclassified' } 36 | PCUndefinedObject >> ifNotNil: aBlock [ 37 | "A convenient test, in conjunction with Object ifNotNil:" 38 | 39 | ^ self 40 | ] 41 | 42 | { #category : #'as yet unclassified' } 43 | PCUndefinedObject >> isNil [ 44 | "Answer true if the receiver is nil." 45 | 46 | ^ true 47 | ] 48 | 49 | { #category : #'as yet unclassified' } 50 | PCUndefinedObject >> printOn: aStream [ 51 | aStream nextPutAll: 'nil' 52 | ] 53 | 54 | { #category : #'as yet unclassified' } 55 | PCUndefinedObject >> subclass: subclassName instanceVariableNames: instVarNames classVariableNames: classVarNames [ 56 | ^ PCClassBuilder new 57 | superclass: self; 58 | name: subclassName; 59 | instVarNames: instVarNames; 60 | classVariableNames: classVarNames; 61 | build 62 | ] 63 | -------------------------------------------------------------------------------- /filetree/Kernel-Objects/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-Objects' } 2 | -------------------------------------------------------------------------------- /filetree/Kernel-Optional-Graphics/PCBitBlt.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCBitBlt, 3 | #superclass : #PCObject, 4 | #instVars : [ 5 | 'destForm', 6 | 'sourceForm', 7 | 'fillWords', 8 | 'rule', 9 | 'destX', 10 | 'destY', 11 | 'width', 12 | 'height', 13 | 'sourceX', 14 | 'sourceY', 15 | 'clipX', 16 | 'clipY', 17 | 'clipWidth', 18 | 'clipHeight', 19 | 'colorMap' 20 | ], 21 | #category : 'Kernel-Optional-Graphics' 22 | } 23 | 24 | { #category : #'as yet unclassified' } 25 | PCBitBlt >> clipX: x y: y width: w height: h [ 26 | "Set my clipping boundaries. Setting the clipping bounds is optional." 27 | 28 | clipX := x. 29 | clipY := y. 30 | clipWidth := w. 31 | clipHeight := h 32 | ] 33 | 34 | { #category : #'as yet unclassified' } 35 | PCBitBlt >> copyBits [ 36 | "Primitive. Perform the movement of bits from the source form to the destination form. Fail if any variables are not of the right type or if the combination rule is not implemented." 37 | 38 | 39 | self primitiveFailed 40 | ] 41 | 42 | { #category : #'as yet unclassified' } 43 | PCBitBlt >> copyBitsTranslucent: factor [ 44 | "This entry point to BitBlt supplies an extra argument to specify translucency for operations 30 and 31. The argument must be an integer between 0 and 255." 45 | 46 | 47 | self primitiveFailed 48 | ] 49 | 50 | { #category : #'as yet unclassified' } 51 | PCBitBlt >> destForm: aForm [ 52 | "Set my destination Form." 53 | 54 | destForm := aForm. 55 | clipX := 0. 56 | clipY := 0. 57 | clipWidth := aForm width. 58 | clipHeight := aForm height 59 | ] 60 | 61 | { #category : #'as yet unclassified' } 62 | PCBitBlt >> destX: x y: y width: w height: h [ 63 | "Set the destination rectangle for this operation." 64 | 65 | destX := x. 66 | destY := y. 67 | width := w. 68 | height := h 69 | ] 70 | 71 | { #category : #'as yet unclassified' } 72 | PCBitBlt >> fillR: r g: g b: b [ 73 | "Set my fill color to the given RGB value, where r, g, and b are in the range 0-255. The destination form must be set before calling this method, since the pixel pattern created depends on the destination depth." 74 | 75 | "Note: The ranges of r, g, and b are not checked." 76 | 77 | | d pix | 78 | d := destForm depth. 79 | d = 8 80 | ifTrue: [ pix := 41 + (r // 37 * 36) + (g // 37 * 6) + (b // 37). 81 | ^ self fillWords: (PCWordArray with: 16r01010101 * pix) ]. 82 | d = 16 83 | ifTrue: [ pix := (r // 8 bitShift: 10) + (g // 8 bitShift: 5) + (b // 8). 84 | ^ self fillWords: (PCWordArray with: (pix bitShift: 16) + pix) ]. 85 | "5 bits each of r, g, b" 86 | d = 32 87 | ifTrue: [ ^ self 88 | fillWords: (PCWordArray with: (r bitShift: 16) + (g bitShift: 8) + b) ]. 89 | self error: 'color is supported only for depths 8, 16, and 32' 90 | ] 91 | 92 | { #category : #'as yet unclassified' } 93 | PCBitBlt >> fillWords [ 94 | "Answer the array of pixel words using for filling with a color." 95 | 96 | ^ fillWords 97 | ] 98 | 99 | { #category : #'as yet unclassified' } 100 | PCBitBlt >> fillWords: aBitmapOrNil [ 101 | "Set the array of pixel words using for filling with a color." 102 | 103 | fillWords := aBitmapOrNil 104 | ] 105 | 106 | { #category : #'as yet unclassified' } 107 | PCBitBlt >> initialize [ 108 | rule := PCForm over. 109 | sourceX := sourceY := 0. 110 | destX := destY := 0. 111 | clipX := clipY := 0. 112 | clipWidth := clipHeight := 100000 113 | ] 114 | 115 | { #category : #'as yet unclassified' } 116 | PCBitBlt >> rule: anInteger [ 117 | "Set the combination rule, an integer between 0 and 34 that determines how pixels are combined in this operation." 118 | 119 | rule := anInteger 120 | ] 121 | 122 | { #category : #'as yet unclassified' } 123 | PCBitBlt >> sourceForm: aForm [ 124 | "Set my source and destination forms. The source form may be nil if filling with a color." 125 | 126 | sourceForm := aForm 127 | ] 128 | 129 | { #category : #'as yet unclassified' } 130 | PCBitBlt >> sourceX: x y: y [ 131 | "Set the top-left corner of the destination rectangle for this operation." 132 | 133 | sourceX := x. 134 | sourceY := y 135 | ] 136 | 137 | { #category : #'as yet unclassified' } 138 | PCBitBlt >> width: w height: h [ 139 | "Set the width and height for this operation." 140 | 141 | width := w. 142 | height := h 143 | ] 144 | -------------------------------------------------------------------------------- /filetree/Kernel-Optional-Graphics/PCForm.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCForm, 3 | #superclass : #PCObject, 4 | #instVars : [ 5 | 'bits', 6 | 'width', 7 | 'height', 8 | 'depth', 9 | 'bitBlt' 10 | ], 11 | #category : 'Kernel-Optional-Graphics' 12 | } 13 | 14 | { #category : #'as yet unclassified' } 15 | PCForm class >> over [ 16 | ^ 3 17 | ] 18 | 19 | { #category : #'as yet unclassified' } 20 | PCForm class >> paint [ 21 | ^ 25 22 | ] 23 | 24 | { #category : #'as yet unclassified' } 25 | PCForm class >> width: w height: h depth: d [ 26 | ^ self basicNew setWidth: w height: h depth: d 27 | ] 28 | 29 | { #category : #'as yet unclassified' } 30 | PCForm >> beDisplayDepth: d [ 31 | "Install myself as the Display. Drawing onto me will then cause the screen or window to be updated." 32 | 33 | | screenExtent | 34 | screenExtent := self primScreenSize. 35 | self 36 | setWidth: (screenExtent instVarAt: 1) 37 | height: (screenExtent instVarAt: 2) 38 | depth: d. 39 | PCSystem specialObjectsArray at: 15 put: self "make this Form the Display" 40 | ] 41 | 42 | { #category : #'as yet unclassified' } 43 | PCForm >> bits [ 44 | ^ bits 45 | ] 46 | 47 | { #category : #'as yet unclassified' } 48 | PCForm >> copyX: x y: y width: w height: h [ 49 | "Answer a new form containing given rectangular portion of this form." 50 | 51 | | result | 52 | result := PCForm basicNew setWidth: w height: h depth: depth. 53 | PCBitBlt new 54 | sourceForm: self; 55 | destForm: result; 56 | sourceX: x y: y; 57 | width: w height: h; 58 | copyBits. 59 | ^ result 60 | ] 61 | 62 | { #category : #'as yet unclassified' } 63 | PCForm >> depth [ 64 | ^ depth 65 | ] 66 | 67 | { #category : #'as yet unclassified' } 68 | PCForm >> drawForm: aForm x: x y: y rule: anInteger [ 69 | "Fill the given rectangle with the current fill color." 70 | 71 | | oldFill | 72 | oldFill := bitBlt fillWords. 73 | bitBlt 74 | sourceForm: aForm; 75 | destX: x 76 | y: y 77 | width: aForm width 78 | height: aForm height; 79 | rule: anInteger; 80 | copyBits. 81 | bitBlt sourceForm: nil. 82 | bitBlt fillWords: oldFill 83 | ] 84 | 85 | { #category : #'as yet unclassified' } 86 | PCForm >> fillRectX: x y: y w: w h: h [ 87 | "Fill the given rectangle with the current fill color." 88 | 89 | bitBlt 90 | destX: x 91 | y: y 92 | width: w 93 | height: h; 94 | copyBits 95 | ] 96 | 97 | { #category : #'as yet unclassified' } 98 | PCForm >> height [ 99 | ^ height 100 | ] 101 | 102 | { #category : #'as yet unclassified' } 103 | PCForm >> primScreenSize [ 104 | "Answer the actual screen size. In Pharo Candle, this will be an Association object since Pharo Candle doesn't have Points." 105 | 106 | 107 | self primitiveFailed 108 | ] 109 | 110 | { #category : #'as yet unclassified' } 111 | PCForm >> setColorR: r g: g b: b [ 112 | "Set the fill color for rectangle drawing operations." 113 | 114 | bitBlt fillR: r g: g b: b 115 | ] 116 | 117 | { #category : #'as yet unclassified' } 118 | PCForm >> setWidth: w height: h depth: d [ 119 | | wordsPerLine | 120 | wordsPerLine := (w * d + 31) // 32. 121 | bits := PCByteArray new: 4 * wordsPerLine * h. 122 | width := w. 123 | height := h. 124 | depth := d. 125 | bitBlt := PCBitBlt new 126 | destForm: self; 127 | fillR: 255 g: 0 b: 0 "default color" 128 | ] 129 | 130 | { #category : #'as yet unclassified' } 131 | PCForm >> width [ 132 | ^ width 133 | ] 134 | -------------------------------------------------------------------------------- /filetree/Kernel-Optional-Graphics/PCWordArray.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCWordArray, 3 | #superclass : #PCArrayedCollection, 4 | #type : #words, 5 | #category : 'Kernel-Optional-Graphics' 6 | } 7 | -------------------------------------------------------------------------------- /filetree/Kernel-Optional-Graphics/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-Optional-Graphics' } 2 | -------------------------------------------------------------------------------- /filetree/Kernel-Optional/PCFile.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCFile, 3 | #superclass : #PCObject, 4 | #instVars : [ 5 | 'name', 6 | 'fileID' 7 | ], 8 | #category : 'Kernel-Optional' 9 | } 10 | 11 | { #category : #'as yet unclassified' } 12 | PCFile >> close [ 13 | "Close this file." 14 | 15 | fileID 16 | ifNotNil: [ self primClose: fileID. 17 | fileID := nil ] 18 | ] 19 | 20 | { #category : #'as yet unclassified' } 21 | PCFile >> cr [ 22 | self nextPutAll: (PCString with: PCCharacter cr) 23 | ] 24 | 25 | { #category : #'as yet unclassified' } 26 | PCFile >> localFolderPath [ 27 | "Answer the path for the folder containing the image file." 28 | 29 | "MFile new localFolderPath" 30 | 31 | | imagePath delimiter i | 32 | imagePath := self primImageName. 33 | delimiter := $/. 34 | (imagePath includes: delimiter) 35 | ifFalse: [ delimiter := $\ ]. 36 | i := imagePath size. 37 | [ i > 0 and: [ (imagePath at: i) ~= delimiter ] ] 38 | whileTrue: [ i := i - 1 ]. 39 | i = 0 40 | ifTrue: [ ^ '' ]. 41 | ^ imagePath copyFrom: 1 to: i 42 | ] 43 | 44 | { #category : #'as yet unclassified' } 45 | PCFile >> name [ 46 | "Answer the name of this file." 47 | 48 | ^ name 49 | ] 50 | 51 | { #category : #'as yet unclassified' } 52 | PCFile >> next: count [ 53 | "Answer a String containing the next count bytes of the file. If there are not count bytes left in the file, answer a String with as many bytes as available." 54 | 55 | | buffer n | 56 | buffer := '' class new: count. 57 | n := self 58 | primRead: fileID 59 | into: buffer 60 | startingAt: 1 61 | count: count. 62 | n < count 63 | ifTrue: [ buffer := buffer copyFrom: 1 to: n ]. 64 | ^ buffer 65 | ] 66 | 67 | { #category : #'as yet unclassified' } 68 | PCFile >> nextPutAll: buffer [ 69 | "Write the contents of the given bytes or words object to this file." 70 | 71 | ^ self 72 | primWrite: fileID 73 | from: buffer 74 | startingAt: 1 75 | count: buffer basicSize 76 | ] 77 | 78 | { #category : #'as yet unclassified' } 79 | PCFile >> openReadOnly: fileName [ 80 | "Open the file with the given name for reading and writing." 81 | 82 | name := nil. 83 | fileID := self primOpen: fileName writable: false. 84 | name := fileName 85 | ] 86 | 87 | { #category : #'as yet unclassified' } 88 | PCFile >> openReadWrite: fileName [ 89 | "Open the file with the given name for reading only." 90 | 91 | name := nil. 92 | fileID := self primOpen: fileName writable: true. 93 | name := fileName 94 | ] 95 | 96 | { #category : #'as yet unclassified' } 97 | PCFile >> position [ 98 | "Answer the current file position in bytes." 99 | 100 | ^ self primGetPosition: fileID 101 | ] 102 | 103 | { #category : #'as yet unclassified' } 104 | PCFile >> position: newPosition [ 105 | "Seek to the given file position in bytes." 106 | 107 | ^ self primSetPosition: fileID to: newPosition 108 | ] 109 | 110 | { #category : #'as yet unclassified' } 111 | PCFile >> primClose: id [ 112 | "Close this file. Don't raise an error if the primitive fails." 113 | 114 | 115 | 116 | ] 117 | 118 | { #category : #'as yet unclassified' } 119 | PCFile >> primGetPosition: id [ 120 | "Get this files current position." 121 | 122 | 123 | self primitiveFailed 124 | ] 125 | 126 | { #category : #'as yet unclassified' } 127 | PCFile >> primImageName [ 128 | "Answer the full path name for the current image." 129 | 130 | 131 | self primitiveFailed 132 | ] 133 | 134 | { #category : #'as yet unclassified' } 135 | PCFile >> primOpen: fileName writable: writableFlag [ 136 | "Open a file of the given name, and return the file ID obtained. 137 | If writableFlag is true, then 138 | if there is none with this name, then create one 139 | else prepare to overwrite the existing from the beginning 140 | otherwise 141 | if the file exists, open it read-only 142 | else return nil" 143 | 144 | 145 | self primitiveFailed 146 | ] 147 | 148 | { #category : #'as yet unclassified' } 149 | PCFile >> primRead: id into: byteArray startingAt: startIndex count: count [ 150 | "Read up to count elements into the given buffer and answer the number of elements actually read. The buffer may either a byte- or word-indexable object." 151 | 152 | 153 | self primitiveFailed 154 | ] 155 | 156 | { #category : #'as yet unclassified' } 157 | PCFile >> primSetPosition: id to: anInteger [ 158 | "Set this file to the given position." 159 | 160 | 161 | self primitiveFailed 162 | ] 163 | 164 | { #category : #'as yet unclassified' } 165 | PCFile >> primSize: id [ 166 | "Answer the size of this file." 167 | 168 | 169 | self primitiveFailed 170 | ] 171 | 172 | { #category : #'as yet unclassified' } 173 | PCFile >> primWrite: id from: buffer startingAt: startIndex count: count [ 174 | "Write up to count elements from the given buffer and answer the number of elements actually written. The buffer may either a byte- or word-indexable object." 175 | 176 | 177 | self primitiveFailed 178 | ] 179 | 180 | { #category : #'as yet unclassified' } 181 | PCFile >> readInto: buffer startingAt: startIndex count: count [ 182 | "Read up to count elements into the given array and answer the number of elements actually read. The buffer may either a byte- or word-indexable object." 183 | 184 | ^ self 185 | primRead: fileID 186 | into: buffer 187 | startingAt: startIndex 188 | count: count 189 | ] 190 | 191 | { #category : #'as yet unclassified' } 192 | PCFile >> size [ 193 | "Answer the size of this file in bytes." 194 | 195 | ^ self primSize: fileID 196 | ] 197 | -------------------------------------------------------------------------------- /filetree/Kernel-Optional/PCIdentityDictionary.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCIdentityDictionary, 3 | #superclass : #PCDictionary, 4 | #category : 'Kernel-Optional' 5 | } 6 | 7 | { #category : #'as yet unclassified' } 8 | PCIdentityDictionary >> keys [ 9 | "Answer an array of the receiver's keys." 10 | 11 | | result | 12 | result := PCOrderedCollection new: self size. 13 | self keysDo: [ :key | result add: key ]. 14 | ^ result asArray 15 | ] 16 | 17 | { #category : #'as yet unclassified' } 18 | PCIdentityDictionary >> scanFor: anObject [ 19 | "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 20 | 21 | | finish hash start element | 22 | finish := array size. 23 | finish > 4096 24 | ifTrue: [ hash := anObject identityHash * (finish // 4096) ] 25 | ifFalse: [ hash := anObject identityHash ]. 26 | start := hash \\ array size + 1. "Search from (hash mod size) to the end." 27 | start to: finish do: [ :index | 28 | ((element := array at: index) == nil or: [ element key == anObject ]) 29 | ifTrue: [ ^ index ] ]. "Search from 1 to where we started." 30 | 1 to: start - 1 do: [ :index | 31 | ((element := array at: index) == nil or: [ element key == anObject ]) 32 | ifTrue: [ ^ index ] ]. 33 | ^ 0 "No match AND no empty slot" 34 | ] 35 | -------------------------------------------------------------------------------- /filetree/Kernel-Optional/PCIdentitySet.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCIdentitySet, 3 | #superclass : #PCSet, 4 | #category : 'Kernel-Optional' 5 | } 6 | 7 | { #category : #'as yet unclassified' } 8 | PCIdentitySet >> scanFor: anObject [ 9 | "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 10 | 11 | | finish hash start element | 12 | finish := array size. 13 | finish > 4096 14 | ifTrue: [ hash := anObject identityHash * (finish // 4096) ] 15 | ifFalse: [ hash := anObject identityHash ]. 16 | start := hash \\ array size + 1. "Search from (hash mod size) to the end." 17 | start to: finish do: [ :index | 18 | ((element := array at: index) == nil or: [ element == anObject ]) 19 | ifTrue: [ ^ index ] ]. "Search from 1 to where we started." 20 | 1 to: start - 1 do: [ :index | 21 | ((element := array at: index) == nil or: [ element == anObject ]) 22 | ifTrue: [ ^ index ] ]. 23 | ^ 0 "No match AND no empty slot" 24 | ] 25 | -------------------------------------------------------------------------------- /filetree/Kernel-Optional/PCSemaphore.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCSemaphore, 3 | #superclass : #PCLinkedList, 4 | #instVars : [ 5 | 'excessSignals' 6 | ], 7 | #category : 'Kernel-Optional' 8 | } 9 | 10 | { #category : #'as yet unclassified' } 11 | PCSemaphore >> = anObject [ 12 | ^ self == anObject 13 | ] 14 | 15 | { #category : #'as yet unclassified' } 16 | PCSemaphore >> critical: aBlock [ 17 | "Evaluate the given block immediated if the receiver is not currently running the critical: method. If it is, evaluate the given block when the current critical: message is finished. Answer the result of evaluating the block." 18 | 19 | | result | 20 | self wait. 21 | result := aBlock value. 22 | self signal. 23 | ^ result 24 | ] 25 | 26 | { #category : #'as yet unclassified' } 27 | PCSemaphore >> hash [ 28 | ^ self identityHash 29 | ] 30 | 31 | { #category : #'as yet unclassified' } 32 | PCSemaphore >> initialize [ 33 | "Consume any excess signals the receiver may have accumulated." 34 | 35 | excessSignals := 0 36 | ] 37 | 38 | { #category : #'as yet unclassified' } 39 | PCSemaphore >> signal [ 40 | "Primitive. Increment my signal count. If one or more processes are waiting on me, allow the first one to proceed. If no process is waiting, just remember the excess signal. Essential. See Object documentation whatIsAPrimitive." 41 | 42 | 43 | self primitiveFailed 44 | ] 45 | 46 | { #category : #'as yet unclassified' } 47 | PCSemaphore >> wait [ 48 | "Primitive. This semaphore must have a signal before the caller's process can proceed. If I have no signals, the process is suspended this semaphore is signalled. Essential. See Object documentation whatIsAPrimitive." 49 | 50 | 51 | self primitiveFailed 52 | ] 53 | -------------------------------------------------------------------------------- /filetree/Kernel-Optional/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-Optional' } 2 | -------------------------------------------------------------------------------- /filetree/Kernel-Processes/PCProcess.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCProcess, 3 | #superclass : #PCObject, 4 | #instVars : [ 5 | 'nextLink', 6 | 'suspendedContext', 7 | 'priority', 8 | 'myList', 9 | 'threadId', 10 | 'errorHandler' 11 | ], 12 | #category : 'Kernel-Processes' 13 | } 14 | 15 | { #category : #'as yet unclassified' } 16 | PCProcess class >> for: aContext priority: anInteger [ 17 | "Answer an instance of me for the given context (usually a Block) at the given priority." 18 | 19 | ^ self new 20 | initSuspendedContext: aContext; 21 | priority: anInteger 22 | ] 23 | 24 | { #category : #'as yet unclassified' } 25 | PCProcess >> errorHandler [ 26 | ^ errorHandler 27 | ] 28 | 29 | { #category : #'as yet unclassified' } 30 | PCProcess >> errorHandler: aBlock [ 31 | errorHandler := aBlock 32 | ] 33 | 34 | { #category : #'as yet unclassified' } 35 | PCProcess >> initSuspendedContext: aContext [ 36 | suspendedContext := aContext. 37 | priority := 1 "lowest priority" 38 | ] 39 | 40 | { #category : #'as yet unclassified' } 41 | PCProcess >> nextLink [ 42 | ^ nextLink 43 | ] 44 | 45 | { #category : #'as yet unclassified' } 46 | PCProcess >> nextLink: aLink [ 47 | nextLink := aLink 48 | ] 49 | 50 | { #category : #'as yet unclassified' } 51 | PCProcess >> printOn: aStream [ 52 | super printOn: aStream. 53 | aStream nextPutAll: ' in '. 54 | suspendedContext printOn: aStream 55 | ] 56 | 57 | { #category : #'as yet unclassified' } 58 | PCProcess >> priority [ 59 | "Answer the priority of the receiver." 60 | 61 | ^ priority 62 | ] 63 | 64 | { #category : #'as yet unclassified' } 65 | PCProcess >> priority: anInteger [ 66 | "Set the receiver's priority to anInteger. The priority is used by the VM as an index into the scheduler's array of process queues so it must be an integer between 1 and Processor highestPriority." 67 | 68 | priority := (anInteger asInteger max: 1) 69 | min: Processor highestPriority 70 | ] 71 | 72 | { #category : #'as yet unclassified' } 73 | PCProcess >> resume [ 74 | "Primitive. Allow this process to proceed. Put the receiver in line to become the active process. Fail if the receiver is already waiting on a queue (i.e., on a Semaphore or on a scheduler queue). Essential. See Object documentation whatIsAPrimitive." 75 | 76 | 77 | self primitiveFailed 78 | ] 79 | 80 | { #category : #'as yet unclassified' } 81 | PCProcess >> suspend [ 82 | "Primitive. Stop this process in such a way that it can be restarted later (see resume). If the receiver is the active process, suspend it. Otherwise, remove the receiver from its suspended process list. Essential. See Object documentation whatIsAPrimitive." 83 | 84 | 85 | Processor activeProcess == self 86 | ifTrue: [ self primitiveFailed ] 87 | ifFalse: [ Processor 88 | remove: self 89 | ifAbsent: [ self error: 'This process was not active' ]. 90 | myList := nil ] 91 | ] 92 | 93 | { #category : #'as yet unclassified' } 94 | PCProcess >> suspendedContext [ 95 | ^ suspendedContext 96 | ] 97 | 98 | { #category : #'as yet unclassified' } 99 | PCProcess >> terminate [ 100 | "Stop this process forever." 101 | 102 | Processor activeProcess == self 103 | ifTrue: [ thisContext removeSelf suspend ] 104 | ifFalse: [ myList 105 | ifNotNil: [ myList remove: self ifAbsent: [ ]. 106 | myList := nil ]. 107 | suspendedContext := nil ] 108 | ] 109 | -------------------------------------------------------------------------------- /filetree/Kernel-Processes/PCProcessList.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCProcessList, 3 | #superclass : #PCSequenceableCollection, 4 | #instVars : [ 5 | 'firstLink', 6 | 'lastLink' 7 | ], 8 | #category : 'Kernel-Processes' 9 | } 10 | 11 | { #category : #'as yet unclassified' } 12 | PCProcessList >> add: aLink [ 13 | "Add aLink to the end of the receiver's list. Answer aLink." 14 | 15 | ^ self addLast: aLink 16 | ] 17 | 18 | { #category : #'as yet unclassified' } 19 | PCProcessList >> addLast: aLink [ 20 | "Add aLink to the end of the receiver's list. Answer aLink." 21 | 22 | self isEmpty 23 | ifTrue: [ firstLink := aLink ] 24 | ifFalse: [ lastLink nextLink: aLink ]. 25 | lastLink := aLink. 26 | ^ aLink 27 | ] 28 | 29 | { #category : #'as yet unclassified' } 30 | PCProcessList >> do: aBlock [ 31 | "Evaluate the given block for each of my elements." 32 | 33 | | aLink | 34 | aLink := firstLink. 35 | [ aLink == nil ] 36 | whileFalse: [ aBlock value: aLink. 37 | aLink := aLink nextLink ] 38 | ] 39 | 40 | { #category : #'as yet unclassified' } 41 | PCProcessList >> first [ 42 | "Answer the first element. Raise an error if I am empty." 43 | 44 | self emptyCheck. 45 | ^ firstLink 46 | ] 47 | 48 | { #category : #'as yet unclassified' } 49 | PCProcessList >> isEmpty [ 50 | ^ firstLink == nil 51 | ] 52 | 53 | { #category : #'as yet unclassified' } 54 | PCProcessList >> remove: aLink ifAbsent: aBlock [ 55 | "Remove aLink from the receiver. If it is not there, answer the result of evaluating aBlock." 56 | 57 | | tempLink | 58 | aLink == firstLink 59 | ifTrue: [ firstLink := aLink nextLink. 60 | aLink == lastLink 61 | ifTrue: [ lastLink := nil ] ] 62 | ifFalse: [ tempLink := firstLink. 63 | [ tempLink == nil 64 | ifTrue: [ ^ aBlock value ]. 65 | tempLink nextLink == aLink ] 66 | whileFalse: [ tempLink := tempLink nextLink ]. 67 | tempLink nextLink: aLink nextLink. 68 | aLink == lastLink 69 | ifTrue: [ lastLink := tempLink ] ]. 70 | aLink nextLink: nil. 71 | ^ aLink 72 | ] 73 | 74 | { #category : #'as yet unclassified' } 75 | PCProcessList >> removeFirst [ 76 | "Remove and answer the first element. Raise an error if I am empty." 77 | 78 | | oldLink | 79 | self emptyCheck. 80 | oldLink := firstLink. 81 | firstLink == lastLink 82 | ifTrue: [ firstLink := nil. 83 | lastLink := nil ] 84 | ifFalse: [ firstLink := oldLink nextLink ]. 85 | oldLink nextLink: nil. 86 | ^ oldLink 87 | ] 88 | 89 | { #category : #'as yet unclassified' } 90 | PCProcessList >> size [ 91 | "Answer the number of elements I contain." 92 | 93 | | tally | 94 | tally := 0. 95 | self do: [ :each | tally := tally + 1 ]. 96 | ^ tally 97 | ] 98 | -------------------------------------------------------------------------------- /filetree/Kernel-Processes/PCProcessorScheduler.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCProcessorScheduler, 3 | #superclass : #PCObject, 4 | #instVars : [ 5 | 'suspendedProcessLists', 6 | 'activeProcess' 7 | ], 8 | #category : 'Kernel-Processes' 9 | } 10 | 11 | { #category : #'as yet unclassified' } 12 | PCProcessorScheduler class >> new [ 13 | "The VM depends on a unique scheduler." 14 | 15 | self cannotInstantiate 16 | ] 17 | 18 | { #category : #'as yet unclassified' } 19 | PCProcessorScheduler >> activeProcess [ 20 | "Answer the currently running Process." 21 | 22 | ^ activeProcess 23 | ] 24 | 25 | { #category : #'as yet unclassified' } 26 | PCProcessorScheduler >> highestPriority [ 27 | "Answer the number of priority levels currently available for use." 28 | 29 | ^ suspendedProcessLists size 30 | ] 31 | 32 | { #category : #'as yet unclassified' } 33 | PCProcessorScheduler >> idleProcess [ 34 | "A default background process that simply loops forever. It runs only when no higher priority processes are available, perhaps because they are waiting on a semaphore or timer." 35 | 36 | [ true ] whileTrue: [ ] 37 | "do nothing" 38 | ] 39 | 40 | { #category : #'as yet unclassified' } 41 | PCProcessorScheduler >> initProcessLists [ 42 | "Create process lists for prioriy levels 1 through 5." 43 | 44 | suspendedProcessLists := (1 to: 5) 45 | collect: [ :i | PCProcessList new ] 46 | ] 47 | 48 | { #category : #'as yet unclassified' } 49 | PCProcessorScheduler >> installIdleProcess [ 50 | "Install an idle process of the lowest possible priority that is always runnable." 51 | 52 | "Details: The virtual machine requires that there is always some runnable process that can be scheduled; this background process ensures that this is the case." 53 | 54 | | idleList idleProc | 55 | "terminate any old idle processes" 56 | idleList := suspendedProcessLists at: 1. 57 | [ idleList isEmpty ] whileFalse: [ idleList first terminate ]. 58 | idleProc := PCProcess for: [ self idleProcess ] priority: 1. 59 | (suspendedProcessLists at: idleProc priority) addLast: idleProc 60 | ] 61 | 62 | { #category : #'as yet unclassified' } 63 | PCProcessorScheduler >> installStartProcess [ 64 | "Install the startup process as the active process. This process will run when Pharo Candle is started." 65 | 66 | activeProcess := PCProcess 67 | for: [ PCSystem start ] asContext 68 | priority: 3 69 | ] 70 | 71 | { #category : #'as yet unclassified' } 72 | PCProcessorScheduler >> remove: aProcess ifAbsent: aBlock [ 73 | "Remove the given process from the list on which it is waiting. If the process is not on the queue for it's priority, evaluate the given block. Always answer the process." 74 | 75 | (suspendedProcessLists at: aProcess priority) 76 | remove: aProcess 77 | ifAbsent: aBlock. 78 | ^ aProcess 79 | ] 80 | -------------------------------------------------------------------------------- /filetree/Kernel-Processes/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-Processes' } 2 | -------------------------------------------------------------------------------- /filetree/Kernel-Streams/PCReadStream.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCReadStream, 3 | #superclass : #PCObject, 4 | #instVars : [ 5 | 'collection', 6 | 'position', 7 | 'readLimit' 8 | ], 9 | #category : 'Kernel-Streams' 10 | } 11 | 12 | { #category : #'as yet unclassified' } 13 | PCReadStream class >> on: aCollection [ 14 | "Answer an instance of me, streaming over the elements of aCollection." 15 | 16 | ^ self basicNew on: aCollection 17 | ] 18 | 19 | { #category : #'as yet unclassified' } 20 | PCReadStream >> atEnd [ 21 | "Primitive. Answer whether the receiver can access any more objects. Optional. See Object documentation whatIsAPrimitive." 22 | 23 | 24 | ^ position >= readLimit 25 | ] 26 | 27 | { #category : #'as yet unclassified' } 28 | PCReadStream >> contents [ 29 | "Answer with a copy of my collection from 1 to readLimit." 30 | 31 | ^ collection copyFrom: 1 to: readLimit 32 | ] 33 | 34 | { #category : #'as yet unclassified' } 35 | PCReadStream >> next [ 36 | "Primitive. Answer the next object in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Optional. See Object documentation whatIsAPrimitive." 37 | 38 | 39 | position >= readLimit 40 | ifTrue: [ ^ nil ] 41 | ifFalse: [ ^ collection at: (position := position + 1) ] 42 | ] 43 | 44 | { #category : #'as yet unclassified' } 45 | PCReadStream >> next: anInteger [ 46 | "Answer a collection containing the next anInteger elements of my collection." 47 | 48 | | end result | 49 | end := position + anInteger min: readLimit. 50 | result := collection copyFrom: position + 1 to: end. 51 | position := end. 52 | ^ result 53 | ] 54 | 55 | { #category : #'as yet unclassified' } 56 | PCReadStream >> on: aCollection [ 57 | "Initialize myself for streaming over the given collection." 58 | 59 | collection := aCollection. 60 | readLimit := aCollection size. 61 | position := 0 62 | ] 63 | 64 | { #category : #'as yet unclassified' } 65 | PCReadStream >> peek [ 66 | "Answer the next object without advancing my position. Answer nil if there are no more elements." 67 | 68 | | result | 69 | self atEnd 70 | ifTrue: [ ^ nil ]. 71 | result := self next. 72 | position := position - 1. 73 | ^ result 74 | ] 75 | 76 | { #category : #'as yet unclassified' } 77 | PCReadStream >> peekFor: anObject [ 78 | "If my next element equals the given object, skip it and answer true. Otherwise, answer false and leave my position unchanged." 79 | 80 | | result | 81 | result := self peek = anObject. 82 | result 83 | ifTrue: [ self skip: 1 ]. 84 | ^ result 85 | ] 86 | 87 | { #category : #'as yet unclassified' } 88 | PCReadStream >> position [ 89 | "Answer the current position of accessing the sequence of objects." 90 | 91 | ^ position 92 | ] 93 | 94 | { #category : #'as yet unclassified' } 95 | PCReadStream >> position: anInteger [ 96 | "Set my current position to anInteger, as long as anInteger is within bounds. If not, report an error." 97 | 98 | anInteger >= 0 & (anInteger <= readLimit) 99 | ifTrue: [ position := anInteger asInteger ] 100 | ifFalse: [ self error: 'Position out of bounds: ' , anInteger printString ] 101 | ] 102 | 103 | { #category : #'as yet unclassified' } 104 | PCReadStream >> size [ 105 | "Compatibility with other streams (e.g., FileStream)" 106 | 107 | ^ readLimit 108 | ] 109 | 110 | { #category : #'as yet unclassified' } 111 | PCReadStream >> skip: anInteger [ 112 | "Set the receiver's position to be the current position+anInteger." 113 | 114 | self position: (position + anInteger min: readLimit) 115 | ] 116 | -------------------------------------------------------------------------------- /filetree/Kernel-Streams/PCWriteStream.class.st: -------------------------------------------------------------------------------- 1 | Class { 2 | #name : #PCWriteStream, 3 | #superclass : #PCReadStream, 4 | #instVars : [ 5 | 'writeLimit' 6 | ], 7 | #category : 'Kernel-Streams' 8 | } 9 | 10 | { #category : #'as yet unclassified' } 11 | PCWriteStream >> contents [ 12 | "Answer with a copy of my collection up to the high-water mark that was written." 13 | 14 | readLimit := readLimit max: position. 15 | ^ collection copyFrom: 1 to: readLimit 16 | ] 17 | 18 | { #category : #'as yet unclassified' } 19 | PCWriteStream >> nextPut: anObject [ 20 | "Primitive. Insert the argument at the next position in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Fail if the argument is not of the right type for the collection. Optional. See Object documentation whatIsAPrimitive." 21 | 22 | 23 | position >= writeLimit 24 | ifTrue: [ ^ self pastEndPut: anObject ] 25 | ifFalse: [ position := position + 1. 26 | ^ collection at: position put: anObject ] 27 | ] 28 | 29 | { #category : #'as yet unclassified' } 30 | PCWriteStream >> nextPutAll: aCollection [ 31 | "Write the elements of the given collection starting at my current position. Answer the collection." 32 | 33 | "Optimization: If the given collection has the same class as my collection, use the fast operation replaceFrom:to:with:." 34 | 35 | | newEnd | 36 | collection class == aCollection class 37 | ifFalse: [ aCollection do: [ :v | self nextPut: v ]. 38 | ^ aCollection ]. 39 | newEnd := position + aCollection size. 40 | newEnd > writeLimit 41 | ifTrue: [ collection := collection 42 | , 43 | (collection species 44 | new: newEnd - writeLimit + (collection size max: 20)). 45 | writeLimit := collection size ]. 46 | "grow my collection if necessary" 47 | collection replaceFrom: position + 1 to: newEnd with: aCollection. 48 | position := newEnd 49 | ] 50 | 51 | { #category : #'as yet unclassified' } 52 | PCWriteStream >> on: aCollection [ 53 | super on: aCollection. 54 | readLimit := 0. 55 | writeLimit := aCollection size 56 | ] 57 | 58 | { #category : #'as yet unclassified' } 59 | PCWriteStream >> pastEndPut: anObject [ 60 | "Grow my collection." 61 | 62 | "Details: In general, double my size. Grow by at least 20 elements if my size is under 20 and grow by 20000 if my size is over 20000." 63 | 64 | collection := collection 65 | , (collection class new: ((collection size max: 20) min: 20000)). 66 | writeLimit := collection size. 67 | collection at: (position := position + 1) put: anObject 68 | ] 69 | 70 | { #category : #'as yet unclassified' } 71 | PCWriteStream >> position: anInteger [ 72 | "Set my read position, but remember the high-water mark that was written." 73 | 74 | readLimit := readLimit max: position. 75 | super position: anInteger 76 | ] 77 | 78 | { #category : #'as yet unclassified' } 79 | PCWriteStream >> size [ 80 | ^ readLimit := readLimit max: position 81 | ] 82 | 83 | { #category : #'as yet unclassified' } 84 | PCWriteStream >> space [ 85 | "Append a space character to me." 86 | 87 | self nextPut: PCCharacter space 88 | ] 89 | -------------------------------------------------------------------------------- /filetree/Kernel-Streams/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-Streams' } 2 | -------------------------------------------------------------------------------- /filetree/Kernel-System/package.st: -------------------------------------------------------------------------------- 1 | Package { #name : #'Kernel-System' } 2 | -------------------------------------------------------------------------------- /source/Kernel-Classes/PCClass.hz: -------------------------------------------------------------------------------- 1 | PCClass 2 | superclass: #PCBehavior; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#name #instVarNames #classVariables ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Classes'. 7 | 8 | PCClass >> classVariables 9 | [ 10 | "Answer the dictionary of class variables that I share with my sole instance, or nil if I have none." 11 | ^ classVariables 12 | ] 13 | 14 | PCClass >> classVariables: aDictionary 15 | [ 16 | "Answer the dictionary of class variables that I share with my sole instance, or nil if I have none." 17 | ^ classVariables := aDictionary 18 | ] 19 | 20 | 21 | PCClass >> initFrom: aPharoClass methodDict: newMethodDict 22 | [ 23 | "Fill in my instance variables from the given Class using the given MethodDictionary." 24 | superclass := PCObject. "corrected later" 25 | methodDict := newMethodDict. 26 | format := aPharoClass format. 27 | name := (aPharoClass name copyFrom: 2 to: aPharoClass name size) asSymbol. "omit leading M" 28 | instVarNames := aPharoClass instVarNames. 29 | classVariables := aPharoClass classPool. 30 | instVarNames size = 0 31 | ifTrue: [ instVarNames := nil ]. 32 | classVariables size = 0 33 | ifTrue: [ classVariables := nil ] 34 | ] 35 | 36 | PCClass >> instVarNames: anArray 37 | [ 38 | instVarNames := anArray. 39 | ] 40 | 41 | PCClass >> instVarNames 42 | [ 43 | "Answer an Array of the receiver's instance variable names." 44 | instVarNames ifNil: [ ^ #() ]. 45 | ^ instVarNames 46 | ] 47 | 48 | PCClass >> isMeta 49 | [ 50 | ^ false 51 | ] 52 | 53 | PCClass >> name 54 | [ 55 | ^ name 56 | ] 57 | 58 | PCClass >> name: aSymbol 59 | [ 60 | name := aSymbol 61 | ] 62 | 63 | PCClass >> theNonMetaClass 64 | [ 65 | ^ self 66 | ] 67 | 68 | PCClass >> classSide 69 | [ 70 | ^ self class 71 | ] 72 | 73 | PCClass >> newClassBuilderForSubclass: subclassName instanceVariableNames: instVarNames classVariableNames: classVarNames 74 | [ 75 | ^ PCClassBuilder new 76 | superclass: self; 77 | name: subclassName; 78 | instVarNames: instVarNames; 79 | classVariableNames: classVarNames; 80 | yourself 81 | ] 82 | 83 | PCClass >> subclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames 84 | [ 85 | ^ (self newClassBuilderForSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames) 86 | build 87 | ] 88 | 89 | PCClass >> variableSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames 90 | [ 91 | ^ (self newClassBuilderForSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames) 92 | beVariable; 93 | build 94 | ] 95 | 96 | PCClass >> variableByteSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames 97 | [ 98 | ^ (self newClassBuilderForSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames) 99 | beBytes; 100 | build 101 | ] 102 | 103 | PCClass >> variableWordSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames 104 | [ 105 | ^ (self newClassBuilderForSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames) 106 | beWords; 107 | build 108 | ] 109 | 110 | PCClass >> weakSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames 111 | [ 112 | ^ (self newClassBuilderForSubclass: subclassName instanceVariableNames: someInstVarNames classVariableNames: classVarNames) 113 | beWeak; 114 | build 115 | ] 116 | 117 | PCClass class 118 | instanceVariables: #(). 119 | 120 | -------------------------------------------------------------------------------- /source/Kernel-Classes/PCClassBuilder.hz: -------------------------------------------------------------------------------- 1 | PCClassBuilder 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #( #superclass #name #instVarNames #classVariablesNames #formats ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Classes'. 7 | 8 | PCClassBuilder >> initialize 9 | [ 10 | super initialize. 11 | instVarNames := ''. 12 | classVariablesNames := ''. 13 | superclass := PCObject. 14 | self bePointers. 15 | ] 16 | 17 | PCClassBuilder >> build 18 | [ 19 | | metaclass theClass supermetaclass | 20 | supermetaclass := superclass ifNil: [ PCClass ] ifNotNil: [ superclass class ]. 21 | 22 | metaclass := PCMetaclass new. 23 | metaclass superclass: supermetaclass. 24 | metaclass setFormat: supermetaclass format. 25 | 26 | theClass := metaclass basicNew initialize. 27 | 28 | theClass superclass: superclass. 29 | theClass setFormat: self newClassFormat. 30 | 31 | theClass instVarNames: instVarNames asArray. 32 | theClass name: name. 33 | 34 | theClass classVariables: PCDictionary new. 35 | 36 | self classVariableNames do: [ :varName | theClass classVariables at: varName put: nil ]. 37 | 38 | metaclass soleInstance: theClass. 39 | ^ theClass. 40 | ] 41 | 42 | PCClassBuilder >> newClassFormat 43 | [ 44 | "<2 bits of size><5 bits of compact class index><4 bits of inst spec><6 bits of size><1 bit with a 0>" 45 | 46 | | size1 instSpec size2 compactClassIndex | 47 | size1 := (self instSize + 1 // 64) bitAnd: 16r3. 48 | instSpec := self isCompiledMethod 49 | ifTrue: [ 12 ] 50 | ifFalse: [self isWeak 51 | ifTrue:[ 4 ] 52 | ifFalse:[self isPointers 53 | ifTrue: [ self isVariable 54 | ifTrue: [ self instSize > 0 ifTrue: [ 3 ] ifFalse: [ 2 ] ] 55 | ifFalse: [ self instSize > 0 ifTrue: [ 1 ] ifFalse: [ 0 ] ] 56 | ] 57 | ifFalse: [ self isWords ifTrue: [ 6 ] ifFalse: [ 8 ] ] 58 | ] 59 | ]. 60 | size2 := (self instSize + 1 \\ 64) bitAnd: 16r3F. 61 | 62 | compactClassIndex := self compactClassIndex. 63 | 64 | ^(size1 bitShift: 16) + (compactClassIndex bitShift: 11) + (instSpec bitShift: 7) + (size2 bitShift: 1) 65 | ] 66 | 67 | PCClassBuilder >> compactClassIndex 68 | [ 69 | ^ self compactClassIndexFor: name 70 | ] 71 | 72 | PCClassBuilder >> isCompiledMethod 73 | [ 74 | ^ formats includes: #compiledMethod 75 | ] 76 | 77 | PCClassBuilder >> beCompiledMethod 78 | [ 79 | ^ formats := #( compiledMethod variable bytes ) 80 | ] 81 | 82 | PCClassBuilder >> isWeak 83 | [ 84 | ^ formats includes: #weak 85 | ] 86 | 87 | PCClassBuilder >> beWeak 88 | [ 89 | ^ formats := #( weak variable pointers ) 90 | ] 91 | 92 | PCClassBuilder >> isPointers 93 | [ 94 | ^ formats includes: #pointers 95 | ] 96 | 97 | PCClassBuilder >> bePointers 98 | [ 99 | ^ formats := #( pointers ) 100 | ] 101 | 102 | PCClassBuilder >> isVariable 103 | [ 104 | ^ formats includes: #variable 105 | ] 106 | 107 | PCClassBuilder >> beVariable 108 | [ 109 | ^ formats := #( variable pointers ) 110 | ] 111 | 112 | PCClassBuilder >> isWords 113 | [ 114 | ^ formats includes: #words 115 | ] 116 | 117 | PCClassBuilder >> beWords 118 | [ 119 | ^ formats := #( variable words ) 120 | ] 121 | 122 | PCClassBuilder >> beBytes 123 | [ 124 | self isCompiledMethodClassIndex ifTrue: [ ^ self beCompiledMethod ]. 125 | ^ formats := #( variable bytes ) 126 | ] 127 | 128 | PCClassBuilder >> instSize 129 | [ 130 | ^ (superclass ifNil: [0] ifNotNil: [ superclass instSize ]) + instVarNames size 131 | ] 132 | 133 | PCClassBuilder >> classVariableNames 134 | [ 135 | ^ classVariablesNames 136 | ] 137 | 138 | PCClassBuilder >> superclass: aClass 139 | [ 140 | superclass := aClass 141 | ] 142 | 143 | PCClassBuilder >> name: aName 144 | [ 145 | name := aName 146 | ] 147 | 148 | PCClassBuilder >> instVarNames: anArray 149 | [ 150 | instVarNames := anArray 151 | ] 152 | 153 | PCClassBuilder >> classVariableNames: anArray 154 | [ 155 | classVariablesNames := anArray 156 | ] 157 | 158 | PCClassBuilder >> isCompiledMethodClassIndex 159 | [ 160 | ^ (self compactClassIndexFor: name) == (self compactClassIndexFor: #PCCompiledMethod) 161 | ] 162 | 163 | PCClassBuilder >> compactClassIndexFor: aClassName 164 | [ 165 | ^ #(#PCCompiledMethod 166 | nil 167 | #PCArray 168 | #PCLargeNegativeInteger 169 | #PCLargePositiveInteger 170 | #PCFloat 171 | nil 172 | #PCAssociation 173 | #PCPoint 174 | #PCRectangle 175 | #PCString 176 | #PCBlock 177 | nil 178 | #PCMethodContext 179 | nil 180 | nil "#PCBitmap" 181 | nil 182 | nil 183 | nil 184 | nil 185 | nil 186 | nil 187 | nil 188 | nil 189 | nil 190 | nil 191 | nil 192 | nil 193 | nil 194 | nil 195 | nil) indexOf: aClassName ifAbsent: [ 0 ] 196 | ] -------------------------------------------------------------------------------- /source/Kernel-Classes/PCMetaclass.hz: -------------------------------------------------------------------------------- 1 | PCMetaclass 2 | superclass: #PCBehavior; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#soleInstance ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Classes'. 7 | 8 | PCMetaclass >> initMethodDict: newMethodDict 9 | [ 10 | "Initialize myself with the given method dictionary. Create but do not initialize my soleInstance." 11 | superclass := PCClass. 12 | methodDict := newMethodDict. 13 | format := PCClass format. "all metaclasses have the same format as PClass" 14 | soleInstance := self basicNew 15 | ] 16 | 17 | PCMetaclass >> isMeta 18 | [ 19 | ^ true 20 | ] 21 | 22 | PCMetaclass >> name 23 | [ 24 | "Answer my name, either 'Metaclass' or the name of my class followed by ' class'." 25 | soleInstance ifNil: [ ^ 'Metaclass' ] ifNotNil: [ ^ soleInstance name , ' class' ] 26 | ] 27 | 28 | PCMetaclass >> new 29 | [ 30 | "Each metaclass should have exactly one instance." 31 | self cannotInstantiate 32 | ] 33 | 34 | PCMetaclass >> theNonMetaClass 35 | [ 36 | "Answer my only instance." 37 | ^ soleInstance 38 | ] 39 | 40 | PCMetaclass >> soleInstance: aClass 41 | [ 42 | soleInstance := aClass 43 | ] 44 | 45 | PCMetaclass class 46 | instanceVariables: #(). 47 | 48 | -------------------------------------------------------------------------------- /source/Kernel-Collections-Abstract/PCArrayedCollection.hz: -------------------------------------------------------------------------------- 1 | PCArrayedCollection 2 | superclass: #PCSequenceableCollection; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Collections-Abstract'. 7 | 8 | PCArrayedCollection >> add: newObject 9 | [ 10 | self shouldNotImplement 11 | ] 12 | 13 | PCArrayedCollection >> mergeFirst: first middle: middle last: last into: dst by: aBlock 14 | [ 15 | "Private! Merge the sorted ranges [first..middle] and [middle+1..last] of the receiver into the range [first..last] of dst." 16 | | i1 i2 val1 val2 out | 17 | i1 := first. 18 | i2 := middle + 1. 19 | val1 := self at: i1. 20 | val2 := self at: i2. 21 | out := first - 1. "will be pre-incremented" "select 'lower' half of the elements based on comparator" 22 | [ i1 <= middle and: [ i2 <= last ] ] 23 | whileTrue: [ 24 | (aBlock value: val2 value: val1) 25 | ifTrue: [ 26 | dst at: (out := out + 1) put: val2. 27 | i2 := i2 + 1. 28 | i2 <= last 29 | ifTrue: [ val2 := self at: i2 ] ] 30 | ifFalse: [ 31 | dst at: (out := out + 1) put: val1. 32 | val1 := self at: (i1 := i1 + 1) ] ]. "copy the remaining elements" 33 | i1 <= middle 34 | ifTrue: [ 35 | dst 36 | replaceFrom: out + 1 37 | to: last 38 | with: self 39 | startingAt: i1 ] 40 | ifFalse: [ 41 | dst 42 | replaceFrom: out + 1 43 | to: last 44 | with: self 45 | startingAt: i2 ] 46 | ] 47 | 48 | PCArrayedCollection >> mergeSortFrom: startIndex to: stopIndex by: aBlock 49 | [ 50 | "Sort the given range of indices using the mergesort algorithm. Mergesort is a worst-case O(N log N) sorting algorithm that usually does only half as many comparisons as heapsort or quicksort." 51 | "Details: recursively split the range to be sorted into two halves, mergesort each half, then merge the two halves together. An extra copy of the data is used as temporary storage and successive merge phases copy data back and forth between the receiver and this copy. The recursion is set up so that the final merge is performed into the receiver, resulting in the receiver being completely sorted." 52 | | temp | 53 | self size <= 1 54 | ifTrue: [ ^ self ]. "nothing to do" 55 | startIndex = stopIndex 56 | ifTrue: [ ^ self ]. 57 | (startIndex >= 1 and: [ startIndex < stopIndex ]) 58 | ifFalse: [ self error: 'bad start index' ]. 59 | stopIndex <= self size 60 | ifFalse: [ self error: 'bad stop index' ]. 61 | temp := self basicCopy. 62 | self 63 | mergeSortFrom: startIndex 64 | to: stopIndex 65 | src: temp 66 | dst: self 67 | by: aBlock 68 | ] 69 | 70 | PCArrayedCollection >> mergeSortFrom: first to: last src: src dst: dst by: aBlock 71 | [ 72 | "Private! Split the range to be sorted in half, sort each half, and merge the two half-ranges into dst." 73 | | middle | 74 | first = last 75 | ifTrue: [ ^ self ]. 76 | middle := (first + last) // 2. 77 | self 78 | mergeSortFrom: first 79 | to: middle 80 | src: dst 81 | dst: src 82 | by: aBlock. 83 | self 84 | mergeSortFrom: middle + 1 85 | to: last 86 | src: dst 87 | dst: src 88 | by: aBlock. 89 | src 90 | mergeFirst: first 91 | middle: middle 92 | last: last 93 | into: dst 94 | by: aBlock 95 | ] 96 | 97 | PCArrayedCollection >> size 98 | [ 99 | "Primitive. Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Primitive is specified here to override MSequenceableCollection size. Essential. See Object documentation whatIsAPrimitive. " 100 | 101 | ^ self basicSize 102 | ] 103 | 104 | PCArrayedCollection >> sort 105 | [ 106 | "Sort this array into ascending order using the '<' operator." 107 | self mergeSortFrom: 1 to: self size by: [ :el1 :el2 | el1 < el2 ] 108 | ] 109 | 110 | PCArrayedCollection >> sort: aBlock 111 | [ 112 | "Sort this array using the given comparision block. The block should take two arguments and return true if the first element should precede the second in the sorted result." 113 | self mergeSortFrom: 1 to: self size by: aBlock 114 | ] 115 | 116 | PCArrayedCollection class 117 | instanceVariables: #(). 118 | 119 | PCArrayedCollection class >> new 120 | [ 121 | "Answer a new instance of me, with size = 0." 122 | ^ self new: 0 123 | ] 124 | 125 | PCArrayedCollection class >> with: anObject 126 | [ 127 | "Answer a new instance of me, containing only anObject." 128 | | newCollection | 129 | newCollection := self new: 1. 130 | newCollection at: 1 put: anObject. 131 | ^ newCollection 132 | ] 133 | 134 | PCArrayedCollection class >> with: firstObject with: secondObject 135 | [ 136 | "Answer a new instance of me containing the two arguments as elements." 137 | | newCollection | 138 | newCollection := self new: 2. 139 | newCollection at: 1 put: firstObject. 140 | newCollection at: 2 put: secondObject. 141 | ^ newCollection 142 | ] 143 | 144 | PCArrayedCollection class >> with: firstObject with: secondObject with: thirdObject 145 | [ 146 | "Answer a new instance of me, containing the three arguments as elements." 147 | | newCollection | 148 | newCollection := self new: 3. 149 | newCollection at: 1 put: firstObject. 150 | newCollection at: 2 put: secondObject. 151 | newCollection at: 3 put: thirdObject. 152 | ^ newCollection 153 | ] 154 | 155 | -------------------------------------------------------------------------------- /source/Kernel-Collections-Abstract/PCCollection.hz: -------------------------------------------------------------------------------- 1 | PCCollection 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Collections-Abstract'. 7 | 8 | PCCollection >> add: newObject 9 | [ 10 | "Include newObject as one of my elements. Answer newObject. ArrayedCollections cannot respond to this message." 11 | self subclassResponsibility 12 | ] 13 | 14 | PCCollection >> asArray 15 | [ 16 | "Answer an Array whose elements are the elements of this collection. The order in which elements are added depends on the order in which this collection enumerates its elements. In the case of unordered collections, the ordering is not necessarily the same for multiple requests for the conversion." 17 | | result i | 18 | result := PCArray new: self size. 19 | i := 0. 20 | self do: [ :each | result at: (i := i + 1) put: each ]. 21 | ^ result 22 | ] 23 | 24 | PCCollection >> asByteArray 25 | [ 26 | "Answer a ByteArray containing my elements." 27 | | result i | 28 | result := PCByteArray new: self size. 29 | i := 0. 30 | self do: [ :each | result at: (i := i + 1) put: each ]. 31 | ^ result 32 | ] 33 | 34 | PCCollection >> asSet 35 | [ 36 | "Answer a Set whose elements are the unique elements of the receiver." 37 | | aSet | 38 | aSet := PCSet new: self size. 39 | self do: [ :each | aSet add: each ]. 40 | ^ aSet 41 | ] 42 | 43 | PCCollection >> collect: aBlock 44 | [ 45 | "Evaluate aBlock with each of the receiver's elements as the argument. 46 | Collect the resulting values into a collection like the receiver. Answer 47 | the new collection." 48 | | newCollection | 49 | newCollection := self species new. 50 | self do: [ :each | newCollection add: (aBlock value: each) ]. 51 | ^ newCollection 52 | ] 53 | 54 | PCCollection >> detect: aBlock ifNone: exceptionBlock 55 | [ 56 | "Evaluate aBlock with each of the receiver's elements as the argument. 57 | Answer the first element for which aBlock evaluates to true. If none 58 | evaluate to true, then evaluate the argument, exceptionBlock." 59 | self 60 | do: [ :each | 61 | (aBlock value: each) 62 | ifTrue: [ ^ each ] ]. 63 | ^ exceptionBlock value 64 | ] 65 | 66 | PCCollection >> do: aBlock 67 | [ 68 | "Evaluate aBlock with each of the receiver's elements as the argument." 69 | self subclassResponsibility 70 | ] 71 | 72 | PCCollection >> emptyCheck 73 | [ 74 | self isEmpty 75 | ifTrue: [ self errorEmptyCollection ] 76 | ] 77 | 78 | PCCollection >> errorEmptyCollection 79 | [ 80 | self error: 'this collection is empty' 81 | ] 82 | 83 | PCCollection >> errorNotFound 84 | [ 85 | self error: 'Object is not in the collection.' 86 | ] 87 | 88 | PCCollection >> includes: anObject 89 | [ 90 | "Answer whether anObject is one of the receiver's elements." 91 | self 92 | do: [ :each | 93 | anObject = each 94 | ifTrue: [ ^ true ] ]. 95 | ^ false 96 | ] 97 | 98 | PCCollection >> isEmpty 99 | [ 100 | "Answer whether the receiver contains any elements." 101 | ^ self size = 0 102 | ] 103 | 104 | PCCollection >> printOn: aStream 105 | [ 106 | "Refer to the comment in Object|printOn:." 107 | aStream nextPutAll: self class name , ' ('. 108 | self 109 | do: [ :element | 110 | element printOn: aStream. 111 | aStream space ]. 112 | aStream nextPut: $) 113 | ] 114 | 115 | PCCollection >> remove: oldObject 116 | [ 117 | "Remove oldObject as one of the receiver's elements. Answer oldObject 118 | unless no element is equal to oldObject, in which case, create an error 119 | notification." 120 | ^ self remove: oldObject ifAbsent: [ self errorNotFound ] 121 | ] 122 | 123 | PCCollection >> remove: oldObject ifAbsent: anExceptionBlock 124 | [ 125 | "Remove oldObject as one of the receiver's elements. If several of the 126 | elements are equal to oldObject, only one is removed. If no element is 127 | equal to oldObject, answer the result of evaluating anExceptionBlock. 128 | Otherwise, answer the argument, oldObject. SequenceableCollections 129 | cannot respond to this message." 130 | self subclassResponsibility 131 | ] 132 | 133 | PCCollection >> select: aBlock 134 | [ 135 | "Evaluate aBlock with each of the receiver's elements as the argument. 136 | Collect into a new collection like the receiver, only those elements for 137 | which aBlock evaluates to true. Answer the new collection." 138 | | newCollection | 139 | newCollection := self species new. 140 | self 141 | do: [ :each | 142 | (aBlock value: each) 143 | ifTrue: [ newCollection add: each ] ]. 144 | ^ newCollection 145 | ] 146 | 147 | PCCollection >> size 148 | [ 149 | "Answer how many elements the receiver contains." 150 | | count | 151 | count := 0. 152 | self do: [ :each | count := count + 1 ]. 153 | ^ count 154 | ] 155 | 156 | PCCollection >> sum 157 | [ 158 | "Answer the sum of the elements of this collection. If the collection is empty, answer zero." 159 | "Details: Use an arbitrary element of the collection as the initial value so this method will work for collections of any kind of object that understands + and -." 160 | | total seed | 161 | total := seed := self detect: [ :x | true ] ifNone: [ ^ 0 ]. 162 | self do: [ :el | total := total + el ]. 163 | ^ total - seed "subtract the seed value from the total" 164 | ] 165 | 166 | PCCollection class 167 | instanceVariables: #(). 168 | 169 | PCCollection class >> with: anObject 170 | [ 171 | "Answer an instance of me containing anObject." 172 | | newCollection | 173 | newCollection := self new. 174 | newCollection add: anObject. 175 | ^ newCollection 176 | ] 177 | 178 | PCCollection class >> with: firstObject with: secondObject 179 | [ 180 | "Answer an instance of me containing the two arguments as elements." 181 | | newCollection | 182 | newCollection := self new. 183 | newCollection add: firstObject. 184 | newCollection add: secondObject. 185 | ^ newCollection 186 | ] 187 | 188 | PCCollection class >> with: firstObject with: secondObject with: thirdObject 189 | [ 190 | "Answer an instance of me containing the three arguments as elements." 191 | | newCollection | 192 | newCollection := self new. 193 | newCollection add: firstObject. 194 | newCollection add: secondObject. 195 | newCollection add: thirdObject. 196 | ^ newCollection 197 | ] 198 | 199 | -------------------------------------------------------------------------------- /source/Kernel-Collections-Ordered/PCArray.hz: -------------------------------------------------------------------------------- 1 | PCArray 2 | superclass: #PCArrayedCollection; 3 | instanceSpecification: #(#variable #pointers #words ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Collections-Ordered'. 7 | 8 | PCArray >> asArray 9 | [ 10 | "Answer with the receiver itself." 11 | ^ self 12 | ] 13 | 14 | PCArray >> asDictionary 15 | [ 16 | | dictionary | 17 | dictionary := PCDictionary new. 18 | self do: [:each | dictionary add: each ]. 19 | ^ dictionary 20 | ] 21 | 22 | PCArray >> elementsExchangeIdentityWith: otherArray 23 | [ 24 | "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array." 25 | 26 | self primitiveFailed 27 | ] 28 | 29 | PCArray >> hash 30 | [ 31 | "Make sure that equal (=) arrays hash equally." 32 | self size = 0 33 | ifTrue: [ ^ 17171 ]. 34 | ^ (self at: 1) hash + (self at: self size) hash 35 | ] 36 | 37 | PCArray >> printOn: aStream 38 | [ 39 | aStream nextPutAll: '#('. 40 | self 41 | do: [ :each | 42 | each printOn: aStream. 43 | aStream space ]. 44 | aStream nextPut: $) 45 | ] 46 | 47 | PCArray >> replaceFrom: start to: stop with: replacement startingAt: repStart 48 | [ 49 | "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." 50 | 51 | super 52 | replaceFrom: start 53 | to: stop 54 | with: replacement 55 | startingAt: repStart 56 | ] 57 | 58 | PCArray class 59 | instanceVariables: #(). 60 | -------------------------------------------------------------------------------- /source/Kernel-Collections-Ordered/PCByteArray.hz: -------------------------------------------------------------------------------- 1 | PCByteArray 2 | superclass: #PCArrayedCollection; 3 | instanceSpecification: #(#variable #byte ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Collections-Ordered'. 7 | 8 | PCByteArray >> asByteArray 9 | [ 10 | ^ self 11 | ] 12 | 13 | PCByteArray >> asString 14 | [ 15 | "Answer the receiver converted to a String." 16 | ^ (PCString new: self size) 17 | replaceFrom: 1 18 | to: self size 19 | with: self 20 | startingAt: 1 21 | ] 22 | 23 | PCByteArray >> replaceFrom: startIndex to: stopIndex with: source startingAt: srcStartIndex 24 | [ 25 | "Primitive. Destructively replace the elements from startIndex to stopIndex in the receiver with the elements starting at srcStartIndex in the source collection. Answer the receiver. Range checks are performed in the primitive. Optional. See Object documentation whatIsAPrimitive." 26 | 27 | super 28 | replaceFrom: startIndex 29 | to: stopIndex 30 | with: source 31 | startingAt: srcStartIndex 32 | ] 33 | 34 | PCByteArray class 35 | instanceVariables: #(). 36 | 37 | -------------------------------------------------------------------------------- /source/Kernel-Collections-Ordered/PCInterval.hz: -------------------------------------------------------------------------------- 1 | PCInterval 2 | superclass: #PCSequenceableCollection; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#start #stop #step ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Collections-Ordered'. 7 | 8 | PCInterval >> = anInterval 9 | [ 10 | "Answer true if my species and anInterval species are equal, and 11 | if our starts, steps and sizes are equal." 12 | self species == anInterval species 13 | ifTrue: [ ^ start = anInterval first and: [ step = anInterval increment and: [ self size = anInterval size ] ] ] 14 | ifFalse: [ ^ false ] 15 | ] 16 | 17 | PCInterval >> add: newObject 18 | [ 19 | "Adding to an Interval is not allowed." 20 | self shouldNotImplement 21 | ] 22 | 23 | PCInterval >> at: anInteger 24 | [ 25 | "Answer the anInteger'th element." 26 | (anInteger >= 1 and: [ anInteger <= self size ]) 27 | ifTrue: [ ^ start + (step * (anInteger - 1)) ] 28 | ifFalse: [ self errorSubscriptBounds: anInteger ] 29 | ] 30 | 31 | PCInterval >> at: anInteger put: anObject 32 | [ 33 | "Storing into an Interval is not allowed." 34 | self error: 'you can not store into an interval' 35 | ] 36 | 37 | PCInterval >> collect: aBlock 38 | [ 39 | | nextValue result | 40 | result := self species new: self size. 41 | nextValue := start. 42 | 1 to: result size do: [ :i | 43 | result at: i put: (aBlock value: nextValue). 44 | nextValue := nextValue + step ]. 45 | ^ result 46 | ] 47 | 48 | PCInterval >> do: aBlock 49 | [ 50 | | aValue | 51 | aValue := start. 52 | step < 0 53 | ifTrue: [ 54 | [ stop <= aValue ] 55 | whileTrue: [ 56 | aBlock value: aValue. 57 | aValue := aValue + step ] ] 58 | ifFalse: [ 59 | [ stop >= aValue ] 60 | whileTrue: [ 61 | aBlock value: aValue. 62 | aValue := aValue + step ] ] 63 | ] 64 | 65 | PCInterval >> first 66 | [ 67 | "Refer to the comment in SequenceableCollection|first." 68 | ^ start 69 | ] 70 | 71 | PCInterval >> hash 72 | [ 73 | "Hash is reimplemented because = is implemented." 74 | ^ (((start hash bitShift: 2) bitOr: stop hash) bitShift: 1) bitOr: self size 75 | ] 76 | 77 | PCInterval >> includes: aNumber 78 | [ 79 | ^ aNumber between: self first and: self last 80 | ] 81 | 82 | PCInterval >> increment 83 | [ 84 | "Answer the receiver's interval increment." 85 | ^ step 86 | ] 87 | 88 | PCInterval >> last 89 | [ 90 | "Refer to the comment in SequenceableCollection|last." 91 | ^ stop - ((stop - start) \\ step) 92 | ] 93 | 94 | PCInterval >> printOn: aStream 95 | [ 96 | aStream nextPut: $(. 97 | start printOn: aStream. 98 | aStream nextPutAll: ' to: '. 99 | stop printOn: aStream. 100 | step ~= 1 101 | ifTrue: [ 102 | aStream nextPutAll: ' by: '. 103 | step printOn: aStream ]. 104 | aStream nextPut: $) 105 | ] 106 | 107 | PCInterval >> remove: newObject 108 | [ 109 | "Removing from an Interval is not allowed." 110 | self error: 'elements cannot be removed from an Interval' 111 | ] 112 | 113 | PCInterval >> setFrom: startInteger to: stopInteger by: stepInteger 114 | [ 115 | start := startInteger. 116 | stop := stopInteger. 117 | step := stepInteger 118 | ] 119 | 120 | PCInterval >> size 121 | [ 122 | step < 0 123 | ifTrue: [ 124 | start < stop 125 | ifTrue: [ ^ 0 ] 126 | ifFalse: [ ^ (stop - start) // step + 1 ] ] 127 | ifFalse: [ 128 | stop < start 129 | ifTrue: [ ^ 0 ] 130 | ifFalse: [ ^ (stop - start) // step + 1 ] ] 131 | ] 132 | 133 | PCInterval >> species 134 | [ 135 | ^ PCArray 136 | ] 137 | 138 | PCInterval class 139 | instanceVariables: #(). 140 | 141 | PCInterval class >> from: startInteger to: stopInteger 142 | [ 143 | "Answer an instance of me, starting at startNumber, ending at stopNumber, and with an interval increment of 1." 144 | ^ self basicNew setFrom: startInteger to: stopInteger by: 1 145 | ] 146 | 147 | PCInterval class >> from: startInteger to: stopInteger by: stepInteger 148 | [ 149 | "Answer an instance of me, starting at startNumber, ending at stopNumber, and with an interval increment of stepNumber." 150 | ^ self basicNew setFrom: startInteger to: stopInteger by: stepInteger 151 | ] 152 | 153 | -------------------------------------------------------------------------------- /source/Kernel-Collections-Ordered/PCSymbol.hz: -------------------------------------------------------------------------------- 1 | PCSymbol 2 | superclass: #PCString; 3 | instanceSpecification: #(#variable #byte ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Collections-Ordered'. 7 | 8 | PCSymbol >> = anObject 9 | [ 10 | ^ self == anObject 11 | ] 12 | 13 | PCSymbol >> asString 14 | [ 15 | "Answer a string containing my characters." 16 | | sz result | 17 | sz := self size. 18 | result := PCString new: sz. 19 | result 20 | replaceFrom: 1 21 | to: sz 22 | with: self 23 | startingAt: 1. 24 | ^ result 25 | ] 26 | 27 | PCSymbol >> asSymbol 28 | [ 29 | ^ self 30 | ] 31 | 32 | PCSymbol >> at: anInteger put: anObject 33 | [ 34 | "You cannot modify the receiver." 35 | self errorNoModification 36 | ] 37 | 38 | PCSymbol >> basicCopy 39 | [ 40 | "Answer myself because Symbols are unique." 41 | 42 | ] 43 | 44 | PCSymbol >> errorNoModification 45 | [ 46 | self error: 'Symbols can not be modified.' 47 | ] 48 | 49 | PCSymbol >> hash 50 | [ 51 | ^ self identityHash 52 | ] 53 | 54 | PCSymbol >> initFrom: aString 55 | [ 56 | "Warning! Use only to initialize new Symbols. Symbols are assumed to be immutable there after." 57 | self size = aString size 58 | ifFalse: [ self error: 'size mismatch' ]. 59 | super 60 | replaceFrom: 1 61 | to: self size 62 | with: aString 63 | startingAt: 1 64 | ] 65 | 66 | PCSymbol >> printOn: aStream 67 | [ 68 | aStream nextPutAll: self 69 | ] 70 | 71 | PCSymbol >> replaceFrom: start to: stop with: replacement startingAt: repStart 72 | [ 73 | self errorNoModification 74 | ] 75 | 76 | PCSymbol >> species 77 | [ 78 | ^ PCString 79 | ] 80 | 81 | PCSymbol class 82 | instanceVariables: #(). 83 | 84 | PCSymbol class >> new: size 85 | [ 86 | "Symbols are unique. You can create a new Symbol from a String using 'asSymbol'." 87 | self cannotInstantiate 88 | ] 89 | 90 | -------------------------------------------------------------------------------- /source/Kernel-Collections-Ordered/PCValueLink.hz: -------------------------------------------------------------------------------- 1 | PCValueLink 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#nextLink #value ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Collections-Ordered'. 7 | 8 | PCValueLink >> = anotherObject 9 | [ 10 | ^ self species == anotherObject species 11 | and: [ self value = anotherObject value and: [ self nextLink == anotherObject nextLink ] ] 12 | ] 13 | 14 | PCValueLink >> asLink 15 | [ 16 | ^ self 17 | ] 18 | 19 | PCValueLink >> hash 20 | [ 21 | ^ self value hash bitXor: nextLink identityHash 22 | ] 23 | 24 | PCValueLink >> nextLink 25 | [ 26 | ^ nextLink 27 | ] 28 | 29 | PCValueLink >> nextLink: aLink 30 | [ 31 | nextLink := aLink 32 | ] 33 | 34 | PCValueLink >> printOn: aStream 35 | [ 36 | aStream nextPutAll: 'ValueLink('. 37 | value printOn: aStream. 38 | aStream nextPut: $) 39 | ] 40 | 41 | PCValueLink >> value 42 | [ 43 | ^ value 44 | ] 45 | 46 | PCValueLink >> value: aValue 47 | [ 48 | value := aValue 49 | ] 50 | 51 | PCValueLink class 52 | instanceVariables: #(). 53 | 54 | PCValueLink class >> value: aValue 55 | [ 56 | ^ self new value: aValue 57 | ] 58 | 59 | -------------------------------------------------------------------------------- /source/Kernel-Collections-Unordered/PCAssociation.hz: -------------------------------------------------------------------------------- 1 | PCAssociation 2 | superclass: #PCMagnitude; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#key #value ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Collections-Unordered'. 7 | 8 | PCAssociation >> < aLookupKey 9 | [ 10 | "Sort by keys." 11 | ^ key < aLookupKey key 12 | ] 13 | 14 | PCAssociation >> = anAssociation 15 | [ 16 | "True if the receiver and argument have equal keys." 17 | self species = anAssociation species 18 | ifTrue: [ ^ key = anAssociation key ] 19 | ifFalse: [ ^ false ] 20 | ] 21 | 22 | PCAssociation >> hash 23 | [ 24 | "Hash is reimplemented because = is implemented." 25 | ^ key hash 26 | ] 27 | 28 | PCAssociation >> key 29 | [ 30 | ^ key 31 | ] 32 | 33 | PCAssociation >> key: anObject 34 | [ 35 | key := anObject 36 | ] 37 | 38 | PCAssociation >> key: aKey value: anObject 39 | [ 40 | key := aKey. 41 | value := anObject 42 | ] 43 | 44 | PCAssociation >> printOn: aStream 45 | [ 46 | "Print in the format (key->value)." 47 | aStream nextPut: $(. 48 | key printOn: aStream. 49 | aStream nextPutAll: '->'. 50 | value printOn: aStream. 51 | aStream nextPut: $) 52 | ] 53 | 54 | PCAssociation >> value 55 | [ 56 | ^ value 57 | ] 58 | 59 | PCAssociation >> value: anObject 60 | [ 61 | value := anObject 62 | ] 63 | 64 | PCAssociation class 65 | instanceVariables: #(). 66 | 67 | PCAssociation class >> key: newKey value: newValue 68 | [ 69 | "Answer a new Association with the given key and value." 70 | ^ self new key: newKey value: newValue 71 | ] 72 | 73 | -------------------------------------------------------------------------------- /source/Kernel-Collections-Unordered/PCSet.hz: -------------------------------------------------------------------------------- 1 | PCSet 2 | superclass: #PCCollection; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#tally #array ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Collections-Unordered'. 7 | 8 | PCSet >> = aSet 9 | [ 10 | (aSet isKindOf: PCSet) 11 | ifFalse: [ ^ false ]. 12 | self size = aSet size 13 | ifFalse: [ ^ false ]. 14 | self 15 | do: [ :each | 16 | (aSet includes: each) 17 | ifFalse: [ ^ false ] ]. 18 | ^ true 19 | ] 20 | 21 | PCSet >> add: newObject 22 | [ 23 | "Add an element. User error instead of halt. go 10/1/97 09:33" 24 | | index | 25 | newObject == nil 26 | ifTrue: [ self error: 'Sets cannot meaningfully contain nil as an element' ]. 27 | index := self findElementOrNil: newObject. 28 | (array at: index) == nil 29 | ifTrue: [ self atNewIndex: index put: newObject ]. 30 | ^ newObject 31 | ] 32 | 33 | PCSet >> asArray 34 | [ 35 | "Return an array whose elements are those of the receiver. " 36 | | s | 37 | s := PCWriteStream on: (PCArray new: self size). 38 | self do: [ :el | s nextPut: el ]. 39 | ^ s contents 40 | ] 41 | 42 | PCSet >> asSet 43 | [ 44 | ^ self 45 | ] 46 | 47 | PCSet >> atNewIndex: index put: anObject 48 | [ 49 | array at: index put: anObject. 50 | tally := tally + 1. 51 | self fullCheck 52 | ] 53 | 54 | PCSet >> collect: aBlock 55 | [ 56 | "Return a Set containing the result of evaluating aBlock for each element of this set." 57 | | newSet | 58 | tally = 0 59 | ifTrue: [ ^ PCSet new: 2 ]. 60 | newSet := PCSet new: self size. 61 | array 62 | do: [ :each | 63 | each == nil 64 | ifFalse: [ newSet add: (aBlock value: each) ] ]. 65 | ^ newSet 66 | ] 67 | 68 | PCSet >> copy 69 | [ 70 | ^ self basicCopy withArray: array basicCopy 71 | ] 72 | 73 | PCSet >> do: aBlock 74 | [ 75 | tally = 0 76 | ifTrue: [ ^ self ]. 77 | array 78 | do: [ :element | 79 | element == nil 80 | ifFalse: [ aBlock value: element ] ] 81 | ] 82 | 83 | PCSet >> findElementOrNil: anObject 84 | [ 85 | "Answer the index of a first slot containing either a nil (indicating an empty slot) or an element that matches the given object. Answer the index of that slot or zero. Fail if neither a match nor an empty slot is found." 86 | | index | 87 | index := self scanFor: anObject. 88 | index > 0 89 | ifTrue: [ ^ index ]. "Bad scene. Neither have we found a matching element 90 | nor even an empty slot. No hashed set is ever supposed to get 91 | completely full." 92 | self error: 'There is no free space in this set!' 93 | ] 94 | 95 | PCSet >> fixCollisionsFrom: index 96 | [ 97 | "The element at index has been removed and replaced by nil. 98 | This method moves forward from there, relocating any entries 99 | that had been placed below due to collisions with this one" 100 | | length oldIndex newIndex element | 101 | oldIndex := index. 102 | length := array size. 103 | [ 104 | oldIndex = length 105 | ifTrue: [ oldIndex := 1 ] 106 | ifFalse: [ oldIndex := oldIndex + 1 ]. 107 | (element := self keyAt: oldIndex) == nil ] 108 | whileFalse: [ 109 | newIndex := self findElementOrNil: element. 110 | oldIndex = newIndex 111 | ifFalse: [ self swap: oldIndex with: newIndex ] ] 112 | ] 113 | 114 | PCSet >> fullCheck 115 | [ 116 | "Keep array at least 1/4 free for decent hash behavior" 117 | array size - tally < (array size // 4 max: 1) 118 | ifTrue: [ self grow ] 119 | ] 120 | 121 | PCSet >> grow 122 | [ 123 | "Grow the elements array and reinsert the old elements." 124 | | oldElements | 125 | oldElements := array. 126 | array := PCArray new: array size + (array size max: 2). 127 | tally := 0. 128 | oldElements 129 | do: [ :each | 130 | each == nil 131 | ifFalse: [ self noCheckAdd: each ] ] 132 | ] 133 | 134 | PCSet >> includes: anObject 135 | [ 136 | ^ (array at: (self findElementOrNil: anObject)) ~~ nil 137 | ] 138 | 139 | PCSet >> init: n 140 | [ 141 | "Initialize array to an array size of n." 142 | array := PCArray new: n. 143 | tally := 0 144 | ] 145 | 146 | PCSet >> keyAt: index 147 | [ 148 | "May be overridden by subclasses so that fixCollisions will work" 149 | ^ array at: index 150 | ] 151 | 152 | PCSet >> noCheckAdd: anObject 153 | [ 154 | array at: (self findElementOrNil: anObject) put: anObject. 155 | tally := tally + 1 156 | ] 157 | 158 | PCSet >> remove: oldObject ifAbsent: aBlock 159 | [ 160 | | index | 161 | index := self findElementOrNil: oldObject. 162 | (array at: index) == nil 163 | ifTrue: [ ^ aBlock value ]. 164 | array at: index put: nil. 165 | tally := tally - 1. 166 | self fixCollisionsFrom: index. 167 | ^ oldObject 168 | ] 169 | 170 | PCSet >> scanFor: anObject 171 | [ 172 | "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 173 | | element start finish | 174 | start := anObject hash \\ array size + 1. 175 | finish := array size. "Search from (hash mod size) to the end." 176 | start to: finish do: [ :index | 177 | ((element := array at: index) == nil or: [ element = anObject ]) 178 | ifTrue: [ ^ index ] ]. "Search from 1 to where we started." 179 | 1 to: start - 1 do: [ :index | 180 | ((element := array at: index) == nil or: [ element = anObject ]) 181 | ifTrue: [ ^ index ] ]. 182 | ^ 0 "No match AND no empty slot" 183 | ] 184 | 185 | PCSet >> size 186 | [ 187 | ^ tally 188 | ] 189 | 190 | PCSet >> swap: oneIndex with: otherIndex 191 | [ 192 | "May be overridden by subclasses so that fixCollisions will work" 193 | array swap: oneIndex with: otherIndex 194 | ] 195 | 196 | PCSet >> withArray: anArray 197 | [ 198 | "private -- for use only in copy" 199 | array := anArray 200 | ] 201 | 202 | PCSet class 203 | instanceVariables: #(). 204 | 205 | PCSet class >> new 206 | [ 207 | ^ self new: 4 208 | ] 209 | 210 | PCSet class >> new: nElements 211 | [ 212 | "Create a Set large enough to hold nElements without growing." 213 | | initialSize | 214 | "make large enough size to hold nElements with some slop (see fullCheck)" 215 | nElements <= 0 216 | ifTrue: [ initialSize := 1 ] 217 | ifFalse: [ initialSize := (nElements + 1) * 4 // 3 ]. 218 | ^ self basicNew init: initialSize 219 | ] 220 | 221 | -------------------------------------------------------------------------------- /source/Kernel-Methods/PCBlock.hz: -------------------------------------------------------------------------------- 1 | PCBlock 2 | superclass: #PCObject; 3 | instanceSpecification: #(#variable #pointers #words ); 4 | instanceVariables: #(#outerContext #startpc #nargs ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Methods'. 7 | 8 | PCBlock >> asContext 9 | [ 10 | "Create a MethodContext that is ready to execute self. Assumes self takes no args (if it does the args will be nil)" 11 | ^ self asContextWithSender: nil 12 | ] 13 | 14 | PCBlock >> asContextWithSender: aContext 15 | [ 16 | "Inner private support method for evaluation. Do not use unless you know what you're doing." 17 | ^ (PCMethodContext newForMethod: outerContext method) 18 | setSender: aContext 19 | receiver: outerContext receiver 20 | method: outerContext method 21 | closure: self 22 | startpc: startpc; 23 | privRefresh 24 | ] 25 | 26 | PCBlock >> home 27 | [ 28 | ^ outerContext home 29 | ] 30 | 31 | PCBlock >> ifError: errorHandlerBlock 32 | [ 33 | "Evaluate the block represented by the receiver. If an error occurs the given handler block is evaluated. The handler block can be either a zero- or two-argument block; if the latter, then the error message and receiver are supplied to it as parameters. Answer the value returned by the handler block if the receiver gets an error." 34 | "Warning: The receiver should not contain an explicit return since that would leave an obsolete error handler hanging around." 35 | "Examples: 36 | [1 whatsUpDoc] ifError: [:err :rcvr | ^ 'huh?']. 37 | [1 whatsUpDoc] ifError: ['huh']. 38 | [1 / 0] ifError: [:err :rcvr | 39 | 'division by 0' = err 40 | ifTrue: [^ Float infinity] 41 | ifFalse: [self error: err]] 42 | " 43 | | activeProcess lastHandler val | 44 | activeProcess := Processor activeProcess. 45 | lastHandler := activeProcess errorHandler. 46 | activeProcess 47 | errorHandler: [ :aString :aReceiver | 48 | activeProcess errorHandler: lastHandler. 49 | errorHandlerBlock numArgs = 0 50 | ifTrue: [ ^ errorHandlerBlock value ]. 51 | ^ errorHandlerBlock value: aString value: aReceiver ]. 52 | val := self value. 53 | activeProcess errorHandler: lastHandler. 54 | ^ val 55 | ] 56 | 57 | PCBlock >> method 58 | [ 59 | ^ self home method 60 | ] 61 | 62 | PCBlock >> msecs 63 | [ 64 | "Answer the number of milliseconds it took to evaluate this block." 65 | | startMSecs | 66 | startMSecs := PCSystem milliseconds. 67 | self value. 68 | ^ PCSystem milliseconds - startMSecs 69 | ] 70 | 71 | PCBlock >> numArgs 72 | [ 73 | ^ nargs 74 | ] 75 | 76 | PCBlock >> numCopiedValues 77 | [ 78 | "Answer the number of copied values of the receiver. Since these are 79 | stored in the receiver's indexable fields this is the receiver's basic size. 80 | Primitive. Answer the number of indexable variables in the receiver. 81 | This value is the same as the largest legal subscript." 82 | 83 | ^ self basicSize 84 | ] 85 | 86 | PCBlock >> outerContext 87 | [ 88 | ^ outerContext 89 | ] 90 | 91 | PCBlock >> value 92 | [ 93 | "Evaluate this block without any arguments." 94 | 95 | ^ self valueWithArguments: #() 96 | ] 97 | 98 | PCBlock >> value: arg 99 | [ 100 | "Evaluate this block with one argument." 101 | 102 | ^ self valueWithArguments: (PCArray with: arg) 103 | ] 104 | 105 | PCBlock >> value: arg1 value: arg2 106 | [ 107 | "Evaluate this block with two arguments." 108 | 109 | ^ self valueWithArguments: (PCArray with: arg1 with: arg2) 110 | ] 111 | 112 | PCBlock >> valueWithArguments: anArray 113 | [ 114 | "Primitive. Evaluate the block represented by the receiver. The argument is an Array whose elements are the arguments for the block. Fail if the length of the Array is not the same as the the number of arguments that the block was expecting. Fail if the block is already being executed. Essential. See Object documentation whatIsAPrimitive." 115 | 116 | anArray size = nargs 117 | ifTrue: [ self error: 'Attempt to evaluate a block that is already being evaluated.' ] 118 | ifFalse: [ self error: 'This block requires ' , nargs printString , ' arguments.' ] 119 | ] 120 | 121 | PCBlock class 122 | instanceVariables: #(). 123 | 124 | -------------------------------------------------------------------------------- /source/Kernel-Methods/PCCompiledMethod.hz: -------------------------------------------------------------------------------- 1 | PCCompiledMethod 2 | superclass: #PCByteArray; 3 | instanceSpecification: #(#compiledMethod); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Methods'. 7 | 8 | PCCompiledMethod >> frameSize 9 | [ 10 | "Answer the size of temporary frame needed to run the receiver." 11 | "NOTE: Versions 2.7 and later use two sizes of contexts." 12 | (self header bitAnd: 16r20000) = 0 13 | ifTrue: [ ^ 16 ] 14 | ifFalse: [ ^ 56 ] 15 | ] 16 | 17 | PCCompiledMethod >> header 18 | [ 19 | "Answer the method header word containing information about the form of this method (e.g., number of literals) and the context needed to run it." 20 | ^ self objectAt: 1 21 | ] 22 | 23 | PCCompiledMethod >> initialPC 24 | [ 25 | "Answer the program counter for my first bytecode." 26 | ^ 4 * (self numLiterals + 1) + 1 27 | ] 28 | 29 | PCCompiledMethod >> isCompiledMethod 30 | [ 31 | ^ true 32 | ] 33 | 34 | PCCompiledMethod >> numLiterals 35 | [ 36 | "Answer the number of literals used by the receiver." 37 | ^ (self header bitShift: -9) bitAnd: 16rFF 38 | ] 39 | 40 | PCCompiledMethod >> numTemps 41 | [ 42 | "Answer the number of temporary variables used by this method." 43 | ^ (self header bitShift: -18) bitAnd: 16r3F 44 | ] 45 | 46 | PCCompiledMethod >> objectAt: index 47 | [ 48 | "Primitive. Answer the method header (if index = 1) or a literal (if index > 1) from the receiver. Essential. See Object documentation whatIsAPrimitive." 49 | 50 | self primitiveFailed 51 | ] 52 | 53 | PCCompiledMethod >> objectAt: index put: value 54 | [ 55 | "Primitive. Store the value argument into a literal in the receiver. An index of 2 corresponds to the first literal. Fails if the index is less than 2 or greater than the number of literals. Answer the value as the result. Normally only the compiler sends this message because only the compiler stores values in CompiledMethods. Essential. See Object documentation whatIsAPrimitive." 56 | 57 | self primitiveFailed 58 | ] 59 | 60 | PCCompiledMethod class 61 | instanceVariables: #(). 62 | 63 | -------------------------------------------------------------------------------- /source/Kernel-Methods/PCContext.hz: -------------------------------------------------------------------------------- 1 | PCContext 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#sender #pc #stackp ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Methods'. 7 | 8 | PCContext >> blockCopy: numArgs 9 | [ 10 | "Primitive. Distinguish a block of code from its enclosing method by creating a new BlockContext for that block. The compiler inserts into all methods that contain blocks the bytecodes to send the message blockCopy:. Do not use blockCopy: in code that you write! Only the compiler can decide to send the message blockCopy:. Fail if numArgs is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." 11 | 12 | ^ (PCBlock newForMethod: self home method) home: self home startpc: pc + 2 nargs: numArgs 13 | ] 14 | 15 | PCContext >> isContextPart 16 | [ 17 | ^ true 18 | ] 19 | 20 | PCContext >> sender 21 | [ 22 | "Answer the context that sent the message that created the receiver." 23 | ^ sender 24 | ] 25 | 26 | PCContext class 27 | instanceVariables: #(). 28 | 29 | PCContext class >> newForMethod: aMethod 30 | [ 31 | "This is the only method for creating new contexts, other than by using the clone primitive. Any other attempts, such as inherited methods like shallowCopy, should be avoided or must at least be rewritten to determine the proper size for the method that will use this context. This is because asking a context its size (even basicSize!) will not return the actual object size but only the number of fields currently accessible, as determined by stackp." 32 | ^ super basicNew: aMethod frameSize 33 | ] 34 | 35 | -------------------------------------------------------------------------------- /source/Kernel-Methods/PCMessage.hz: -------------------------------------------------------------------------------- 1 | PCMessage 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#selector #arguments #lookupClass ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Methods'. 7 | 8 | PCMessage >> arguments 9 | [ 10 | "Answer the message arguments array." 11 | ^ arguments 12 | ] 13 | 14 | PCMessage >> lookupClass 15 | [ 16 | "Answer the message lookupClass." 17 | ^ lookupClass 18 | ] 19 | 20 | PCMessage >> printOn: aStream 21 | [ 22 | "Refer to the comment in Object|printOn:." 23 | super printOn: aStream. 24 | aStream 25 | nextPutAll: ' selector: ' , selector printString; 26 | nextPutAll: ' args: ' , arguments printString 27 | ] 28 | 29 | PCMessage >> selector 30 | [ 31 | "Answer the message selector." 32 | ^ selector 33 | ] 34 | 35 | PCMessage >> sentTo: anObject 36 | [ 37 | "Answer the result of sending this message to the given object." 38 | lookupClass == nil 39 | ifTrue: [ ^ anObject perform: selector withArguments: arguments ] 40 | ifFalse: [ ^ anObject perform: selector withArguments: arguments inSuperclass: lookupClass] 41 | ] 42 | 43 | PCMessage class 44 | instanceVariables: #(). 45 | -------------------------------------------------------------------------------- /source/Kernel-Methods/PCMethodContext.hz: -------------------------------------------------------------------------------- 1 | PCMethodContext 2 | superclass: #PCContext; 3 | instanceSpecification: #(#variable #pointers #words ); 4 | instanceVariables: #(#method #closureOrNil #receiver ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Methods'. 7 | 8 | PCMethodContext >> asContext 9 | [ 10 | ^ self 11 | ] 12 | 13 | PCMethodContext >> home 14 | [ 15 | "Answer the context in which the receiver was defined." 16 | closureOrNil == nil 17 | ifTrue: [ ^ self ]. 18 | ^ closureOrNil outerContext home 19 | ] 20 | 21 | PCMethodContext >> method 22 | [ 23 | ^ method 24 | ] 25 | 26 | PCMethodContext >> privRefresh 27 | [ 28 | "Reinitialize the receiver so that it is in the state it was at its creation." 29 | closureOrNil 30 | ifNotNil: [ 31 | pc := closureOrNil startpc. 32 | self stackp: closureOrNil numArgs + closureOrNil numCopiedValues. 33 | 1 to: closureOrNil numCopiedValues do: [ :i | self tempAt: closureOrNil numArgs + i put: (closureOrNil at: i) ] ] 34 | ifNil: [ 35 | pc := method initialPC. 36 | self stackp: method numTemps. 37 | method numArgs + 1 to: method numTemps do: [ :i | self tempAt: i put: nil ] ] 38 | ] 39 | 40 | PCMethodContext >> removeSelf 41 | [ 42 | "Nil the receiver pointer and answer its former value." 43 | | result | 44 | result := receiver. 45 | receiver := nil. 46 | ^ result 47 | ] 48 | 49 | PCMethodContext >> setSender: s receiver: r method: m closure: c startpc: startpc 50 | [ 51 | "Create the receiver's initial state." 52 | sender := s. 53 | receiver := r. 54 | method := m. 55 | closureOrNil := c. 56 | pc := startpc. 57 | stackp := 0 58 | ] 59 | 60 | PCMethodContext >> stackp: newStackp 61 | [ 62 | "Storing into the stack pointer is a potentially dangerous thing. 63 | This primitive stores nil into any cells that become accessible as a result, 64 | and it performs the entire operation atomically." 65 | "Once this primitive is implemented, failure code should cause an error" 66 | 67 | self error: 'stackp store failure' 68 | ] 69 | 70 | PCMethodContext >> tempAt: index put: value 71 | [ 72 | "Store the argument, value, as the temporary variable whose index is the 73 | argument, index. Primitive. Assumes receiver is indexable. Answer the 74 | value of an indexable element in the receiver. Fail if the argument index 75 | is not an Integer or is out of bounds. Essential. See Object documentation 76 | whatIsAPrimitive. Override the default at:put: primitive to give latitude to 77 | the VM in context management." 78 | 79 | 80 | ] 81 | 82 | PCMethodContext class 83 | instanceVariables: #(). 84 | 85 | -------------------------------------------------------------------------------- /source/Kernel-Methods/PCMethodDictionary.hz: -------------------------------------------------------------------------------- 1 | PCMethodDictionary 2 | superclass: #PCDictionary; 3 | instanceSpecification: #(#variable #pointers #words ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Methods'. 7 | 8 | PCMethodDictionary >> add: anAssociation 9 | [ 10 | ^ self at: anAssociation key put: anAssociation value 11 | ] 12 | 13 | PCMethodDictionary >> associationsDo: aBlock 14 | [ 15 | | key | 16 | tally = 0 17 | ifTrue: [ ^ self ]. 18 | 1 to: self basicSize do: [ :i | (key := self basicAt: i) ifNotNil: [ aBlock value: key -> (array at: i) ] ] 19 | ] 20 | 21 | PCMethodDictionary >> at: key ifAbsent: aBlock 22 | [ 23 | | index | 24 | index := self findElementOrNil: key. 25 | (self basicAt: index) == nil 26 | ifTrue: [ ^ aBlock value ]. 27 | ^ array at: index 28 | ] 29 | 30 | PCMethodDictionary >> at: key put: value 31 | [ 32 | "Set the value at key to be value." 33 | | index | 34 | index := self findElementOrNil: key. 35 | (self basicAt: index) == nil 36 | ifTrue: [ 37 | tally := tally + 1. 38 | self basicAt: index put: key ]. 39 | array at: index put: value. 40 | self fullCheck. 41 | ^ value 42 | ] 43 | 44 | PCMethodDictionary >> copy 45 | [ 46 | "Copy my values array." 47 | ^ self basicCopy withArray: array basicCopy 48 | ] 49 | 50 | PCMethodDictionary >> do: aBlock 51 | [ 52 | tally = 0 53 | ifTrue: [ ^ self ]. 54 | 1 to: self basicSize do: [ :i | (self basicAt: i) ifNotNil: [ aBlock value: (array at: i) ] ] 55 | ] 56 | 57 | PCMethodDictionary >> grow 58 | [ 59 | | newSelf key | 60 | newSelf := self species new: self basicSize. "This will double the size" 61 | 1 to: self basicSize do: [ :i | 62 | key := self basicAt: i. 63 | key == nil 64 | ifFalse: [ newSelf at: key put: (array at: i) ] ]. 65 | self become: newSelf 66 | ] 67 | 68 | PCMethodDictionary >> includesKey: aSymbol 69 | [ 70 | "This override assumes that pointsTo is a fast primitive." 71 | ^ super pointsTo: aSymbol 72 | ] 73 | 74 | PCMethodDictionary >> keyAt: index 75 | [ 76 | ^ self basicAt: index 77 | ] 78 | 79 | PCMethodDictionary >> keyAtIdentityValue: value ifAbsent: exceptionBlock 80 | [ 81 | "Answer the key whose value equals the argument, value. If there is none, answer the result of evaluating exceptionBlock." 82 | | k | 83 | 1 to: self basicSize do: [ :i | 84 | value == (array at: i) 85 | ifTrue: [ (k := self basicAt: i) ifNotNil: [ ^ k ] ] ]. 86 | ^ exceptionBlock value 87 | ] 88 | 89 | PCMethodDictionary >> keysDo: aBlock 90 | [ 91 | | key | 92 | tally = 0 93 | ifTrue: [ ^ self ]. 94 | 1 to: self basicSize do: [ :i | (key := self basicAt: i) ifNotNil: [ aBlock value: key ] ] 95 | ] 96 | 97 | PCMethodDictionary >> removeKey: key ifAbsent: errorBlock 98 | [ 99 | "Pharo Candle does not support method removal." 100 | self shouldNotImplement 101 | ] 102 | 103 | PCMethodDictionary >> scanFor: anObject 104 | [ 105 | "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 106 | | element start finish | 107 | start := anObject basicIdentityHash \\ array size + 1. 108 | finish := array size. "Search from (hash mod size) to the end." 109 | start to: finish do: [ :index | 110 | ((element := self basicAt: index) == nil or: [ element == anObject ]) 111 | ifTrue: [ ^ index ] ]. "Search from 1 to where we started." 112 | 1 to: start - 1 do: [ :index | 113 | ((element := self basicAt: index) == nil or: [ element == anObject ]) 114 | ifTrue: [ ^ index ] ]. 115 | ^ 0 "No match AND no empty slot" 116 | ] 117 | 118 | PCMethodDictionary >> swap: oneIndex with: otherIndex 119 | [ 120 | | element | 121 | element := self basicAt: oneIndex. 122 | self basicAt: oneIndex put: (self basicAt: otherIndex). 123 | self basicAt: otherIndex put: element. 124 | super swap: oneIndex with: otherIndex 125 | ] 126 | 127 | PCMethodDictionary class 128 | instanceVariables: #(). 129 | 130 | PCMethodDictionary class >> new: nElements 131 | [ 132 | "Create a Dictionary large enough to hold nElements without growing." 133 | "NOTE: The basic size MUST be a power of 2. It is VITAL (see grow) that size gets doubled if nElements is a power of 2." 134 | | size | 135 | size := 1 bitShift: nElements highBit. 136 | ^ (self basicNew: size) init: size 137 | ] 138 | 139 | -------------------------------------------------------------------------------- /source/Kernel-Numeric/PCCharacter.hz: -------------------------------------------------------------------------------- 1 | PCCharacter 2 | superclass: #PCMagnitude; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#value ); 5 | classVariables: #(#CharacterTable ); 6 | package: #'PharoCandle-Kernel-Numeric'. 7 | 8 | 9 | 10 | PCCharacter >> setValue: newValue 11 | [ 12 | value ifNotNil:[ ^ self error:'Characters are immutable' ]. 13 | value := newValue. 14 | ] 15 | PCCharacter >> < aCharacter 16 | [ 17 | "Answer true if my value is less than the given character's value." 18 | ^ self asciiValue < aCharacter asciiValue 19 | ] 20 | 21 | PCCharacter >> = aCharacter 22 | [ 23 | "Primitive. Answer true if the receiver and the argument are the same object (have the same object pointer) and false otherwise. Optional. See Object documentation whatIsAPrimitive." 24 | 25 | ^ self == aCharacter 26 | ] 27 | 28 | PCCharacter >> > aCharacter 29 | [ 30 | "Answer true if my value is greater than the given character's value." 31 | ^ self asciiValue > aCharacter asciiValue 32 | ] 33 | 34 | PCCharacter >> asCharacter 35 | [ 36 | "Answer the receiver itself." 37 | ^ self 38 | ] 39 | 40 | PCCharacter >> asInteger 41 | [ 42 | "Answer my ASCII value." 43 | ^ value 44 | ] 45 | 46 | PCCharacter >> asLowercase 47 | [ 48 | "If I am uppercase, answer the matching lowercase Character. Otherwise, answer myself." 49 | (65 <= value and: [ value <= 90 ]) 50 | ifTrue: [ ^ (value + 32) asCharacter ] 51 | ifFalse: [ ^ self ] "self isUppercase" 52 | ] 53 | 54 | PCCharacter >> asString 55 | [ 56 | ^ PCString with: self 57 | ] 58 | 59 | PCCharacter >> asUppercase 60 | [ 61 | "If the receiver is lowercase, answer its matching uppercase Character." 62 | (97 <= value and: [ value <= 122 ]) 63 | ifTrue: [ ^ (value - 32) asCharacter ] 64 | ifFalse: [ ^ self ] "self isLowercase" 65 | ] 66 | 67 | PCCharacter >> asciiValue 68 | [ 69 | "Answer the value of the receiver that represents its ascii encoding." 70 | ^ value 71 | ] 72 | 73 | PCCharacter >> basicCopy 74 | [ 75 | "Answer myself because Characters are unique." 76 | ^ self 77 | ] 78 | 79 | PCCharacter >> digitValue 80 | [ 81 | "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and -1 otherwise. This is used to parse literal numbers of radix 2-36." 82 | value <= $9 asciiValue 83 | ifTrue: [ ^ value - $0 asciiValue ]. 84 | value >= $A asciiValue 85 | ifTrue: [ 86 | value <= $Z asciiValue 87 | ifTrue: [ ^ value - $A asciiValue + 10 ] ]. 88 | ^ -1 89 | ] 90 | 91 | PCCharacter >> hash 92 | [ 93 | "My hash is my value." 94 | ^ value 95 | ] 96 | 97 | PCCharacter >> isDigit 98 | [ 99 | "Answer whether the receiver is a digit." 100 | ^ value >= 48 and: [ value <= 57 ] 101 | ] 102 | 103 | PCCharacter >> isLetter 104 | [ 105 | "Answer whether the receiver is a letter." 106 | ^ (65 <= value and: [ value <= 90 ]) or: [ 97 <= value and: [ value <= 122 ] ] 107 | ] 108 | 109 | PCCharacter >> isSpecial 110 | [ 111 | "Answer whether the receiver is one of the special characters" 112 | ^ '+/\*~<>=@%|&?!' includes: self 113 | ] 114 | 115 | PCCharacter >> isUppercase 116 | [ 117 | "Answer whether the receiver is an uppercase letter." 118 | ^ 65 <= value and: [ value <= 90 ] 119 | ] 120 | 121 | PCCharacter >> isVowel 122 | [ 123 | "Answer true if the receiver is one of the vowels AEIOU (either upper- or lowercase)." 124 | ^ 'AEIOU' includes: self asUppercase 125 | ] 126 | 127 | PCCharacter >> printOn: aStream 128 | [ 129 | aStream nextPut: $$. 130 | aStream nextPut: self 131 | ] 132 | 133 | PCCharacter >> to: other 134 | [ 135 | "Answer with a collection of all characters in the given ASCII range. For example, $a to: $z" 136 | ^ (self asciiValue to: other asciiValue) collect: [ :i | i asCharacter ] 137 | ] 138 | 139 | PCCharacter >> tokenish 140 | [ 141 | "Answer true if the receiver is a valid token-character--that is, a letter, digit, or colon." 142 | ^ self isLetter or: [ self isDigit or: [ self = $: ] ] 143 | ] 144 | 145 | PCCharacter class 146 | instanceVariables: #(). 147 | 148 | PCCharacter class >> initialize 149 | [ 150 | "Create the table of DigitsValues." 151 | "self initialize" 152 | 153 | CharacterTable ifNil: [ 154 | "Initialize only once to ensure that byte characters are unique" 155 | CharacterTable := PCArray new: 256. 156 | 1 to: 256 do: [:i | CharacterTable at: i put: (self basicNew setValue: i - 1)]]. 157 | ] 158 | 159 | PCCharacter class >> asciiValue: anInteger 160 | [ 161 | "Answer the Character whose ASCII value is anInteger." 162 | ^ CharacterTable at: anInteger + 1 163 | ] 164 | 165 | PCCharacter class >> cr 166 | [ 167 | "Answer the Character representing a carriage return." 168 | ^ 13 asCharacter 169 | ] 170 | 171 | PCCharacter class >> digitValue: x 172 | [ 173 | "Answer the Character whose digit value is x. For example, answer $9 for x=9, $0 for x=0, $A for x=10, $Z for x=35." 174 | | i | 175 | i := x asInteger. 176 | ^ CharacterTable 177 | at: 178 | (i < 10 179 | ifTrue: [ 48 + i ] 180 | ifFalse: [ 55 + i ]) + 1 181 | ] 182 | 183 | PCCharacter class >> lf 184 | [ 185 | "Answer the Character representing a linefeed." 186 | ^ 10 asCharacter 187 | ] 188 | 189 | PCCharacter class >> new 190 | [ 191 | "There are 256 unique Characters; creating new ones is not allowed." 192 | self cannotInstantiate 193 | ] 194 | 195 | PCCharacter class >> setCharacterTable: aCharacterTable 196 | [ 197 | CharacterTable := aCharacterTable 198 | ] 199 | 200 | PCCharacter class >> space 201 | [ 202 | "Answer the Character representing a space." 203 | ^ 32 asCharacter 204 | ] 205 | 206 | PCCharacter class >> tab 207 | [ 208 | "Answer the Character representing a tab." 209 | ^ 9 asCharacter 210 | ] 211 | 212 | PCCharacter class >> value: anInteger 213 | [ 214 | "Answer the MCharacter whose ascii value is anInteger." 215 | ^ CharacterTable at: anInteger + 1 216 | ] 217 | 218 | -------------------------------------------------------------------------------- /source/Kernel-Numeric/PCLargeNegativeInteger.hz: -------------------------------------------------------------------------------- 1 | PCLargeNegativeInteger 2 | superclass: #PCLargePositiveInteger; 3 | instanceSpecification: #(#variable #byte ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Numeric'. 7 | 8 | PCLargeNegativeInteger >> abs 9 | [ 10 | ^ self negated 11 | ] 12 | 13 | PCLargeNegativeInteger >> negated 14 | [ 15 | ^ self copyto: (PCLargePositiveInteger new: self digitLength) 16 | ] 17 | 18 | PCLargeNegativeInteger >> negative 19 | [ 20 | "Answer whether the receiver is mathematically negative." 21 | ^ true 22 | ] 23 | 24 | PCLargeNegativeInteger >> normalize 25 | [ 26 | "Check for leading zeroes and return shortened copy if so" 27 | | sLen val len oldLen minVal | 28 | "First establish len = significant length" 29 | len := oldLen := self digitLength. 30 | [ 31 | len = 0 32 | ifTrue: [ ^ 0 ]. 33 | (self digitAt: len) = 0 ] whileTrue: [ len := len - 1 ]. "Now check if in SmallInteger range" 34 | sLen := 4. "SmallInteger minVal digitLength" 35 | len <= sLen 36 | ifTrue: [ 37 | minVal := PCSmallInteger minVal. 38 | (len < sLen or: [ (self digitAt: sLen) < minVal lastDigit ]) 39 | ifTrue: [ 40 | "If high digit less, then can be small" 41 | val := 0. 42 | len to: 1 by: -1 do: [ :i | val := val * 256 - (self digitAt: i) ]. 43 | ^ val ]. 44 | 1 to: sLen do: [ :i "If all digits same, then = minVal" | 45 | (self digitAt: i) = (minVal digitAt: i) 46 | ifFalse: [ 47 | "Not so; return self shortened" 48 | len < oldLen 49 | ifTrue: [ ^ self growto: len ] 50 | ifFalse: [ ^ self ] ] ]. 51 | ^ minVal ]. "Return self, or a shortened copy" 52 | len < oldLen 53 | ifTrue: [ ^ self growto: len ] 54 | ifFalse: [ ^ self ] 55 | ] 56 | 57 | PCLargeNegativeInteger >> printOn: aStream base: b 58 | [ 59 | "Refer to the comment in Integer|printOn:base:." 60 | aStream nextPut: $-. 61 | super printOn: aStream base: b 62 | ] 63 | 64 | PCLargeNegativeInteger >> sign 65 | [ 66 | "Optimization. Answer -1 since receiver is less than 0." 67 | ^ -1 68 | ] 69 | 70 | PCLargeNegativeInteger class 71 | instanceVariables: #(). 72 | 73 | -------------------------------------------------------------------------------- /source/Kernel-Numeric/PCMagnitude.hz: -------------------------------------------------------------------------------- 1 | PCMagnitude 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Numeric'. 7 | 8 | PCMagnitude >> < aMagnitude 9 | [ 10 | "Answer whether the receiver is less than the argument." 11 | ^ self subclassResponsibility 12 | ] 13 | 14 | PCMagnitude >> <= aMagnitude 15 | [ 16 | "Answer whether the receiver is less than or equal to the argument." 17 | ^ (self > aMagnitude) not 18 | ] 19 | 20 | PCMagnitude >> = aMagnitude 21 | [ 22 | "Compare the receiver with the argument and answer with true if the 23 | receiver is equal to the argument. Otherwise answer false." 24 | ^ self subclassResponsibility 25 | ] 26 | 27 | PCMagnitude >> > aMagnitude 28 | [ 29 | "Answer whether the receiver is greater than the argument." 30 | ^ aMagnitude < self 31 | ] 32 | 33 | PCMagnitude >> >= aMagnitude 34 | [ 35 | "Answer whether the receiver is greater than or equal to the argument." 36 | ^ (self < aMagnitude) not 37 | ] 38 | 39 | PCMagnitude >> between: min and: max 40 | [ 41 | "Answer whether the receiver is less than or equal to the argument, max, 42 | and greater than or equal to the argument, min." 43 | ^ self >= min and: [ self <= max ] 44 | ] 45 | 46 | PCMagnitude >> hash 47 | [ 48 | "Hash must be redefined whenever = is redefined." 49 | ^ self subclassResponsibility 50 | ] 51 | 52 | PCMagnitude >> max: aMagnitude 53 | [ 54 | "Answer the receiver or the argument, whichever has the greater 55 | magnitude." 56 | self > aMagnitude 57 | ifTrue: [ ^ self ] 58 | ifFalse: [ ^ aMagnitude ] 59 | ] 60 | 61 | PCMagnitude >> min: aMagnitude 62 | [ 63 | "Answer the receiver or the argument, whichever has the lesser 64 | magnitude." 65 | self < aMagnitude 66 | ifTrue: [ ^ self ] 67 | ifFalse: [ ^ aMagnitude ] 68 | ] 69 | 70 | PCMagnitude class 71 | instanceVariables: #(). 72 | 73 | -------------------------------------------------------------------------------- /source/Kernel-Objects/PCFalse.hz: -------------------------------------------------------------------------------- 1 | PCFalse 2 | superclass: #PCTrue; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Objects'. 7 | 8 | PCFalse >> & aBoolean 9 | [ 10 | "Answer true if both the receiver AND the argument are true. Unlike and:, the argument is always evaluted." 11 | ^ false 12 | ] 13 | 14 | PCFalse >> and: alternativeBlock 15 | [ 16 | "Answer true if both the receiver AND the result of evaluating the given block are true. Only evaluate the given block if the receiver is true." 17 | ^ false 18 | ] 19 | 20 | PCFalse >> ifFalse: falseBlock 21 | [ 22 | "If the receiver is false, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because the expression is compiled in-line." 23 | ^ falseBlock value 24 | ] 25 | 26 | PCFalse >> ifTrue: trueBlock 27 | [ 28 | "If the receiver is true, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the true is not a boolean. Execution does not actually reach here because the expression is compiled in-line." 29 | ^ nil 30 | ] 31 | 32 | PCFalse >> ifTrue: trueBlock ifFalse: falseBlock 33 | [ 34 | "If the receiver is true, answer the result of evaluating trueBlock. Otherwise, answer the result of evaluating falseBlock. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because this message is compiled in-line." 35 | ^ falseBlock value 36 | ] 37 | 38 | PCFalse >> not 39 | [ 40 | "Answer the negation of the receiver." 41 | ^ true 42 | ] 43 | 44 | PCFalse >> or: alternativeBlock 45 | [ 46 | "Answer true if either the receiver OR the argument are true. Only evaluate the given block if the receiver is false." 47 | ^ alternativeBlock value 48 | ] 49 | 50 | PCFalse >> printOn: aStream 51 | [ 52 | aStream nextPutAll: 'false' 53 | ] 54 | 55 | PCFalse >> | aBoolean 56 | [ 57 | "Answer true if either the receiver OR the argument are true. Unlike or:, the argument is always evaluted." 58 | ^ aBoolean 59 | ] 60 | 61 | PCFalse class 62 | instanceVariables: #(). 63 | -------------------------------------------------------------------------------- /source/Kernel-Objects/PCTrue.hz: -------------------------------------------------------------------------------- 1 | PCTrue 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Objects'. 7 | 8 | PCTrue >> & alternativeObject 9 | [ 10 | "Answer true if both the receiver AND the argument are true. Unlike and:, the argument is always evaluted." 11 | ^ alternativeObject 12 | ] 13 | 14 | PCTrue >> and: alternativeBlock 15 | [ 16 | "Answer true if both the receiver AND the result of evaluating the given block are true. Only evaluate the given block if the receiver is true." 17 | ^ alternativeBlock value 18 | ] 19 | 20 | PCTrue >> basicCopy 21 | [ 22 | "There is the only one instance of me, so answer myself." 23 | ^ self 24 | ] 25 | 26 | PCTrue >> ifFalse: falseBlock 27 | [ 28 | "If the receiver is false, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because the expression is compiled in-line." 29 | ^ nil 30 | ] 31 | 32 | PCTrue >> ifTrue: trueBlock 33 | [ 34 | "If the receiver is true, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the true is not a boolean. Execution does not actually reach here because the expression is compiled in-line." 35 | ^ trueBlock value 36 | ] 37 | 38 | PCTrue >> ifTrue: trueBlock ifFalse: falseBlock 39 | [ 40 | "If the receiver is true, answer the result of evaluating trueBlock. Otherwise, answer the result of evaluating falseBlock. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because this message is compiled in-line." 41 | ^ trueBlock value 42 | ] 43 | 44 | PCTrue >> not 45 | [ 46 | "Answer the negation of the receiver." 47 | ^ false 48 | ] 49 | 50 | PCTrue >> or: alternativeBlock 51 | [ 52 | "Answer true if either the receiver OR the argument are true. Only evaluate the given block if the receiver is false." 53 | ^ true 54 | ] 55 | 56 | PCTrue >> printOn: aStream 57 | [ 58 | aStream nextPutAll: 'true' 59 | ] 60 | 61 | PCTrue >> | aBoolean 62 | [ 63 | "Answer true if either the receiver OR the argument are true. Unlike or:, the argument is always evaluted." 64 | ^ true 65 | ] 66 | 67 | PCTrue class 68 | instanceVariables: #(). 69 | 70 | PCTrue class >> new 71 | [ 72 | "There is a single unique instance of each boolean." 73 | self cannotInstantiate 74 | ] 75 | 76 | -------------------------------------------------------------------------------- /source/Kernel-Objects/PCUndefinedObject.hz: -------------------------------------------------------------------------------- 1 | PCUndefinedObject 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Objects'. 7 | 8 | PCUndefinedObject >> basicCopy 9 | [ 10 | "There is the only one instance of me, so answer myself." 11 | ^ self 12 | ] 13 | 14 | PCUndefinedObject >> ifNil: aBlock 15 | [ 16 | "A convenient test, in conjunction with Object ifNil:" 17 | ^ aBlock value 18 | ] 19 | 20 | PCUndefinedObject >> ifNil: nilBlock ifNotNil: ifNotNilBlock 21 | [ 22 | "Evaluate the block for nil because I'm == nil" 23 | ^ nilBlock value 24 | ] 25 | 26 | PCUndefinedObject >> ifNotNil: aBlock 27 | [ 28 | "A convenient test, in conjunction with Object ifNotNil:" 29 | ^ self 30 | ] 31 | 32 | PCUndefinedObject >> isNil 33 | [ 34 | "Answer true if the receiver is nil." 35 | ^ true 36 | ] 37 | 38 | PCUndefinedObject >> printOn: aStream 39 | [ 40 | aStream nextPutAll: 'nil' 41 | ] 42 | 43 | PCUndefinedObject >> subclass: subclassName instanceVariableNames: instVarNames classVariableNames: classVarNames 44 | [ 45 | ^ PCClassBuilder new 46 | superclass: self; 47 | name: subclassName; 48 | instVarNames: instVarNames; 49 | classVariableNames: classVarNames; 50 | build 51 | ] 52 | 53 | PCUndefinedObject class 54 | instanceVariables: #(). 55 | 56 | PCUndefinedObject class >> new 57 | [ 58 | "There is a single unique instance of me." 59 | self cannotInstantiate 60 | ] -------------------------------------------------------------------------------- /source/Kernel-Optional-Graphics/PCBitBlt.hz: -------------------------------------------------------------------------------- 1 | PCBitBlt 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#destForm #sourceForm #fillWords #rule #destX #destY #width #height #sourceX #sourceY #clipX #clipY #clipWidth #clipHeight #colorMap ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Optional-Graphics'. 7 | 8 | PCBitBlt >> clipX: x y: y width: w height: h 9 | [ 10 | "Set my clipping boundaries. Setting the clipping bounds is optional." 11 | clipX := x. 12 | clipY := y. 13 | clipWidth := w. 14 | clipHeight := h 15 | ] 16 | 17 | PCBitBlt >> copyBits 18 | [ 19 | "Primitive. Perform the movement of bits from the source form to the destination form. Fail if any variables are not of the right type or if the combination rule is not implemented." 20 | 21 | self primitiveFailed 22 | ] 23 | 24 | PCBitBlt >> copyBitsTranslucent: factor 25 | [ 26 | "This entry point to BitBlt supplies an extra argument to specify translucency for operations 30 and 31. The argument must be an integer between 0 and 255." 27 | 28 | self primitiveFailed 29 | ] 30 | 31 | PCBitBlt >> destForm: aForm 32 | [ 33 | "Set my destination Form." 34 | destForm := aForm. 35 | clipX := 0. 36 | clipY := 0. 37 | clipWidth := aForm width. 38 | clipHeight := aForm height 39 | ] 40 | 41 | PCBitBlt >> destX: x y: y width: w height: h 42 | [ 43 | "Set the destination rectangle for this operation." 44 | destX := x. 45 | destY := y. 46 | width := w. 47 | height := h 48 | ] 49 | 50 | PCBitBlt >> fillR: r g: g b: b 51 | [ 52 | "Set my fill color to the given RGB value, where r, g, and b are in the range 0-255. The destination form must be set before calling this method, since the pixel pattern created depends on the destination depth." 53 | "Note: The ranges of r, g, and b are not checked." 54 | | d pix | 55 | d := destForm depth. 56 | d = 8 57 | ifTrue: [ 58 | pix := 41 + (r // 37 * 36) + (g // 37 * 6) + (b // 37). 59 | ^ self fillWords: (PCWordArray with: 16r01010101 * pix) ]. 60 | d = 16 61 | ifTrue: [ 62 | "5 bits each of r, g, b" 63 | pix := (r // 8 bitShift: 10) + (g // 8 bitShift: 5) + (b // 8). 64 | ^ self fillWords: (PCWordArray with: (pix bitShift: 16) + pix) ]. 65 | d = 32 66 | ifTrue: [ ^ self fillWords: (PCWordArray with: (r bitShift: 16) + (g bitShift: 8) + b) ]. 67 | self error: 'color is supported only for depths 8, 16, and 32' 68 | ] 69 | 70 | PCBitBlt >> fillWords 71 | [ 72 | "Answer the array of pixel words using for filling with a color." 73 | ^ fillWords 74 | ] 75 | 76 | PCBitBlt >> fillWords: aBitmapOrNil 77 | [ 78 | "Set the array of pixel words using for filling with a color." 79 | fillWords := aBitmapOrNil 80 | ] 81 | 82 | PCBitBlt >> initialize 83 | [ 84 | rule := PCForm over. 85 | sourceX := sourceY := 0. 86 | destX := destY := 0. 87 | clipX := clipY := 0. 88 | clipWidth := clipHeight := 100000 89 | ] 90 | 91 | PCBitBlt >> rule: anInteger 92 | [ 93 | "Set the combination rule, an integer between 0 and 34 that determines how pixels are combined in this operation." 94 | rule := anInteger 95 | ] 96 | 97 | PCBitBlt >> sourceForm: aForm 98 | [ 99 | "Set my source and destination forms. The source form may be nil if filling with a color." 100 | sourceForm := aForm 101 | ] 102 | 103 | PCBitBlt >> sourceX: x y: y 104 | [ 105 | "Set the top-left corner of the destination rectangle for this operation." 106 | sourceX := x. 107 | sourceY := y 108 | ] 109 | 110 | PCBitBlt >> width: w height: h 111 | [ 112 | "Set the width and height for this operation." 113 | width := w. 114 | height := h 115 | ] 116 | 117 | PCBitBlt class 118 | instanceVariables: #(). 119 | 120 | -------------------------------------------------------------------------------- /source/Kernel-Optional-Graphics/PCForm.hz: -------------------------------------------------------------------------------- 1 | PCForm 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#bits #width #height #depth #bitBlt ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Optional-Graphics'. 7 | 8 | PCForm >> beDisplayDepth: d 9 | [ 10 | "Install myself as the Display. Drawing onto me will then cause the screen or window to be updated." 11 | | screenExtent | 12 | screenExtent := self primScreenSize. 13 | self setWidth: (screenExtent instVarAt: 1) height: (screenExtent instVarAt: 2) depth: d. 14 | PCSystem specialObjectsArray at: 15 put: self "make this Form the Display" 15 | ] 16 | 17 | PCForm >> bits 18 | [ 19 | ^ bits 20 | ] 21 | 22 | PCForm >> copyX: x y: y width: w height: h 23 | [ 24 | "Answer a new form containing given rectangular portion of this form." 25 | | result | 26 | result := PCForm basicNew setWidth: w height: h depth: depth. 27 | PCBitBlt new 28 | sourceForm: self; 29 | destForm: result; 30 | sourceX: x y: y; 31 | width: w height: h; 32 | copyBits. 33 | ^ result 34 | ] 35 | 36 | PCForm >> depth 37 | [ 38 | ^ depth 39 | ] 40 | 41 | PCForm >> drawForm: aForm x: x y: y rule: anInteger 42 | [ 43 | "Fill the given rectangle with the current fill color." 44 | | oldFill | 45 | oldFill := bitBlt fillWords. 46 | bitBlt 47 | sourceForm: aForm; 48 | destX: x 49 | y: y 50 | width: aForm width 51 | height: aForm height; 52 | rule: anInteger; 53 | copyBits. 54 | bitBlt sourceForm: nil. 55 | bitBlt fillWords: oldFill 56 | ] 57 | 58 | PCForm >> fillRectX: x y: y w: w h: h 59 | [ 60 | "Fill the given rectangle with the current fill color." 61 | bitBlt 62 | destX: x 63 | y: y 64 | width: w 65 | height: h; 66 | copyBits 67 | ] 68 | 69 | PCForm >> height 70 | [ 71 | ^ height 72 | ] 73 | 74 | PCForm >> primScreenSize 75 | [ 76 | "Answer the actual screen size. In Pharo Candle, this will be an Association object since Pharo Candle doesn't have Points." 77 | 78 | self primitiveFailed 79 | ] 80 | 81 | PCForm >> setColorR: r g: g b: b 82 | [ 83 | "Set the fill color for rectangle drawing operations." 84 | bitBlt fillR: r g: g b: b 85 | ] 86 | 87 | PCForm >> setWidth: w height: h depth: d 88 | [ 89 | | wordsPerLine | 90 | wordsPerLine := (w * d + 31) // 32. 91 | bits := PCByteArray new: 4 * wordsPerLine * h. 92 | width := w. 93 | height := h. 94 | depth := d. 95 | bitBlt := PCBitBlt new 96 | destForm: self; 97 | fillR: 255 g: 0 b: 0 "default color" 98 | ] 99 | 100 | PCForm >> width 101 | [ 102 | ^ width 103 | ] 104 | 105 | PCForm class 106 | instanceVariables: #(). 107 | 108 | PCForm class >> over 109 | [ 110 | ^ 3 111 | ] 112 | 113 | PCForm class >> paint 114 | [ 115 | ^ 25 116 | ] 117 | 118 | PCForm class >> width: w height: h depth: d 119 | [ 120 | ^ self basicNew setWidth: w height: h depth: d 121 | ] 122 | 123 | -------------------------------------------------------------------------------- /source/Kernel-Optional-Graphics/PCWordArray.hz: -------------------------------------------------------------------------------- 1 | PCWordArray 2 | superclass: #PCArrayedCollection; 3 | instanceSpecification: #(#variable #words ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Optional-Graphics'. 7 | 8 | PCWordArray class 9 | instanceVariables: #(). 10 | 11 | -------------------------------------------------------------------------------- /source/Kernel-Optional/PCFile.hz: -------------------------------------------------------------------------------- 1 | PCFile 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#name #fileID ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Optional'. 7 | 8 | PCFile >> close 9 | [ 10 | "Close this file." 11 | fileID 12 | ifNotNil: [ 13 | self primClose: fileID. 14 | fileID := nil ] 15 | ] 16 | 17 | PCFile >> cr 18 | [ 19 | self nextPutAll: (PCString with: PCCharacter cr) 20 | ] 21 | 22 | PCFile >> localFolderPath 23 | [ 24 | "Answer the path for the folder containing the image file." 25 | "MFile new localFolderPath" 26 | | imagePath delimiter i | 27 | imagePath := self primImageName. 28 | delimiter := $/. 29 | (imagePath includes: delimiter) 30 | ifFalse: [ delimiter := $\ ]. 31 | i := imagePath size. 32 | [ i > 0 and: [ (imagePath at: i) ~= delimiter ] ] whileTrue: [ i := i - 1 ]. 33 | i = 0 34 | ifTrue: [ ^ '' ]. 35 | ^ imagePath copyFrom: 1 to: i 36 | ] 37 | 38 | PCFile >> name 39 | [ 40 | "Answer the name of this file." 41 | ^ name 42 | ] 43 | 44 | PCFile >> next: count 45 | [ 46 | "Answer a String containing the next count bytes of the file. If there are not count bytes left in the file, answer a String with as many bytes as available." 47 | | buffer n | 48 | buffer := '' class new: count. 49 | n := self 50 | primRead: fileID 51 | into: buffer 52 | startingAt: 1 53 | count: count. 54 | n < count 55 | ifTrue: [ buffer := buffer copyFrom: 1 to: n ]. 56 | ^ buffer 57 | ] 58 | 59 | PCFile >> nextPutAll: buffer 60 | [ 61 | "Write the contents of the given bytes or words object to this file." 62 | ^ self 63 | primWrite: fileID 64 | from: buffer 65 | startingAt: 1 66 | count: buffer basicSize 67 | ] 68 | 69 | PCFile >> openReadOnly: fileName 70 | [ 71 | "Open the file with the given name for reading and writing." 72 | name := nil. 73 | fileID := self primOpen: fileName writable: false. 74 | name := fileName 75 | ] 76 | 77 | PCFile >> openReadWrite: fileName 78 | [ 79 | "Open the file with the given name for reading only." 80 | name := nil. 81 | fileID := self primOpen: fileName writable: true. 82 | name := fileName 83 | ] 84 | 85 | PCFile >> position 86 | [ 87 | "Answer the current file position in bytes." 88 | ^ self primGetPosition: fileID 89 | ] 90 | 91 | PCFile >> position: newPosition 92 | [ 93 | "Seek to the given file position in bytes." 94 | ^ self primSetPosition: fileID to: newPosition 95 | ] 96 | 97 | PCFile >> primClose: id 98 | [ 99 | "Close this file. Don't raise an error if the primitive fails." 100 | 101 | 102 | ] 103 | 104 | PCFile >> primGetPosition: id 105 | [ 106 | "Get this files current position." 107 | 108 | self primitiveFailed 109 | ] 110 | 111 | PCFile >> primImageName 112 | [ 113 | "Answer the full path name for the current image." 114 | 115 | self primitiveFailed 116 | ] 117 | 118 | PCFile >> primOpen: fileName writable: writableFlag 119 | [ 120 | "Open a file of the given name, and return the file ID obtained. 121 | If writableFlag is true, then 122 | if there is none with this name, then create one 123 | else prepare to overwrite the existing from the beginning 124 | otherwise 125 | if the file exists, open it read-only 126 | else return nil" 127 | 128 | self primitiveFailed 129 | ] 130 | 131 | PCFile >> primRead: id into: byteArray startingAt: startIndex count: count 132 | [ 133 | "Read up to count elements into the given buffer and answer the number of elements actually read. The buffer may either a byte- or word-indexable object." 134 | 135 | self primitiveFailed 136 | ] 137 | 138 | PCFile >> primSetPosition: id to: anInteger 139 | [ 140 | "Set this file to the given position." 141 | 142 | self primitiveFailed 143 | ] 144 | 145 | PCFile >> primSize: id 146 | [ 147 | "Answer the size of this file." 148 | 149 | self primitiveFailed 150 | ] 151 | 152 | PCFile >> primWrite: id from: buffer startingAt: startIndex count: count 153 | [ 154 | "Write up to count elements from the given buffer and answer the number of elements actually written. The buffer may either a byte- or word-indexable object." 155 | 156 | self primitiveFailed 157 | ] 158 | 159 | PCFile >> readInto: buffer startingAt: startIndex count: count 160 | [ 161 | "Read up to count elements into the given array and answer the number of elements actually read. The buffer may either a byte- or word-indexable object." 162 | ^ self 163 | primRead: fileID 164 | into: buffer 165 | startingAt: startIndex 166 | count: count 167 | ] 168 | 169 | PCFile >> size 170 | [ 171 | "Answer the size of this file in bytes." 172 | ^ self primSize: fileID 173 | ] 174 | 175 | PCFile class 176 | instanceVariables: #(). 177 | 178 | -------------------------------------------------------------------------------- /source/Kernel-Optional/PCIdentityDictionary.hz: -------------------------------------------------------------------------------- 1 | PCIdentityDictionary 2 | superclass: #PCDictionary; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Optional'. 7 | 8 | PCIdentityDictionary >> keys 9 | [ 10 | "Answer an array of the receiver's keys." 11 | | result | 12 | result := PCOrderedCollection new: self size. 13 | self keysDo: [ :key | result add: key ]. 14 | ^ result asArray 15 | ] 16 | 17 | PCIdentityDictionary >> scanFor: anObject 18 | [ 19 | "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 20 | | finish hash start element | 21 | finish := array size. 22 | finish > 4096 23 | ifTrue: [ hash := anObject identityHash * (finish // 4096) ] 24 | ifFalse: [ hash := anObject identityHash ]. 25 | start := hash \\ array size + 1. "Search from (hash mod size) to the end." 26 | start to: finish do: [ :index | 27 | ((element := array at: index) == nil or: [ element key == anObject ]) 28 | ifTrue: [ ^ index ] ]. "Search from 1 to where we started." 29 | 1 to: start - 1 do: [ :index | 30 | ((element := array at: index) == nil or: [ element key == anObject ]) 31 | ifTrue: [ ^ index ] ]. 32 | ^ 0 "No match AND no empty slot" 33 | ] 34 | 35 | PCIdentityDictionary class 36 | instanceVariables: #(). 37 | -------------------------------------------------------------------------------- /source/Kernel-Optional/PCIdentitySet.hz: -------------------------------------------------------------------------------- 1 | PCIdentitySet 2 | superclass: #PCSet; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Optional'. 7 | 8 | PCIdentitySet >> scanFor: anObject 9 | [ 10 | "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." 11 | | finish hash start element | 12 | finish := array size. 13 | finish > 4096 14 | ifTrue: [ hash := anObject identityHash * (finish // 4096) ] 15 | ifFalse: [ hash := anObject identityHash ]. 16 | start := hash \\ array size + 1. "Search from (hash mod size) to the end." 17 | start to: finish do: [ :index | 18 | ((element := array at: index) == nil or: [ element == anObject ]) 19 | ifTrue: [ ^ index ] ]. "Search from 1 to where we started." 20 | 1 to: start - 1 do: [ :index | 21 | ((element := array at: index) == nil or: [ element == anObject ]) 22 | ifTrue: [ ^ index ] ]. 23 | ^ 0 "No match AND no empty slot" 24 | ] 25 | 26 | PCIdentitySet class 27 | instanceVariables: #(). 28 | 29 | -------------------------------------------------------------------------------- /source/Kernel-Optional/PCPoint.hz: -------------------------------------------------------------------------------- 1 | PCPoint 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#x #y ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Optional'. 7 | 8 | PCPoint >> * arg 9 | [ 10 | "Answer a Point that is the product of the receiver and arg." 11 | arg isPoint 12 | ifTrue: [ ^ (x * arg x) @ (y * arg y) ]. 13 | ^ arg adaptToPoint: self andSend: #* 14 | ] 15 | 16 | PCPoint >> + arg 17 | [ 18 | "Answer a Point that is the sum of the receiver and arg." 19 | arg isPoint 20 | ifTrue: [ ^ (x + arg x) @ (y + arg y) ]. 21 | ^ arg adaptToPoint: self andSend: #+ 22 | ] 23 | 24 | PCPoint >> - arg 25 | [ 26 | "Answer a Point that is the difference of the receiver and arg." 27 | arg isPoint 28 | ifTrue: [ ^ (x - arg x) @ (y - arg y) ]. 29 | ^ arg adaptToPoint: self andSend: #- 30 | ] 31 | 32 | PCPoint >> / arg 33 | [ 34 | "Answer a Point that is the quotient of the receiver and arg." 35 | arg isPoint 36 | ifTrue: [ ^ (x / arg x) @ (y / arg y) ]. 37 | ^ arg adaptToPoint: self andSend: #/ 38 | ] 39 | 40 | PCPoint >> // arg 41 | [ 42 | "Answer a Point that is the quotient of the receiver and arg." 43 | arg isPoint 44 | ifTrue: [ ^ (x // arg x) @ (y // arg y) ]. 45 | ^ arg adaptToPoint: self andSend: #// 46 | ] 47 | 48 | PCPoint >> = aPoint 49 | [ 50 | self species = aPoint species 51 | ifTrue: [ ^ x = aPoint x and: [ y = aPoint y ] "Refer to the comment in Object|=." ] 52 | ifFalse: [ ^ false ] 53 | ] 54 | 55 | PCPoint >> abs 56 | [ 57 | "Answer a Point whose x and y are the absolute values of the receiver's x and y." 58 | ^ x abs @ y abs 59 | ] 60 | 61 | PCPoint >> adaptToFloat: rcvr andSend: selector 62 | [ 63 | "If I am involved in arithmetic with a Float, convert it to a Point." 64 | ^ rcvr @ rcvr perform: selector with: self 65 | ] 66 | 67 | PCPoint >> adaptToInteger: rcvr andSend: selector 68 | [ 69 | "If I am involved in arithmetic with an Integer, convert it to a Point." 70 | ^ rcvr @ rcvr perform: selector with: self 71 | ] 72 | 73 | PCPoint >> asPoint 74 | [ 75 | "Answer the receiver itself." 76 | ^ self 77 | ] 78 | 79 | PCPoint >> crossProduct: aPoint 80 | [ 81 | "Answer a number that is the cross product of the receiver and the argument, aPoint." 82 | ^ x * aPoint y - (y * aPoint x) 83 | ] 84 | 85 | PCPoint >> degrees 86 | [ 87 | "Answer the angle the receiver makes with origin in degrees. Right is 0; down is 90." 88 | | tan theta | 89 | x = 0 90 | ifTrue: [ 91 | y >= 0 92 | ifTrue: [ ^ 90.0 ] 93 | ifFalse: [ ^ 270.0 ] ] 94 | ifFalse: [ 95 | tan := y asFloat / x asFloat. 96 | theta := tan arcTan. 97 | x >= 0 98 | ifTrue: [ 99 | y >= 0 100 | ifTrue: [ ^ theta radiansToDegrees ] 101 | ifFalse: [ ^ 360.0 + theta radiansToDegrees ] ] 102 | ifFalse: [ ^ 180.0 + theta radiansToDegrees ] ] 103 | ] 104 | 105 | PCPoint >> dist: aPoint 106 | [ 107 | "Answer the distance between aPoint and the receiver." 108 | ^ (aPoint - self) r 109 | ] 110 | 111 | PCPoint >> dotProduct: aPoint 112 | [ 113 | "Answer a number that is the dot product of the receiver and the argument." 114 | ^ x * aPoint x + (y * aPoint y) 115 | ] 116 | 117 | PCPoint >> hash 118 | [ 119 | "Hash is reimplemented because = is implemented." 120 | ^ (x hash bitShift: 2) bitXor: y hash 121 | ] 122 | 123 | PCPoint >> max: aPoint 124 | [ 125 | "Answer a new Point whose x and y are the maximum of the receiver and the argument point x and y." 126 | ^ (x max: aPoint x) @ (y max: aPoint y) 127 | ] 128 | 129 | PCPoint >> min: aPoint 130 | [ 131 | "Answer a new Point whose x and y are the minimum of the receiver's and the argument point's x and y." 132 | ^ (x min: aPoint x) @ (y min: aPoint y) 133 | ] 134 | 135 | PCPoint >> negated 136 | [ 137 | "Answer a point whose x and y coordinates are the negatives of those of the receiver." 138 | ^ x negated @ y negated 139 | ] 140 | 141 | PCPoint >> printOn: aStream 142 | [ 143 | "The receiver prints on aStream in terms of infix notation." 144 | x printOn: aStream. 145 | aStream nextPut: $@. 146 | y printOn: aStream 147 | ] 148 | 149 | PCPoint >> r 150 | [ 151 | "Answer the receiver's radius in polar coordinate system." 152 | ^ (x * x + (y * y)) sqrt 153 | ] 154 | 155 | PCPoint >> rounded 156 | [ 157 | "Answer a Point that is the receiver's x and y rounded. Answer the receiver if its coordinates are already integral." 158 | (x isInteger and: [ y isInteger ]) 159 | ifTrue: [ ^ self ]. 160 | ^ x rounded @ y rounded 161 | ] 162 | 163 | PCPoint >> setR: rho degrees: theta 164 | [ 165 | | radians | 166 | radians := theta asFloat degreesToRadians. 167 | x := rho asFloat * radians cos. 168 | y := rho asFloat * radians sin 169 | ] 170 | 171 | PCPoint >> setX: xValue setY: yValue 172 | [ 173 | x := xValue. 174 | y := yValue 175 | ] 176 | 177 | PCPoint >> theta 178 | [ 179 | "Answer the angle the receiver makes with origin in radians. See degrees." 180 | | tan theta | 181 | x = 0 182 | ifTrue: [ 183 | y >= 0 184 | ifTrue: [ ^ 1.5708 "90.0 degreesToRadians" ] 185 | ifFalse: [ ^ 4.71239 "270.0 degreesToRadians" ] ] 186 | ifFalse: [ 187 | tan := y asFloat / x asFloat. 188 | theta := tan arcTan. 189 | x >= 0 190 | ifTrue: [ 191 | y >= 0 192 | ifTrue: [ ^ theta ] 193 | ifFalse: [ ^ 360.0 degreesToRadians + theta ] ] 194 | ifFalse: [ ^ 180.0 degreesToRadians + theta ] ] 195 | ] 196 | 197 | PCPoint >> truncated 198 | [ 199 | "Answer a Point whose x and y coordinates are integers. Answer the receiver if its coordinates are already integral." 200 | (x isInteger and: [ y isInteger ]) 201 | ifTrue: [ ^ self ]. 202 | ^ x truncated @ y truncated 203 | ] 204 | 205 | PCPoint >> x 206 | [ 207 | ^ x 208 | ] 209 | 210 | PCPoint >> y 211 | [ 212 | ^ y 213 | ] 214 | 215 | PCPoint class 216 | instanceVariables: #(). 217 | 218 | PCPoint class >> r: rho degrees: theta 219 | [ 220 | "Answer an instance of me with polar coordinates rho and theta." 221 | ^ self new setR: rho degrees: theta 222 | ] 223 | 224 | PCPoint class >> x: xValue y: yValue 225 | [ 226 | "Answer an instance of me with the given coordinates." 227 | ^ self new setX: xValue setY: yValue 228 | ] 229 | 230 | -------------------------------------------------------------------------------- /source/Kernel-Optional/PCSemaphore.hz: -------------------------------------------------------------------------------- 1 | PCSemaphore 2 | superclass: #PCLinkedList; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#excessSignals ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Optional'. 7 | 8 | PCSemaphore >> = anObject 9 | [ 10 | ^ self == anObject 11 | ] 12 | 13 | PCSemaphore >> critical: aBlock 14 | [ 15 | "Evaluate the given block immediated if the receiver is not currently running the critical: method. If it is, evaluate the given block when the current critical: message is finished. Answer the result of evaluating the block." 16 | | result | 17 | self wait. 18 | result := aBlock value. 19 | self signal. 20 | ^ result 21 | ] 22 | 23 | PCSemaphore >> hash 24 | [ 25 | ^ self identityHash 26 | ] 27 | 28 | PCSemaphore >> initialize 29 | [ 30 | "Consume any excess signals the receiver may have accumulated." 31 | excessSignals := 0 32 | ] 33 | 34 | PCSemaphore >> signal 35 | [ 36 | "Primitive. Increment my signal count. If one or more processes are waiting on me, allow the first one to proceed. If no process is waiting, just remember the excess signal. Essential. See Object documentation whatIsAPrimitive." 37 | 38 | self primitiveFailed 39 | ] 40 | 41 | PCSemaphore >> wait 42 | [ 43 | "Primitive. This semaphore must have a signal before the caller's process can proceed. If I have no signals, the process is suspended this semaphore is signalled. Essential. See Object documentation whatIsAPrimitive." 44 | 45 | self primitiveFailed 46 | ] 47 | 48 | PCSemaphore class 49 | instanceVariables: #(). 50 | 51 | -------------------------------------------------------------------------------- /source/Kernel-Processes/PCProcess.hz: -------------------------------------------------------------------------------- 1 | PCProcess 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#nextLink #suspendedContext #priority #myList #threadId #errorHandler ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Processes'. 7 | 8 | PCProcess >> errorHandler 9 | [ 10 | ^ errorHandler 11 | ] 12 | 13 | PCProcess >> errorHandler: aBlock 14 | [ 15 | errorHandler := aBlock 16 | ] 17 | 18 | PCProcess >> initSuspendedContext: aContext 19 | [ 20 | suspendedContext := aContext. 21 | priority := 1 "lowest priority" 22 | ] 23 | 24 | PCProcess >> nextLink 25 | [ 26 | ^ nextLink 27 | ] 28 | 29 | PCProcess >> nextLink: aLink 30 | [ 31 | nextLink := aLink 32 | ] 33 | 34 | PCProcess >> printOn: aStream 35 | [ 36 | super printOn: aStream. 37 | aStream nextPutAll: ' in '. 38 | suspendedContext printOn: aStream 39 | ] 40 | 41 | PCProcess >> priority 42 | [ 43 | "Answer the priority of the receiver." 44 | ^ priority 45 | ] 46 | 47 | PCProcess >> priority: anInteger 48 | [ 49 | "Set the receiver's priority to anInteger. The priority is used by the VM as an index into the scheduler's array of process queues so it must be an integer between 1 and Processor highestPriority." 50 | priority := (anInteger asInteger max: 1) min: Processor highestPriority 51 | ] 52 | 53 | PCProcess >> resume 54 | [ 55 | "Primitive. Allow this process to proceed. Put the receiver in line to become the active process. Fail if the receiver is already waiting on a queue (i.e., on a Semaphore or on a scheduler queue). Essential. See Object documentation whatIsAPrimitive." 56 | 57 | self primitiveFailed 58 | ] 59 | 60 | PCProcess >> suspend 61 | [ 62 | "Primitive. Stop this process in such a way that it can be restarted later (see resume). If the receiver is the active process, suspend it. Otherwise, remove the receiver from its suspended process list. Essential. See Object documentation whatIsAPrimitive." 63 | 64 | Processor activeProcess == self 65 | ifTrue: [ self primitiveFailed ] 66 | ifFalse: [ 67 | Processor remove: self ifAbsent: [ self error: 'This process was not active' ]. 68 | myList := nil ] 69 | ] 70 | 71 | PCProcess >> suspendedContext 72 | [ 73 | ^ suspendedContext 74 | ] 75 | 76 | PCProcess >> terminate 77 | [ 78 | "Stop this process forever." 79 | Processor activeProcess == self 80 | ifTrue: [ thisContext removeSelf suspend ] 81 | ifFalse: [ 82 | myList 83 | ifNotNil: [ 84 | myList remove: self ifAbsent: [ ]. 85 | myList := nil ]. 86 | suspendedContext := nil ] 87 | ] 88 | 89 | PCProcess class 90 | instanceVariables: #(). 91 | 92 | PCProcess class >> for: aContext priority: anInteger 93 | [ 94 | "Answer an instance of me for the given context (usually a Block) at the given priority." 95 | ^ self new 96 | initSuspendedContext: aContext; 97 | priority: anInteger 98 | ] 99 | 100 | -------------------------------------------------------------------------------- /source/Kernel-Processes/PCProcessList.hz: -------------------------------------------------------------------------------- 1 | PCProcessList 2 | superclass: #PCSequenceableCollection; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#firstLink #lastLink ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Processes'. 7 | 8 | PCProcessList >> add: aLink 9 | [ 10 | "Add aLink to the end of the receiver's list. Answer aLink." 11 | ^ self addLast: aLink 12 | ] 13 | 14 | PCProcessList >> addLast: aLink 15 | [ 16 | "Add aLink to the end of the receiver's list. Answer aLink." 17 | self isEmpty 18 | ifTrue: [ firstLink := aLink ] 19 | ifFalse: [ lastLink nextLink: aLink ]. 20 | lastLink := aLink. 21 | ^ aLink 22 | ] 23 | 24 | PCProcessList >> do: aBlock 25 | [ 26 | "Evaluate the given block for each of my elements." 27 | | aLink | 28 | aLink := firstLink. 29 | [ aLink == nil ] 30 | whileFalse: [ 31 | aBlock value: aLink. 32 | aLink := aLink nextLink ] 33 | ] 34 | 35 | PCProcessList >> first 36 | [ 37 | "Answer the first element. Raise an error if I am empty." 38 | self emptyCheck. 39 | ^ firstLink 40 | ] 41 | 42 | PCProcessList >> isEmpty 43 | [ 44 | ^ firstLink == nil 45 | ] 46 | 47 | PCProcessList >> remove: aLink ifAbsent: aBlock 48 | [ 49 | "Remove aLink from the receiver. If it is not there, answer the result of evaluating aBlock." 50 | | tempLink | 51 | aLink == firstLink 52 | ifTrue: [ 53 | firstLink := aLink nextLink. 54 | aLink == lastLink 55 | ifTrue: [ lastLink := nil ] ] 56 | ifFalse: [ 57 | tempLink := firstLink. 58 | [ 59 | tempLink == nil 60 | ifTrue: [ ^ aBlock value ]. 61 | tempLink nextLink == aLink ] whileFalse: [ tempLink := tempLink nextLink ]. 62 | tempLink nextLink: aLink nextLink. 63 | aLink == lastLink 64 | ifTrue: [ lastLink := tempLink ] ]. 65 | aLink nextLink: nil. 66 | ^ aLink 67 | ] 68 | 69 | PCProcessList >> removeFirst 70 | [ 71 | "Remove and answer the first element. Raise an error if I am empty." 72 | | oldLink | 73 | self emptyCheck. 74 | oldLink := firstLink. 75 | firstLink == lastLink 76 | ifTrue: [ 77 | firstLink := nil. 78 | lastLink := nil ] 79 | ifFalse: [ firstLink := oldLink nextLink ]. 80 | oldLink nextLink: nil. 81 | ^ oldLink 82 | ] 83 | 84 | PCProcessList >> size 85 | [ 86 | "Answer the number of elements I contain." 87 | | tally | 88 | tally := 0. 89 | self do: [ :each | tally := tally + 1 ]. 90 | ^ tally 91 | ] 92 | 93 | PCProcessList class 94 | instanceVariables: #(). 95 | 96 | -------------------------------------------------------------------------------- /source/Kernel-Processes/PCProcessorScheduler.hz: -------------------------------------------------------------------------------- 1 | PCProcessorScheduler 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#suspendedProcessLists #activeProcess ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Processes'. 7 | 8 | PCProcessorScheduler >> activeProcess 9 | [ 10 | "Answer the currently running Process." 11 | ^ activeProcess 12 | ] 13 | 14 | PCProcessorScheduler >> highestPriority 15 | [ 16 | "Answer the number of priority levels currently available for use." 17 | ^ suspendedProcessLists size 18 | ] 19 | 20 | PCProcessorScheduler >> idleProcess 21 | [ 22 | "A default background process that simply loops forever. It runs only when no higher priority processes are available, perhaps because they are waiting on a semaphore or timer." 23 | [ true ] 24 | whileTrue: [ 25 | "do nothing" 26 | ] 27 | ] 28 | 29 | PCProcessorScheduler >> initProcessLists 30 | [ 31 | "Create process lists for prioriy levels 1 through 5." 32 | suspendedProcessLists := (1 to: 5) collect: [ :i | PCProcessList new ] 33 | ] 34 | 35 | PCProcessorScheduler >> installIdleProcess 36 | [ 37 | "Install an idle process of the lowest possible priority that is always runnable." 38 | "Details: The virtual machine requires that there is always some runnable process that can be scheduled; this background process ensures that this is the case." 39 | | idleList idleProc | 40 | "terminate any old idle processes" 41 | idleList := suspendedProcessLists at: 1. 42 | [ idleList isEmpty ] whileFalse: [ idleList first terminate ]. 43 | idleProc := PCProcess for: [ self idleProcess ] priority: 1. 44 | (suspendedProcessLists at: idleProc priority) addLast: idleProc 45 | ] 46 | 47 | PCProcessorScheduler >> installStartProcess 48 | [ 49 | "Install the startup process as the active process. This process will run when Pharo Candle is started." 50 | activeProcess := PCProcess for: [ PCSystem start ] asContext priority: 3 51 | ] 52 | 53 | PCProcessorScheduler >> remove: aProcess ifAbsent: aBlock 54 | [ 55 | "Remove the given process from the list on which it is waiting. If the process is not on the queue for it's priority, evaluate the given block. Always answer the process." 56 | (suspendedProcessLists at: aProcess priority) remove: aProcess ifAbsent: aBlock. 57 | ^ aProcess 58 | ] 59 | 60 | PCProcessorScheduler class 61 | instanceVariables: #(). 62 | 63 | PCProcessorScheduler class >> new 64 | [ 65 | "The VM depends on a unique scheduler." 66 | self cannotInstantiate 67 | ] 68 | 69 | -------------------------------------------------------------------------------- /source/Kernel-Streams/PCReadStream.hz: -------------------------------------------------------------------------------- 1 | PCReadStream 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#collection #position #readLimit ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Streams'. 7 | 8 | PCReadStream >> atEnd 9 | [ 10 | "Primitive. Answer whether the receiver can access any more objects. Optional. See Object documentation whatIsAPrimitive." 11 | 12 | ^ position >= readLimit 13 | ] 14 | 15 | PCReadStream >> contents 16 | [ 17 | "Answer with a copy of my collection from 1 to readLimit." 18 | ^ collection copyFrom: 1 to: readLimit 19 | ] 20 | 21 | PCReadStream >> next 22 | [ 23 | "Primitive. Answer the next object in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Optional. See Object documentation whatIsAPrimitive." 24 | 25 | position >= readLimit 26 | ifTrue: [ ^ nil ] 27 | ifFalse: [ ^ collection at: (position := position + 1) ] 28 | ] 29 | 30 | PCReadStream >> next: anInteger 31 | [ 32 | "Answer a collection containing the next anInteger elements of my collection." 33 | | end result | 34 | end := position + anInteger min: readLimit. 35 | result := collection copyFrom: position + 1 to: end. 36 | position := end. 37 | ^ result 38 | ] 39 | 40 | PCReadStream >> on: aCollection 41 | [ 42 | "Initialize myself for streaming over the given collection." 43 | collection := aCollection. 44 | readLimit := aCollection size. 45 | position := 0 46 | ] 47 | 48 | PCReadStream >> peek 49 | [ 50 | "Answer the next object without advancing my position. Answer nil if there are no more elements." 51 | | result | 52 | self atEnd 53 | ifTrue: [ ^ nil ]. 54 | result := self next. 55 | position := position - 1. 56 | ^ result 57 | ] 58 | 59 | PCReadStream >> peekFor: anObject 60 | [ 61 | "If my next element equals the given object, skip it and answer true. Otherwise, answer false and leave my position unchanged." 62 | | result | 63 | result := self peek = anObject. 64 | result 65 | ifTrue: [ self skip: 1 ]. 66 | ^ result 67 | ] 68 | 69 | PCReadStream >> position 70 | [ 71 | "Answer the current position of accessing the sequence of objects." 72 | ^ position 73 | ] 74 | 75 | PCReadStream >> position: anInteger 76 | [ 77 | "Set my current position to anInteger, as long as anInteger is within bounds. If not, report an error." 78 | anInteger >= 0 & (anInteger <= readLimit) 79 | ifTrue: [ position := anInteger asInteger ] 80 | ifFalse: [ self error: 'Position out of bounds: ' , anInteger printString ] 81 | ] 82 | 83 | PCReadStream >> size 84 | [ 85 | "Compatibility with other streams (e.g., FileStream)" 86 | ^ readLimit 87 | ] 88 | 89 | PCReadStream >> skip: anInteger 90 | [ 91 | "Set the receiver's position to be the current position+anInteger." 92 | self position: (position + anInteger min: readLimit) 93 | ] 94 | 95 | PCReadStream class 96 | instanceVariables: #(). 97 | 98 | PCReadStream class >> on: aCollection 99 | [ 100 | "Answer an instance of me, streaming over the elements of aCollection." 101 | ^ self basicNew on: aCollection 102 | ] 103 | 104 | -------------------------------------------------------------------------------- /source/Kernel-Streams/PCWriteStream.hz: -------------------------------------------------------------------------------- 1 | PCWriteStream 2 | superclass: #PCReadStream; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(#writeLimit ); 5 | classVariables: #(); 6 | package: #'PharoCandle-Kernel-Streams'. 7 | 8 | PCWriteStream >> contents 9 | [ 10 | "Answer with a copy of my collection up to the high-water mark that was written." 11 | readLimit := readLimit max: position. 12 | ^ collection copyFrom: 1 to: readLimit 13 | ] 14 | 15 | PCWriteStream >> nextPut: anObject 16 | [ 17 | "Primitive. Insert the argument at the next position in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Fail if the argument is not of the right type for the collection. Optional. See Object documentation whatIsAPrimitive." 18 | 19 | position >= writeLimit 20 | ifTrue: [ ^ self pastEndPut: anObject ] 21 | ifFalse: [ 22 | position := position + 1. 23 | ^ collection at: position put: anObject ] 24 | ] 25 | 26 | PCWriteStream >> nextPutAll: aCollection 27 | [ 28 | "Write the elements of the given collection starting at my current position. Answer the collection." 29 | "Optimization: If the given collection has the same class as my collection, use the fast operation replaceFrom:to:with:." 30 | | newEnd | 31 | collection class == aCollection class 32 | ifFalse: [ 33 | aCollection do: [ :v | self nextPut: v ]. 34 | ^ aCollection ]. 35 | newEnd := position + aCollection size. 36 | newEnd > writeLimit 37 | ifTrue: [ 38 | "grow my collection if necessary" 39 | collection := collection , (collection species new: newEnd - writeLimit + (collection size max: 20)). 40 | writeLimit := collection size ]. 41 | collection replaceFrom: position + 1 to: newEnd with: aCollection. 42 | position := newEnd 43 | ] 44 | 45 | PCWriteStream >> on: aCollection 46 | [ 47 | super on: aCollection. 48 | readLimit := 0. 49 | writeLimit := aCollection size 50 | ] 51 | 52 | PCWriteStream >> pastEndPut: anObject 53 | [ 54 | "Grow my collection." 55 | "Details: In general, double my size. Grow by at least 20 elements if my size is under 20 and grow by 20000 if my size is over 20000." 56 | collection := collection , (collection class new: ((collection size max: 20) min: 20000)). 57 | writeLimit := collection size. 58 | collection at: (position := position + 1) put: anObject 59 | ] 60 | 61 | PCWriteStream >> position: anInteger 62 | [ 63 | "Set my read position, but remember the high-water mark that was written." 64 | readLimit := readLimit max: position. 65 | super position: anInteger 66 | ] 67 | 68 | PCWriteStream >> size 69 | [ 70 | ^ readLimit := readLimit max: position 71 | ] 72 | 73 | PCWriteStream >> space 74 | [ 75 | "Append a space character to me." 76 | self nextPut: PCCharacter space 77 | ] 78 | 79 | PCWriteStream class 80 | instanceVariables: #(). 81 | 82 | -------------------------------------------------------------------------------- /source/Kernel-System/PCSystem.hz: -------------------------------------------------------------------------------- 1 | PCSystem 2 | superclass: #PCObject; 3 | instanceSpecification: #(#pointers #words ); 4 | instanceVariables: #(); 5 | classVariables: #(#SpecialObjectsArray ); 6 | package: #'PharoCandle-Kernel-System'. 7 | 8 | PCSystem class 9 | instanceVariables: #(). 10 | 11 | PCSystem class >> allObjectsDo: aBlock 12 | [ 13 | "Evaluate the argument, aBlock, for each object in the system excluding SmallIntegers." 14 | | object | 15 | object := self someObject. 16 | [ 0 == object ] 17 | whileFalse: [ 18 | aBlock value: object. 19 | object := object nextObject ] 20 | ] 21 | 22 | PCSystem class >> append: aString toFile: fileName 23 | [ 24 | "Append the given string to the file with the given name." 25 | | f | 26 | f := PCFile new. 27 | f openReadWrite: f localFolderPath , fileName. 28 | f position: f size. 29 | f nextPutAll: aString. 30 | f cr. 31 | f close 32 | ] 33 | 34 | PCSystem class >> exitToDebugger 35 | [ 36 | "Tell the VM that we've encountered an unhandled error or halt." 37 | 38 | 39 | ] 40 | 41 | PCSystem class >> garbageCollect 42 | [ 43 | "Primitive. Reclaims all garbage and answers the number of bytes of available space." 44 | 45 | self primitiveFailed 46 | ] 47 | 48 | PCSystem class >> getVMParameters 49 | [ 50 | "Answer an Array containing the current values of the VM's internal parameter and statistics registers. The same primitive can be called with one integer argument to read a specific parameter and with two parameters to set a writable parameter, although these variations may not be implemented. Optional." 51 | "VM parameters are numbered as follows: 52 | 1 end of old-space (0-based, read-only) 53 | 2 end of young-space (read-only) 54 | 3 end of memory (read-only) 55 | 4 allocationCount (read-only) 56 | 5 allocations between GCs (read-write) 57 | 6 survivor count tenuring threshold (read-write) 58 | 7 full GCs since startup (read-only) 59 | 8 total milliseconds in full GCs since startup (read-only) 60 | 9 incremental GCs since startup (read-only) 61 | 10 total milliseconds in incremental GCs since startup (read-only) 62 | 11 tenures of surving objects since startup (read-only) 63 | 12-20 specific to the translating VM (obsolete) 64 | 21 root table size (read-only) 65 | 22 root table overflows since startup (read-only)" 66 | 67 | self primitiveFailed 68 | ] 69 | 70 | PCSystem class >> getchar 71 | [ 72 | "Answer the ASCII value of the next character from the keyboard buffer. Answer nil if no key has been typed." 73 | | ch | 74 | (ch := self primKeyboardNext) ifNil: [ ^ nil ] ifNotNil: [ ^ ch bitAnd: 16rFF ] 75 | ] 76 | 77 | PCSystem class >> graphicsTest 78 | [ 79 | "This method is called when the image is started. Add a call to your own code here." 80 | "MSystem graphicsTest" 81 | | f | 82 | self log: 'Screen size: ' , PCForm new primScreenSize printString. 83 | f := PCForm new. 84 | f beDisplayDepth: 32. 85 | 0 to: 255 do: [ :r | 86 | 0 to: 255 do: [ :gb | 87 | f setColorR: r g: gb b: gb. 88 | f 89 | fillRectX: gb 90 | y: 0 91 | w: 1 92 | h: f height ] ]. 93 | f setColorR: 255 g: 255 b: 0. 94 | f 95 | fillRectX: 0 96 | y: 0 97 | w: 30 98 | h: 30 99 | ] 100 | 101 | PCSystem class >> incrementalGarbageCollect 102 | [ 103 | "Primitive. Reclaims recently created garbage fairly quickly and answers the number of bytes of available space." 104 | 105 | 106 | ] 107 | 108 | PCSystem class >> log: aString 109 | [ 110 | self append: aString toFile: 'log.txt' 111 | ] 112 | 113 | PCSystem class >> milliseconds 114 | [ 115 | "Answer the current value of the millisecond clock. Optional primitive." 116 | "Note: The millisecond clock may wrap around frequently, depending on the underlaying hardware. If no hardware clock is available, it may always return 0." 117 | 118 | ^ 0 119 | ] 120 | 121 | PCSystem class >> primKeyboardNext 122 | [ 123 | "Answer the next keycode from the keyboard buffer. A keycode is 12 bits: four modifier flags in the 4 most significant bits and the 8 bit ISO character in the least significant bits. Answer nil if no key has been typed." 124 | 125 | ^ nil 126 | ] 127 | 128 | PCSystem class >> primitiveGetSpecialObjectsArray 129 | [ 130 | "Answer the virtual machine's special objects array." 131 | 132 | self primitiveFailed 133 | ] 134 | 135 | PCSystem class >> quit 136 | [ 137 | "Exit from the system." 138 | 139 | 140 | ] 141 | 142 | PCSystem class >> specialObjectsArray 143 | [ 144 | ^ SpecialObjectsArray 145 | ] 146 | 147 | PCSystem class >> specialObjectsArray: anArray 148 | [ 149 | SpecialObjectsArray := anArray 150 | ] 151 | 152 | PCSystem class >> start 153 | [ 154 | self log: 'Welcome to Pharo Candle edition!' substrings asString. 155 | self log: self tinyBenchmarks. 156 | self log: PCForm new primScreenSize printString. 157 | 158 | self testNormalObject. 159 | self testByteObject. 160 | 161 | PCObject superclass ifNil: [ self quit ] 162 | ] 163 | 164 | PCSystem class >> testNormalObject 165 | [ 166 | | test | 167 | test := (PCObject subclass: #Test instanceVariableNames: 'test1 test2' classVariableNames: '') new. 168 | test instVarAt: 1 put: 1. 169 | test instVarAt: 2 put: (test instVarAt: 1) + 2. 170 | 171 | self log: (test instVarAt: 2) asString. 172 | ] 173 | 174 | PCSystem class >> testByteObject 175 | [ 176 | | test | 177 | test := (PCObject variableByteSubclass: #Test instanceVariableNames: '' classVariableNames: '') new: 5. 178 | self log: 'size of byte object created: ' , test basicSize asString. 179 | test at: 1 put: 17. 180 | ] 181 | 182 | PCSystem class >> tinyBenchmarks 183 | [ 184 | "Report the results of running the two tiny benchmarks." 185 | | n t1 t2 r | 186 | n := 25. 187 | t1 := [ n benchmark ] msecs. 188 | t2 := [ r := 28 benchFib ] msecs. 189 | ^ (n * 500000 * 1000 // t1) printString , ' bytecodes/sec; ' , (r * 1000 // t2) printString , ' sends/sec' 190 | ] 191 | 192 | --------------------------------------------------------------------------------