├── .eslintignore ├── .github └── workflows │ └── node.js.yml ├── .gitignore ├── .prettierignore ├── LICENSE ├── README.md ├── bin └── som.mjs ├── package-lock.json ├── package.json ├── scripts └── generatePrimitives.mjs ├── src ├── ClassLoader.mjs ├── Logger.mjs ├── SOM.ohm ├── assert.mjs ├── compilation.mjs ├── evaluation.mjs ├── helpers.mjs ├── kernel.mjs ├── paths.mjs ├── primitives │ ├── Array.mjs │ ├── Block.mjs │ ├── Class.mjs │ ├── Double.mjs │ ├── Integer.mjs │ ├── Method.mjs │ ├── Object.mjs │ ├── String.mjs │ ├── Symbol.mjs │ ├── System.mjs │ └── index.mjs ├── runtime.mjs └── test │ ├── ClassLoader.test.mjs │ ├── compilation.test.mjs │ ├── evaluation.test.mjs │ ├── kernel.test.mjs │ └── snapshots │ ├── compilation.test.mjs.md │ └── compilation.test.mjs.snap ├── test ├── compileSomTestSuite.mjs ├── data │ ├── HelloWorld.som │ └── Thing.som ├── somTestSuite.mjs └── testCli.mjs └── third_party └── SOM-st └── SOM ├── LICENSE ├── Smalltalk ├── Array.som ├── Block.som ├── Block1.som ├── Block2.som ├── Block3.som ├── Boolean.som ├── Class.som ├── Dictionary.som ├── Double.som ├── False.som ├── HashEntry.som ├── Hashtable.som ├── Integer.som ├── Metaclass.som ├── Method.som ├── Nil.som ├── Object.som ├── Pair.som ├── Primitive.som ├── Set.som ├── String.som ├── Symbol.som ├── System.som ├── True.som └── Vector.som └── TestSuite ├── ArrayTest.som ├── BasicInterpreterTests ├── Arrays.som ├── BinaryOperation.som ├── BlockInlining.som ├── Blocks.som ├── CompilerSimplification.som ├── Hash.som ├── IfTrueIfFalse.som ├── MethodCall.som ├── NonLocalReturn.som ├── NonLocalVars.som ├── NumberOfTests.som ├── ObjectCreation.som ├── Regressions.som ├── Return.som ├── Self.som └── number-of-tests.sh ├── BlockTest.som ├── ClassA.som ├── ClassB.som ├── ClassC.som ├── ClassLoadingTest.som ├── ClassStructureTest.som ├── ClosureTest.som ├── CoercionTest.som ├── CompilerReturnTest.som ├── DoesNotUnderstandMessage.som ├── DoesNotUnderstandTest.som ├── DoubleTest.som ├── EmptyTest.som ├── GlobalTest.som ├── HashTest.som ├── IntegerTest.som ├── PreliminaryTest.som ├── ReflectionTest.som ├── SelfBlockTest.som ├── SetTest.som ├── SpecialSelectorsTest.som ├── StringTest.som ├── SuperTest.som ├── SuperTestSuperClass.som ├── SymbolTest.som ├── SystemTest.som ├── TestCase.som ├── TestHarness.som ├── TestRunner.som └── VectorTest.som /.eslintignore: -------------------------------------------------------------------------------- 1 | *.som.js 2 | -------------------------------------------------------------------------------- /.github/workflows/node.js.yml: -------------------------------------------------------------------------------- 1 | # This workflow will do a clean install of node dependencies, build the source code and run tests across different versions of node 2 | # For more information see: https://help.github.com/actions/language-and-framework-guides/using-nodejs-with-github-actions 3 | 4 | name: Node.js CI 5 | 6 | on: 7 | push: 8 | branches: [main] 9 | pull_request: 10 | branches: [main] 11 | 12 | jobs: 13 | build: 14 | runs-on: ubuntu-latest 15 | 16 | strategy: 17 | matrix: 18 | node-version: [14.x, 15.x] 19 | # See supported Node.js release schedule at https://nodejs.org/en/about/releases/ 20 | 21 | steps: 22 | - uses: actions/checkout@v2 23 | - name: Use Node.js ${{ matrix.node-version }} 24 | uses: actions/setup-node@v2 25 | with: 26 | node-version: ${{ matrix.node-version }} 27 | - run: npm ci 28 | - run: npm run build --if-present 29 | - run: npm test 30 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | node_modules 2 | generated 3 | *.som.js 4 | -------------------------------------------------------------------------------- /.prettierignore: -------------------------------------------------------------------------------- 1 | *.som.js 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Patrick Dubroy 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 all 13 | 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 THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ohm-som 2 | 3 | A JavaScript implementation of [SOM](http://som-st.github.io/), a minimal Smalltalk for teaching and research. Just a hobby, won't be big and professional like . 4 | 5 | ## Status 6 | 7 | **2021-05-23:** ⚠️Under construction⚠️, but it now passes the majority of the [SOM test suite](./third_party/SOM-st/SOM/TestSuite). 8 | 9 | ## Usage 10 | 11 | Example: 12 | 13 | ```bash 14 | node bin/som.mjs --classpath test/data HelloWorld 15 | ``` 16 | 17 | ## Scripts 18 | 19 | - `npm test` runs the smaller unit / integration tests (should all pass) 20 | - `npm run som-test-suite` runs the SOM test suite (not expected to pass yet) 21 | 22 | ### Debugging 23 | 24 | There are two environment variables you can set to make debugging easier. 25 | 26 | Use `DEBUG_GENERATED_CLASSES=true` to write out the generated JS code for all SOM classes as they are loaded. These are written to the same directory as the original SOM source. E.g., for Array.som, the generated code will be written to Array.som.js. 27 | 28 | If you set `USE_PREGENERATED_CLASSES=true`, the runtime will use the pre-generated JS code from the appropriate `.som.js` file if it exists. This allows you to easily insert console.log statements, etc. into the JavaScript code, making it easier to debug runtime issues. 29 | -------------------------------------------------------------------------------- /bin/som.mjs: -------------------------------------------------------------------------------- 1 | import minimist from 'minimist' 2 | 3 | import { Environment } from '../src/evaluation.mjs' 4 | 5 | const argv = minimist(process.argv.slice(2), { 6 | string: ['classpath'] 7 | }) 8 | 9 | const classpath = Array.isArray(argv.classpath) 10 | ? argv.classpath 11 | : [argv.classpath] 12 | 13 | const env = new Environment() 14 | classpath.forEach(p => env.registerClasspath(p)) 15 | env.run(argv._) 16 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "ohm-som", 3 | "version": "0.1.0", 4 | "description": "A JavaScript implementation of the SOM Smalltalk dialect (som-st.github.io)", 5 | "main": "src/index.js", 6 | "scripts": { 7 | "test": "ava", 8 | "lint": "prettier-standard --check && standard", 9 | "format": "prettier-standard --format && standard --fix", 10 | "generate-classes": "node scripts/generateClassLib.mjs", 11 | "som-test-suite": "node $NODE_ARGS bin/som.mjs --classpath third_party/SOM-st/SOM/TestSuite TestHarness" 12 | }, 13 | "author": "Patrick Dubroy ", 14 | "license": "MIT", 15 | "devDependencies": { 16 | "ava": "^3.15.0", 17 | "prettier-standard": "^16.4.1", 18 | "standard": "^16.0.3", 19 | "walk-sync": "^2.2.0" 20 | }, 21 | "dependencies": { 22 | "fnv1a": "^1.0.1", 23 | "js-logger": "^1.6.1", 24 | "minimist": "^1.2.5", 25 | "ohm-js": "^15.5.0" 26 | }, 27 | "ava": { 28 | "files": [ 29 | "**/*.test.mjs", 30 | "**/test/**/*.mjs", 31 | "!**/*.som.js" 32 | ], 33 | "ignoredByWatcher": [ 34 | "**/*.som.js" 35 | ] 36 | } 37 | } 38 | -------------------------------------------------------------------------------- /scripts/generatePrimitives.mjs: -------------------------------------------------------------------------------- 1 | import fs from 'fs' 2 | 3 | import { grammar, semantics } from '../src/compilation.mjs' 4 | 5 | // Return an array of selectors representing all of the primitive methods in the class. 6 | semantics.addOperation('primitiveMethods', { 7 | Classdef (id, eq, superclass, instSlots, sep, classSlotsOpt, end) { 8 | const methods = instSlots.primitiveMethods().flat() 9 | const classSlots = classSlotsOpt.child(0) 10 | if (classSlots) { 11 | methods.push( 12 | ...classSlots 13 | .primitiveMethods() 14 | .flat() 15 | .map(o => ({ ...o, isStatic: true })) 16 | ) 17 | } 18 | return methods 19 | }, 20 | InstanceSlots (_, identIter, _end, methodIter) { 21 | return methodIter.primitiveMethods() 22 | }, 23 | ClassSlots (_, identIter, _end, methodIter) { 24 | return methodIter.primitiveMethods() 25 | }, 26 | Method (pattern, _, body) { 27 | if (body._node.ctorName === 'primitive') { 28 | return { 29 | selector: pattern.selector(), 30 | params: pattern.params({}) 31 | } 32 | } 33 | return [] 34 | } 35 | }) 36 | 37 | const inputFilename = process.argv[2] 38 | const matchResult = grammar.match(fs.readFileSync(inputFilename)) 39 | const root = semantics(matchResult) 40 | const className = root.className() 41 | console.log(`${className}: {`) 42 | root.primitiveMethods().forEach(({ isStatic, selector, params }) => { 43 | const prefix = isStatic ? 'static ' : '' 44 | console.log(` ${prefix}'${selector}'(${params}) { 45 | throw new Error('not implemented: ${className}>>${selector}') 46 | },`) 47 | }) 48 | console.log('}') 49 | -------------------------------------------------------------------------------- /src/ClassLoader.mjs: -------------------------------------------------------------------------------- 1 | import fs from 'fs' 2 | import prettier from 'prettier-standard' 3 | 4 | import { assert, checkNotNull } from './assert.mjs' 5 | import { compileClass } from './compilation.mjs' 6 | import { createClassStub } from './kernel.mjs' 7 | import { Logger } from './Logger.mjs' 8 | import { somClassLibPath } from './paths.mjs' 9 | import { getGlobal, setGlobal, sendMessage } from './runtime.mjs' 10 | 11 | const logger = Logger.get('classloading') 12 | 13 | export class ClassLoader { 14 | constructor (kernel, globals, primitives) { 15 | this._depth = -1 16 | this._primitives = new Map() 17 | this._classMap = new Map() 18 | 19 | // TODO: Put these in a class? E.g. `Runtime` (maybe with _eval too). 20 | this._sendMessage = (...args) => sendMessage(globals, ...args) 21 | this._setGlobal = (...args) => setGlobal(globals, ...args) 22 | this._getGlobal = (...args) => getGlobal(globals, ...args) 23 | 24 | this._registerPrimitives(primitives) 25 | this._initializeKernelClasses(kernel) 26 | this._nil = kernel.nil 27 | } 28 | 29 | _logInfo (msg) { 30 | const indent = new Array(this._depth + 1).join(' ') 31 | logger.info(`${indent}${msg}`) 32 | } 33 | 34 | _initializeKernelClasses (kernel) { 35 | // Load the compiled methods for the kernel classes. 36 | for (const name of ['Object', 'Class', 'Metaclass', 'Nil']) { 37 | const classObj = kernel[name] 38 | const filename = `${somClassLibPath}/${name}.som` 39 | const spec = this._getCompiledClass(filename) 40 | this._addMethodsToClass(classObj, spec, filename) 41 | this._classMap.set(name, { classObj }) 42 | } 43 | } 44 | 45 | _getPrimitives (name, defaultValue = {}) { 46 | return this._primitives.get(name) || defaultValue 47 | } 48 | 49 | _registerPrimitives (primitives) { 50 | for (const name in primitives) { 51 | assert( 52 | !this._primitives.has(name), 53 | `'${name}' primitives already registered` 54 | ) 55 | this._primitives.set(name, primitives[name]) 56 | } 57 | } 58 | 59 | // Create a new class named `name` which inherits from `superclass`. 60 | // Also creates the associated metaclass. 61 | _createClass ( 62 | name, 63 | superclass, 64 | instVarNames, 65 | instMethods, 66 | classVarNames = [], 67 | classMethods = {} 68 | ) { 69 | const classSlots = { ...classMethods, _instVarNames: classVarNames } 70 | classVarNames.forEach(n => (classSlots[`$${n}`] = this._nil)) 71 | const metaclass = createClassStub( 72 | this.loadClass('Metaclass'), 73 | `${name} class`, 74 | superclass.class(), 75 | classSlots 76 | ) 77 | 78 | const instSlots = { ...instMethods, _instVarNames: instVarNames } 79 | instVarNames.forEach(n => (instSlots[`$${n}`] = this._nil)) 80 | return createClassStub(metaclass, name, superclass, instSlots) 81 | } 82 | 83 | registerClass (className, filename) { 84 | const entry = this._classMap.get(className) || {} 85 | this._classMap.set(className, { ...entry, filename }) 86 | } 87 | 88 | loadClass (className) { 89 | const entry = checkNotNull( 90 | this._classMap.get(className), 91 | `no class map entry for '${className}'` 92 | ) 93 | 94 | if (entry.classObj) { 95 | return entry.classObj // Already loaded; return it. 96 | } 97 | 98 | this._depth += 1 99 | this._logInfo(`loadClass ${className}...`) 100 | assert( 101 | entry.filename !== undefined, 102 | `no known filename for class '${className}'` 103 | ) 104 | 105 | const spec = this._getCompiledClass(entry.filename) 106 | entry.classObj = this._loadCompiledClass(entry.filename, className, spec) 107 | 108 | this._logInfo(`✔ loaded ${className}`) 109 | this._depth -= 1 110 | 111 | return entry.classObj 112 | } 113 | 114 | loadClassFromSource (source, save = true) { 115 | const spec = compileClass(source) 116 | const { className } = spec 117 | const classObj = this._loadCompiledClass(undefined, className, spec) 118 | if (save) { 119 | this._classMap.set(className, { classObj }) 120 | } 121 | return { className, classObj } 122 | } 123 | 124 | _loadCompiledClass (filename, className, spec) { 125 | assert( 126 | spec.className === className, 127 | `Bad class name: expected '${className}', got '${spec.className}'` 128 | ) 129 | const superclass = this.loadClass(spec.superclassName || 'Object') 130 | const cls = this._createClass( 131 | className, 132 | superclass, 133 | spec.instanceVariableNames, 134 | this._getPrimitives(className), 135 | spec.classVariableNames, 136 | this._getPrimitives(`${className} class`) 137 | ) 138 | 139 | this._addMethodsToClass(cls, spec, filename) 140 | return cls 141 | } 142 | 143 | _getCompiledClass (filename) { 144 | const jsFilename = `${filename}.js` 145 | 146 | if ( 147 | Boolean(process.env.USE_PREGENERATED_CLASSES) && 148 | fs.existsSync(jsFilename) 149 | ) { 150 | this._logInfo(`Reading pre-compiled class from ${jsFilename}`) 151 | // Read in the source, dropping any leading `;` added by prettier. 152 | const jsSource = fs.readFileSync(jsFilename, 'utf-8').replace(/^;/, '') 153 | return this._eval(jsSource) 154 | } 155 | 156 | this._logInfo(`Compiling ${filename}`) 157 | const source = fs.readFileSync(filename, 'utf-8') 158 | return compileClass(source) 159 | } 160 | 161 | _eval (jsExpr) { 162 | // eslint-disable-next-line no-new-func 163 | return new Function('$', '$g', '$setG', 'nil', `return ${jsExpr}`)( 164 | this._sendMessage, 165 | this._getGlobal, 166 | this._setGlobal, 167 | this._nil 168 | ) 169 | } 170 | 171 | _addMethodsToClass (cls, spec, filenameForDebugging) { 172 | if (spec.instanceMethods != null) { 173 | // This is a pregenerated class -- no need to eval, just copy the methods. 174 | Object.assign(cls._prototype, spec.instanceMethods) 175 | Object.assign(cls.class()._prototype, spec.classMethods) 176 | return 177 | } 178 | 179 | const instMethods = spec.instanceMethodsToJS(cls) 180 | const classMethods = spec.classMethodsToJS(cls.class()) 181 | Object.assign(cls._prototype, this._eval(instMethods)) 182 | Object.assign(cls.class()._prototype, this._eval(classMethods)) 183 | 184 | // Optionally write the serialized, compiled class to disk for debugging. 185 | if (filenameForDebugging && Boolean(process.env.DEBUG_GENERATED_CLASSES)) { 186 | const jsFilename = `${filenameForDebugging}.js` 187 | this._logInfo(`Writing pre-compiled class to ${jsFilename}`) 188 | const prettyInstMethods = prettier.format(`(${instMethods})`) 189 | const prettyClassMethods = prettier.format(`(${classMethods})`) 190 | const output = ` 191 | ({ 192 | className: ${JSON.stringify(spec.className)}, 193 | superclassName: ${JSON.stringify(spec.superclassName)}, 194 | instanceVariableNames: ${JSON.stringify(spec.instanceVariableNames)}, 195 | classVariableNames: ${JSON.stringify(spec.classVariableNames)}, 196 | instanceMethods: ${prettyInstMethods.replace(/^;/, '')}, 197 | classMethods: ${prettyClassMethods.replace(/^;/, '')} 198 | }) 199 | ` 200 | fs.writeFileSync(jsFilename, prettier.format(output)) 201 | } 202 | } 203 | } 204 | -------------------------------------------------------------------------------- /src/Logger.mjs: -------------------------------------------------------------------------------- 1 | import Logger from 'js-logger' 2 | 3 | import { assert } from './assert.mjs' 4 | 5 | const isValidLoggerLevel = str => Logger[str] && Logger[str].name === str 6 | 7 | let defaultLevel = Logger.WARN 8 | const { LOG_LEVEL } = process.env 9 | 10 | if (LOG_LEVEL) { 11 | const level = LOG_LEVEL.toUpperCase() 12 | assert(isValidLoggerLevel(level), `Invalid value for LOG_LEVEL: ${LOG_LEVEL}`) 13 | defaultLevel = Logger[level] 14 | } 15 | 16 | Logger.useDefaults({ 17 | defaultLevel 18 | }) 19 | 20 | export { Logger } 21 | -------------------------------------------------------------------------------- /src/SOM.ohm: -------------------------------------------------------------------------------- 1 | /* 2 | Ohm grammar for SOM (som-st.github.io), a minimal Smalltalk for teaching and research. 3 | 4 | Based on https://github.com/SOM-st/SOM/blob/190fd72d5509bbfd5c190d3ed091920565cf79ae/specification/SOM.g4 5 | with some inspiration from https://github.com/moosetechnology/PetitParser/blob/development/src/PetitSmalltalk/PPSmalltalkGrammar.class.st 6 | */ 7 | SOM { 8 | Classdef = 9 | identifier equal Superclass InstanceSlots (separator ClassSlots)? endTerm 10 | 11 | Superclass = identifier? newTerm 12 | 13 | InstanceSlots = (or identifier* or)? Method* 14 | 15 | ClassSlots = (or identifier* or)? Method* 16 | 17 | Method = Pattern equal (primitive | MethodBlock) 18 | 19 | Pattern = UnaryPattern | BinaryPattern | KeywordPattern 20 | 21 | UnaryPattern = unarySelector 22 | 23 | BinaryPattern = binarySelector identifier 24 | 25 | KeywordPattern = (keyword identifier)+ 26 | 27 | MethodBlock = newTerm BlockContents? endTerm 28 | 29 | BlockContents = (or LocalDefs or)? BlockBody 30 | 31 | LocalDefs = identifier* 32 | 33 | BlockBody = 34 | | exit Result -- return 35 | | Expression (period BlockBody?)? -- rec 36 | 37 | Result = Expression period? 38 | 39 | Expression = 40 | | variable assign Expression -- assignment 41 | | KeywordExpression 42 | 43 | KeywordExpression = 44 | | KeywordExpression KeywordMessage -- rec 45 | | BinaryExpression 46 | 47 | KeywordMessage = (keyword BinaryExpression)+ 48 | 49 | BinaryExpression = 50 | | BinaryExpression BinaryMessage -- rec 51 | | UnaryExpression 52 | 53 | BinaryMessage = binarySelector UnaryExpression 54 | 55 | UnaryExpression = 56 | | UnaryExpression UnaryMessage -- rec 57 | | Primary 58 | 59 | UnaryMessage = unarySelector 60 | 61 | Primary = variable | NestedTerm | NestedBlock | Literal 62 | 63 | NestedTerm = newTerm Expression endTerm 64 | 65 | Literal = LiteralArray | LiteralSymbol | LiteralString | LiteralNumber 66 | 67 | LiteralArray = pound newTerm Literal* endTerm 68 | 69 | LiteralNumber = 70 | | minus? double -- double 71 | | minus? integer -- int 72 | 73 | LiteralSymbol = pound (string | selector) 74 | 75 | LiteralString = string 76 | 77 | NestedBlock = newBlock BlockPattern? BlockContents? endBlock 78 | 79 | BlockPattern = BlockArguments or 80 | 81 | BlockArguments = (colon identifier)+ 82 | 83 | // Lexical rules 84 | 85 | selector = unarySelector | binarySelector | keywordSelector 86 | 87 | unarySelector = (primitive | identifier) ~colon 88 | binarySelector = operatorSequence | operator 89 | keywordSelector = keyword+ 90 | keyword = identifier colon 91 | 92 | comment = quote (~quote any)* quote 93 | quote = "\"" 94 | space += comment 95 | 96 | variable = pseudoVariable | identifier 97 | 98 | identifier (an identifier) = letter idRest* 99 | idRest = letter | digit | "_" 100 | 101 | pseudoVariable = nil | true | false | self | super 102 | 103 | primitive = "primitive" ~idRest 104 | nil = "nil" ~idRest 105 | true = "true" ~idRest 106 | false = "false" ~idRest 107 | self = "self" ~idRest 108 | super = "super" ~idRest 109 | 110 | equal = "=" 111 | 112 | separator = "----" "-"* 113 | 114 | newTerm = "(" 115 | endTerm = ")" 116 | or = "|" 117 | 118 | comma = "," 119 | minus = "-" 120 | not = "~" 121 | and = "&" 122 | star = "*" 123 | div = "/" 124 | mod = "\\" 125 | plus = "+" 126 | more = ">" 127 | less = "<" 128 | at = "@" 129 | per = "%" 130 | 131 | operator = 132 | not | and | or | star | div | mod | plus | equal | more | less | comma | at | per | minus 133 | operatorSequence = ~separator operator+ 134 | 135 | newBlock = "[" 136 | endBlock = "]" 137 | 138 | colon = ":" 139 | pound = "#" 140 | exit = "^" 141 | period = "." 142 | assign = ":=" 143 | 144 | integer = digit+ 145 | double = digit+ "." digit+ 146 | 147 | string = "'" (escapeChar | ~("'" | "\\") any)* "'" 148 | 149 | escapeChar (an escape sequence) = 150 | | "\\t" -- tab 151 | | "\\b" -- backspace 152 | | "\\n" -- lineFeed 153 | | "\\r" -- carriageReturn 154 | | "\\f" -- formFeed 155 | | "\\0" -- null 156 | | "\\\'" -- singleQuote 157 | | "\\\\" -- backslash 158 | } 159 | -------------------------------------------------------------------------------- /src/assert.mjs: -------------------------------------------------------------------------------- 1 | export function assert (cond, message = undefined) { 2 | if (!cond) { 3 | throw new Error(message || 'assertion failed') 4 | } 5 | } 6 | 7 | export function checkNotNull (x, message = undefined) { 8 | if (x == null) { 9 | throw new Error(message || `expected non-null value: ${x}`) 10 | } 11 | return x 12 | } 13 | -------------------------------------------------------------------------------- /src/evaluation.mjs: -------------------------------------------------------------------------------- 1 | import fs from 'fs' 2 | import path from 'path' 3 | 4 | import { assert } from './assert.mjs' 5 | import { ClassLoader } from './ClassLoader.mjs' 6 | import { createKernel } from './kernel.mjs' 7 | import { somClassLibPath } from './paths.mjs' 8 | import { createPrimitives } from './primitives/index.mjs' 9 | import { createSuperProxy } from './runtime.mjs' 10 | 11 | export class Environment { 12 | constructor () { 13 | const g = (this.globals = Object.create(null)) 14 | const primitives = createPrimitives(this.globals) 15 | const kernel = createKernel(primitives) 16 | this._classLoader = new ClassLoader(kernel, this.globals, primitives) 17 | this.registerClasspath(somClassLibPath) 18 | 19 | Object.assign(this.globals, { 20 | true: g.True.new(), 21 | false: g.False.new(), 22 | nil: kernel.nil, 23 | system: g.System._new(g, this._classLoader), 24 | 25 | // Convenience constructors. 26 | _bool: val => (val ? g.true : g.false), 27 | _block1: fn => g.Block1._new(fn), 28 | _block2: fn => g.Block2._new(fn), 29 | _block3: fn => g.Block3._new(fn), 30 | 31 | _super: createSuperProxy, 32 | _symbolTable: new Map() 33 | }) 34 | 35 | g.Block._prototype['whileTrue:'] = 36 | g.Block._prototype['_OVERRIDE_whileTrue:'] 37 | } 38 | 39 | get (key) { 40 | return this.globals[key] 41 | } 42 | 43 | // Registers a class for lazy loading, if it is not already loaded. 44 | registerClass (className, filename = undefined) { 45 | if (!(className in this.globals)) { 46 | if (filename) { 47 | this._classLoader.registerClass(className, filename) 48 | } 49 | // TODO: Get rid of this, and let Object>>#unknownGlobal: trigger the 50 | // class load. But then we need to make sure all the native code uses 51 | // the same code path as generated code. 52 | Object.defineProperty(this.globals, className, { 53 | get: () => this._classLoader.loadClass(className), 54 | configurable: true, 55 | enumberable: true 56 | }) 57 | } 58 | } 59 | 60 | registerClasspath (classpath) { 61 | for (const filename of fs.readdirSync(classpath)) { 62 | if (path.extname(filename) === '.som') { 63 | const className = path.basename(filename, '.som') 64 | this.registerClass(className, path.join(classpath, filename)) 65 | } 66 | } 67 | } 68 | 69 | eval (source) { 70 | const Snippet = this._loadClassFromSource( 71 | `Snippet = (doIt = (^[${source}] value))`, 72 | false 73 | ) 74 | return Snippet.new().doIt() 75 | } 76 | 77 | loadClass (filename) { 78 | const ext = path.extname(filename) 79 | assert(ext === '.som', `Expected .som file, got ${ext} (${filename})`) 80 | const className = path.basename(filename, ext) 81 | this._classLoader.registerClass(className, filename) 82 | return this._classLoader.loadClass(className) 83 | } 84 | 85 | _loadClassFromSource (source, save = true) { 86 | const { className, classObj } = this._classLoader.loadClassFromSource( 87 | source, 88 | save 89 | ) 90 | if (save) { 91 | this.registerClass(className) 92 | } 93 | return classObj 94 | } 95 | 96 | run (args) { 97 | const { Array, String, system } = this.globals 98 | const argsArray = Array._new(args.map(arg => String._new(arg))) 99 | system['initialize:'](argsArray) 100 | } 101 | } 102 | 103 | export function doIt (source) { 104 | return new Environment().eval(source) 105 | } 106 | -------------------------------------------------------------------------------- /src/helpers.mjs: -------------------------------------------------------------------------------- 1 | import { assert } from './assert.mjs' 2 | 3 | export function allKeys (obj) { 4 | const keys = [] 5 | for (const k in obj) { 6 | keys.push(k) 7 | } 8 | keys.sort((a, b) => a.localeCompare(b)) 9 | return keys 10 | } 11 | 12 | // Properties beginning with '$' are field names. 13 | export const isFieldName = propName => propName[0] === '$' 14 | 15 | // Properties beginning with '_' are internal properties. 16 | export const isInternalProperty = propName => propName[0] === '_' 17 | 18 | // A selector is any property that is not a field name or an internal property. 19 | export const isSelector = propName => 20 | !isFieldName(propName) && !isInternalProperty(propName) 21 | 22 | export function arrayValue (obj) { 23 | return obj._checkIsKindOf('Array')._arr 24 | } 25 | 26 | export function integerValue (obj) { 27 | assert( 28 | obj._isInteger(), 29 | `Expected Integer, got ${stringValue(obj.class().name())}` 30 | ) 31 | return obj._val 32 | } 33 | 34 | export function numberValue (obj) { 35 | assert( 36 | obj._isInteger() || obj._isDouble(), 37 | `Expected Integer or Double, got ${stringValue(obj.class().name())}` 38 | ) 39 | return obj._val 40 | } 41 | 42 | export function stringValue (obj) { 43 | return obj._checkIsKindOf('String')._str 44 | } 45 | -------------------------------------------------------------------------------- /src/kernel.mjs: -------------------------------------------------------------------------------- 1 | /* 2 | The diagram below shows the structure of the kernel classes in SOM. 3 | This is a simplified version of the blue book kernel -- there is no 4 | Behavior or ClassDescription. 5 | 6 | ┌────────────────────────────────────────┐ 7 | │ ┌──────────────┐ ┌───────┴──────┐ 8 | │ │ Object ├───is-a───►│ Object class ├─is-a─┐ 9 | │ └──────────────┘ └──────────────┘ │ 10 | │ ▲ ▲ ▼ 11 | │ ┌───────┴──────┐ ┌───────┴──────┐ │ 12 | └────►│ Class ├───is-a───►│ Class class ├─is-a─┤ 13 | └──────────────┘ └──────────────┘ │ 14 | ▲ ▲ ▼ 15 | ┌───────┴──────┐ ┌───────┴──────┐ │ 16 | │ Metaclass ├───is-a───►│ Metaclass ├─is-a─┤ 17 | └──────────────┘ │ class │ │ 18 | ▲ └──────────────┘ ▼ 19 | └────────────────────────────────────────┘ 20 | 21 | ────────► : inheritance 22 | ──is-a──► : instantiation 23 | */ 24 | 25 | function extend (obj, props = {}) { 26 | return Object.assign(Object.create(obj), props) 27 | } 28 | 29 | // Create a new stub class object named `name` as an instance of `cls`. 30 | export function createClassStub (cls, name, superclass, instSlots = {}) { 31 | const classObj = extend(cls && cls._prototype, { 32 | _name: name, 33 | _prototype: extend(superclass._prototype, instSlots) 34 | }) 35 | classObj._prototype.class = () => classObj 36 | return classObj 37 | } 38 | 39 | // Returns freshly-created set of kernel classes/objects. 40 | export function createKernel (primitives) { 41 | // First, create stubs. 42 | const SomObject = createClassStub( 43 | null, // -> ObjectClass -- see (1), below 44 | 'Object', 45 | { _prototype: null }, // -> Seen as `nil` -- see (4) 46 | primitives.Object 47 | ) 48 | 49 | const Class = createClassStub( 50 | null, // -> ClassClass (2) 51 | 'Class', 52 | SomObject, 53 | primitives.Class 54 | ) 55 | Class._prototype.class = () => Class 56 | 57 | const Metaclass = createClassStub( 58 | null, // -> MetaclassClass (3) 59 | 'Metaclass', 60 | Class 61 | ) 62 | 63 | // Now create the metaclasses and wire them up. 64 | // Note that SOM is different from Smalltalk-80 in that `Metaclass superclass` 65 | // is Class, not ClassDescription. 66 | 67 | const ObjectClass = createClassStub(Metaclass, 'Object class', Class) 68 | const ClassClass = createClassStub(Metaclass, 'Class class', ObjectClass) 69 | const MetaclassClass = createClassStub( 70 | Metaclass, 71 | 'Metaclass class', 72 | ClassClass 73 | ) 74 | 75 | // (1) Object is-a ObjectClass 76 | Reflect.setPrototypeOf(SomObject, ObjectClass._prototype) 77 | SomObject.class = () => ObjectClass 78 | 79 | // (2) Class is-a ClassClass 80 | Reflect.setPrototypeOf(Class, ClassClass._prototype) 81 | Class.class = () => ClassClass 82 | 83 | // (3) Metaclass is-a MetaclassClass 84 | Reflect.setPrototypeOf(Metaclass, MetaclassClass._prototype) 85 | Metaclass.class = () => MetaclassClass 86 | 87 | // Create `nil`, which is required for initializing other classes. 88 | const NilClass = createClassStub(Metaclass, 'Nil class', ObjectClass) 89 | const Nil = createClassStub(NilClass, 'Nil', SomObject) 90 | const nil = Nil.new() 91 | 92 | // (4) Implement superclass and ensure `Object superclass` returns `nil`. 93 | Class._prototype.superclass = function () { 94 | const parentProto = Reflect.getPrototypeOf(this._prototype) 95 | return parentProto === null ? nil : parentProto.class() 96 | } 97 | 98 | return { Object: SomObject, Class, Metaclass, Nil, nil } 99 | } 100 | -------------------------------------------------------------------------------- /src/paths.mjs: -------------------------------------------------------------------------------- 1 | import path from 'path' 2 | import { fileURLToPath } from 'url' 3 | 4 | const __dirname = path.dirname(fileURLToPath(import.meta.url)) 5 | 6 | export const somTestSuitePath = path.join( 7 | __dirname, 8 | '../third_party/SOM-st/SOM/TestSuite' 9 | ) 10 | 11 | export const somGrammarPath = path.join(__dirname, 'SOM.ohm') 12 | 13 | export const somClassLibPath = path.join( 14 | __dirname, 15 | '../third_party/SOM-st/SOM/Smalltalk' 16 | ) 17 | 18 | export const generatedClassesPath = path.join(__dirname, 'classes/generated') 19 | 20 | export const testDataPath = path.join(__dirname, '../test/data') 21 | -------------------------------------------------------------------------------- /src/primitives/Array.mjs: -------------------------------------------------------------------------------- 1 | import { integerValue } from '../helpers.mjs' 2 | 3 | export default g => ({ 4 | Array: { 5 | 'at:' (index) { 6 | return this._arr[integerValue(index) - 1] 7 | }, 8 | 'at:put:' (index, value) { 9 | return (this._arr[integerValue(index) - 1] = value) 10 | }, 11 | length () { 12 | return g.Integer._new(this._arr.length) 13 | } 14 | }, 15 | 'Array class': { 16 | _new (arr = []) { 17 | return this._basicNew({ _arr: arr }) 18 | }, 19 | 'new:' (length) { 20 | const arr = [] 21 | const primitiveLength = integerValue(length) 22 | for (let i = 0; i < primitiveLength; i++) { 23 | arr.push(g.nil) 24 | } 25 | return this._new(arr) 26 | } 27 | } 28 | }) 29 | -------------------------------------------------------------------------------- /src/primitives/Block.mjs: -------------------------------------------------------------------------------- 1 | export default g => ({ 2 | Block: { 3 | value () { 4 | return this._fn() 5 | }, 6 | restart () { 7 | throw new Error('Not supported: Block>>restart') 8 | }, 9 | '_OVERRIDE_whileTrue:' (block) { 10 | while (this.value() === g.true) { 11 | block.value() 12 | } 13 | return g.nil 14 | } 15 | }, 16 | 'Block class': { 17 | _new (fn) { 18 | return this._basicNew({ _fn: fn }) 19 | } 20 | }, 21 | Block1: { 22 | value () { 23 | return this._fn() 24 | } 25 | }, 26 | Block2: { 27 | 'value:' (arg) { 28 | return this._fn(arg) 29 | } 30 | }, 31 | Block3: { 32 | 'value:with:' (arg1, arg2) { 33 | return this._fn(arg1, arg2) 34 | } 35 | } 36 | }) 37 | -------------------------------------------------------------------------------- /src/primitives/Class.mjs: -------------------------------------------------------------------------------- 1 | import { isFieldName, isSelector } from '../helpers.mjs' 2 | 3 | export default g => ({ 4 | Class: { 5 | name () { 6 | return g.Symbol._new(this._name) 7 | }, 8 | superclass () { 9 | throw new Error('should not be called — overridden in kernel.mjs') 10 | }, 11 | _basicNew (props) { 12 | const self = Object.create(this._prototype) 13 | return Object.assign(self, props) 14 | }, 15 | new () { 16 | return Object.create(this._prototype) 17 | }, 18 | fields () { 19 | const fieldNames = this._allInstVarNames() 20 | return g.Array._new(fieldNames.map(name => g.String._new(name))) 21 | }, 22 | methods () { 23 | return g.Array._new( 24 | Object.keys(this._prototype) 25 | .filter(isSelector) 26 | .map(name => g.Method._new(this, name)) 27 | ) 28 | }, 29 | 30 | // ----- Additions in ohm-som ----- 31 | _allInstVarNames () { 32 | const names = [] 33 | 34 | // We need to manually walk up the prototype chain because Object.keys() 35 | // will see all of the global symbols ($nil, etc.) on Object._prototype. 36 | let proto = this._prototype 37 | while (proto != null) { 38 | for (const name of Object.getOwnPropertyNames(proto)) { 39 | if (isFieldName(name)) { 40 | names.push(name.slice(1)) // Strip the '$' 41 | } 42 | } 43 | proto = Object.getPrototypeOf(proto) 44 | } 45 | return names 46 | } 47 | } 48 | }) 49 | -------------------------------------------------------------------------------- /src/primitives/Double.mjs: -------------------------------------------------------------------------------- 1 | import { numberValue } from '../helpers.mjs' 2 | 3 | export default g => ({ 4 | Double: { 5 | '+' (argument) { 6 | return g.Double._new(this._val + numberValue(argument)) 7 | }, 8 | '-' (argument) { 9 | return g.Double._new(this._val - numberValue(argument)) 10 | }, 11 | '*' (argument) { 12 | return g.Double._new(this._val * numberValue(argument)) 13 | }, 14 | '//' (argument) { 15 | return g.Double._new(this._val / numberValue(argument)) 16 | }, 17 | '%' (argument) { 18 | return g.Double._new(this._val % numberValue(argument)) 19 | }, 20 | sqrt () { 21 | return g.Double._new(Math.sqrt(this._val)) 22 | }, 23 | round () { 24 | return g.Integer._new(Math.round(this._val)) 25 | }, 26 | asInteger () { 27 | return g.Integer._new(Math.trunc(this._val)) 28 | }, 29 | cos () { 30 | return g.Double._new(Math.cos(this._val)) 31 | }, 32 | sin () { 33 | return g.Double._new(Math.sin(this._val)) 34 | }, 35 | '=' (argument) { 36 | return g._bool(this._val === numberValue(argument)) 37 | }, 38 | '<' (argument) { 39 | return g._bool(this._val < numberValue(argument)) 40 | }, 41 | asString () { 42 | return g.String._new(`${this._val}`) 43 | }, 44 | 45 | // ----- ohm-som additions ----- 46 | _isDouble () { 47 | return true 48 | } 49 | }, 50 | 'Double class': { 51 | _new (val) { 52 | return this._basicNew({ _val: val }) 53 | }, 54 | PositiveInfinity () { 55 | return g.Double._new(Number.POSITIVE_INFINITY) 56 | } 57 | } 58 | }) 59 | -------------------------------------------------------------------------------- /src/primitives/Integer.mjs: -------------------------------------------------------------------------------- 1 | import { integerValue, numberValue, stringValue } from '../helpers.mjs' 2 | 3 | // From https://2ality.com/2012/02/js-integers.html (danke @rauschma) 4 | const modulo = (a, b) => a - Math.floor(a / b) * b 5 | const toUint32 = x => modulo(x - (x % 1), Math.pow(2, 32)) 6 | const toInt32 = x => { 7 | const uint32 = toUint32(x) 8 | return uint32 >= Math.pow(2, 31) ? uint32 - Math.pow(2, 32) : uint32 9 | } 10 | 11 | export default g => ({ 12 | Integer: { 13 | // ----- Arithmetic ----- 14 | 15 | '+' (other) { 16 | const cls = other._isInteger() ? g.Integer : g.Double 17 | return cls._new(this._val + numberValue(other)) 18 | }, 19 | '-' (other) { 20 | const cls = other._isInteger() ? g.Integer : g.Double 21 | return cls._new(this._val - numberValue(other)) 22 | }, 23 | '*' (other) { 24 | const cls = other._isInteger() ? g.Integer : g.Double 25 | return cls._new(this._val * numberValue(other)) 26 | }, 27 | // Integer division 28 | '/' (other) { 29 | return g.Integer._new(Math.floor(this._val / numberValue(other))) 30 | }, 31 | // Double division 32 | '//' (argument) { 33 | // Same as Double 34 | return g.Double._new(this._val / numberValue(argument)) 35 | }, 36 | // modulo 37 | '%' (divisor) { 38 | const cls = divisor._isInteger() ? g.Integer : g.Double 39 | return cls._new(modulo(this._val, numberValue(divisor))) 40 | }, 41 | // remainder 42 | 'rem:' (divisor) { 43 | const cls = divisor._isInteger() ? g.Integer : g.Double 44 | return cls._new(this._val % numberValue(divisor)) 45 | }, 46 | '&' (argument) { 47 | return g.Integer._new(this._val & integerValue(argument)) 48 | }, 49 | '<<' (argument) { 50 | // Avoid using the native `<<` operator, because that converts to int32. 51 | return g.Integer._new(this._val * Math.pow(2, integerValue(argument))) 52 | }, 53 | '>>>' (argument) { 54 | return g.Integer._new(this._val >>> integerValue(argument)) 55 | }, 56 | 'bitXor:' (argument) { 57 | return g.Integer._new(this._val ^ integerValue(argument)) 58 | }, 59 | sqrt () { 60 | // Almost the same as Double, but uses Integer if possible. 61 | const val = Math.sqrt(this._val) 62 | return Number.isInteger(val) ? g.Integer._new(val) : g.Double._new(val) 63 | }, 64 | 65 | // ----- Random numbers ----- 66 | atRandom () { 67 | throw new Error('not implemented') 68 | }, 69 | 70 | // ----- Comparing ----- 71 | 72 | '=' (other) { 73 | return g._bool( 74 | (other._isInteger() || other._isDouble()) && 75 | this._val === numberValue(other) 76 | ) 77 | }, 78 | // Integers are always compared by value (not reference) equality. 79 | // Note that this is not actually specified as a primitive in Integer.som. 80 | // See https://github.com/SOM-st/SOM/pull/75 81 | '==' (other) { 82 | return this['='](other) 83 | }, 84 | '<' (other) { 85 | return g._bool( 86 | (other._isInteger() || other._isDouble()) && 87 | this._val < numberValue(other) 88 | ) 89 | }, 90 | 91 | // ----- Converting ----- 92 | 93 | asString () { 94 | return g.String._new(`${this._val}`) 95 | }, 96 | as32BitSignedValue () { 97 | return g.Integer._new(toInt32(this._val)) 98 | }, 99 | as32BitUnsignedValue () { 100 | return g.Integer._new(toUint32(this._val)) 101 | }, 102 | 103 | // ----- ohm-som additions ----- 104 | 105 | _isInteger () { 106 | return true 107 | } 108 | }, 109 | 110 | 'Integer class': { 111 | _new (val) { 112 | return this._basicNew({ _val: val }) 113 | }, 114 | _newFromString (str) { 115 | return this._new(parseInt(str, 10)) 116 | }, 117 | 'fromString:' (aString) { 118 | return this._newFromString(stringValue(aString)) 119 | } 120 | } 121 | }) 122 | -------------------------------------------------------------------------------- /src/primitives/Method.mjs: -------------------------------------------------------------------------------- 1 | import { assert } from '../assert.mjs' 2 | 3 | export default g => ({ 4 | Method: { 5 | signature () { 6 | return g.String._new(this._signature) 7 | }, 8 | holder () { 9 | return this._holder 10 | }, 11 | 'invokeOn:with:' (obj, args) { 12 | this._nativeMethod.apply(obj, args) 13 | } 14 | }, 15 | 'Method class': { 16 | _new (classObj, signature) { 17 | const nativeMethod = classObj._prototype[signature] 18 | assert( 19 | nativeMethod, 20 | `No such method '${signature}' on ${classObj.name()}` 21 | ) 22 | return this._basicNew({ 23 | _signature: signature, 24 | _holder: classObj, 25 | _nativeMethod: nativeMethod 26 | }) 27 | } 28 | } 29 | }) 30 | -------------------------------------------------------------------------------- /src/primitives/Object.mjs: -------------------------------------------------------------------------------- 1 | import fnv1a from 'fnv1a' 2 | 3 | import { assert, checkNotNull } from '../assert.mjs' 4 | import { integerValue, arrayValue, stringValue } from '../helpers.mjs' 5 | 6 | export default g => ({ 7 | Object: { 8 | objectSize () { 9 | throw new Error('not implemented') 10 | }, 11 | 12 | '==' (other) { 13 | return g._bool(this === other) 14 | }, 15 | 16 | hashcode () { 17 | if (this._hashcode === undefined) { 18 | this._hashcode = fnv1a(new Date().toISOString()) 19 | } 20 | return g.Integer._new(this._hashcode) 21 | }, 22 | 23 | inspect () { 24 | throw new Error('not implemented') 25 | }, 26 | 27 | halt () { 28 | throw new Error('not implemented') 29 | }, 30 | 31 | 'perform:' (selector) { 32 | return this[stringValue(selector)]() 33 | }, 34 | 35 | 'perform:withArguments:' (selector, args) { 36 | return this[stringValue(selector)](...arrayValue(args)) 37 | }, 38 | 39 | 'perform:inSuperclass:' (selector, cls) { 40 | assert(cls === this.class().superclass()) 41 | return cls._prototype[stringValue(selector)].call(this) 42 | }, 43 | 44 | 'perform:withArguments:inSuperclass:' (selector, args, cls) { 45 | assert(cls === this.class().superclass()) 46 | return cls._prototype[stringValue(selector)].apply(this, arrayValue(args)) 47 | }, 48 | 49 | 'instVarAt:' (idx) { 50 | const name = this._instVarNames[integerValue(idx) - 1] 51 | return this[`$${name}`] 52 | }, 53 | 54 | 'instVarAt:put:' (idx, obj) { 55 | const name = this._instVarNames[integerValue(idx) - 1] 56 | return (this[`$${name}`] = obj) 57 | }, 58 | 59 | 'instVarNamed:' (sym) { 60 | return this[`$${stringValue(sym)}`] 61 | }, 62 | 63 | // ----- ohm-som additions ----- 64 | 65 | _isKindOf (cls) { 66 | let proto = this 67 | while ((proto = Object.getPrototypeOf(proto))) { 68 | if (proto === cls._prototype) { 69 | return true 70 | } 71 | } 72 | return false 73 | }, 74 | _checkIsKindOf (className) { 75 | const cls = checkNotNull(g[className], `No class named '${className}'`) 76 | assert(this._isKindOf(cls), `Not a ${className}`) 77 | return this 78 | }, 79 | _isInteger () { 80 | return false 81 | }, 82 | _isDouble () { 83 | return false 84 | } 85 | } 86 | }) 87 | -------------------------------------------------------------------------------- /src/primitives/String.mjs: -------------------------------------------------------------------------------- 1 | import fnv1a from 'fnv1a' 2 | 3 | import { integerValue, stringValue } from '../helpers.mjs' 4 | 5 | export default g => ({ 6 | String: { 7 | 'concatenate:' (argument) { 8 | return g.String._new(this._str + stringValue(argument.asString())) 9 | }, 10 | asSymbol () { 11 | return g.Symbol._new(this._str) 12 | }, 13 | hashcode () { 14 | if (this._hashcode === undefined) { 15 | this._hashcode = fnv1a(this._str) 16 | } 17 | return g.Integer._new(this._hashcode) 18 | }, 19 | length () { 20 | return g.Integer._new(this._str.length) 21 | }, 22 | isWhiteSpace () { 23 | return g._bool(/^\s+$/.test(this._str)) 24 | }, 25 | isLetters () { 26 | return g._bool(/^\p{L}+$/u.test(this._str)) 27 | }, 28 | isDigits () { 29 | return g._bool(/^[0-9]+$/.test(this._str)) 30 | }, 31 | '=' (argument) { 32 | return g._bool( 33 | argument._isKindOf(g.String) && argument._str === this._str 34 | ) 35 | }, 36 | 'primSubstringFrom:to:' (start, end) { 37 | const startVal = integerValue(start) - 1 38 | const endVal = integerValue(end) 39 | return g.String._new(this._str.slice(startVal, endVal)) 40 | }, 41 | [Symbol.toPrimitive] (hint) { 42 | return this._str 43 | } 44 | }, 45 | 'String class': { 46 | _new (str) { 47 | return this._basicNew({ _str: str }) 48 | } 49 | } 50 | }) 51 | -------------------------------------------------------------------------------- /src/primitives/Symbol.mjs: -------------------------------------------------------------------------------- 1 | export default g => ({ 2 | Symbol: { 3 | asString () { 4 | return g.String._new(this._str) 5 | } 6 | }, 7 | 'Symbol class': { 8 | _new (str) { 9 | let sym = g._symbolTable.get(str) 10 | if (!sym) { 11 | sym = this._basicNew({ _str: str }) 12 | g._symbolTable.set(str, sym) 13 | } 14 | return sym 15 | } 16 | } 17 | }) 18 | -------------------------------------------------------------------------------- /src/primitives/System.mjs: -------------------------------------------------------------------------------- 1 | import { performance } from 'perf_hooks' 2 | 3 | import { stringValue } from '../helpers.mjs' 4 | 5 | export default g => ({ 6 | System: { 7 | 'global:' (aSymbol) { 8 | return this._global(stringValue(aSymbol)) 9 | }, 10 | _global (name) { 11 | return this._globals[name] 12 | }, 13 | 'global:put:' (aSymbol, value) { 14 | const name = stringValue(aSymbol) 15 | this._globals[name] = value 16 | return this 17 | }, 18 | 'hasGlobal:' (aSymbol) { 19 | const name = stringValue(aSymbol) 20 | return g._bool(name in this._globals) 21 | }, 22 | 'load:' (symbol) { 23 | return this._load(stringValue(symbol)) 24 | }, 25 | _load (className) { 26 | return this._classLoader.loadClass(className) 27 | }, 28 | 'exit:' (errno) { 29 | process.exit(errno) 30 | }, 31 | 'printString:' (string) { 32 | process.stdout.write(stringValue(string)) 33 | return this 34 | }, 35 | printNewline () { 36 | console.log() 37 | return this 38 | }, 39 | time () { 40 | throw new Error('not implemented') 41 | }, 42 | ticks () { 43 | return g.Integer._new(Math.round(performance.now() * 1000)) 44 | }, 45 | fullGC () { 46 | return g.false 47 | } 48 | }, 49 | 'System class': { 50 | _new (globals, classLoader) { 51 | return this._basicNew({ _globals: globals, _classLoader: classLoader }) 52 | } 53 | } 54 | }) 55 | -------------------------------------------------------------------------------- /src/primitives/index.mjs: -------------------------------------------------------------------------------- 1 | import arrayPrimitives from './Array.mjs' 2 | import blockPrimitives from './Block.mjs' 3 | import classPrimitives from './Class.mjs' 4 | import doublePrimitives from './Double.mjs' 5 | import integerPrimitives from './Integer.mjs' 6 | import methodPrimitives from './Method.mjs' 7 | import objectPrimitives from './Object.mjs' 8 | import stringPrimitives from './String.mjs' 9 | import symbolPrimitives from './Symbol.mjs' 10 | import systemPrimitives from './System.mjs' 11 | 12 | export const createPrimitives = (...args) => ({ 13 | ...arrayPrimitives(...args), 14 | ...blockPrimitives(...args), 15 | ...classPrimitives(...args), 16 | ...doublePrimitives(...args), 17 | ...integerPrimitives(...args), 18 | ...methodPrimitives(...args), 19 | ...objectPrimitives(...args), 20 | ...stringPrimitives(...args), 21 | ...symbolPrimitives(...args), 22 | ...systemPrimitives(...args) 23 | }) 24 | 25 | export const createKernelPrimitivesForTesting = (...args) => ({ 26 | ...classPrimitives(...args), 27 | ...objectPrimitives(...args) 28 | }) 29 | -------------------------------------------------------------------------------- /src/runtime.mjs: -------------------------------------------------------------------------------- 1 | import { checkNotNull } from './assert.mjs' 2 | import { isSelector } from './helpers.mjs' 3 | import { Logger } from './Logger.mjs' 4 | 5 | const logger = Logger.get('runtime') 6 | 7 | const superProxyHandler = { 8 | get (target, propName, _receiver) { 9 | if (isSelector(propName)) { 10 | const superclass = target.class().superclass() 11 | return superclass._prototype[propName] 12 | } 13 | return Reflect.get(...arguments) 14 | } 15 | } 16 | 17 | export function createSuperProxy (target) { 18 | return new Proxy(target, superProxyHandler) 19 | } 20 | 21 | export function sendMessage (globals, receiver, selector, ...args) { 22 | checkNotNull(receiver, `receiver of #${selector} is null`) 23 | logger.info( 24 | `sending ${receiver.class()._name}>>#${selector} w/ ${args.length} args` 25 | ) 26 | if (selector in receiver) { 27 | return receiver[selector](...args) 28 | } 29 | return receiver['doesNotUnderstand:arguments:']( 30 | globals.Symbol._new(selector), 31 | globals.Array._new(args) 32 | ) 33 | } 34 | 35 | export function getGlobal (globals, name, receiver) { 36 | if (name in globals) { 37 | return globals[name] 38 | } 39 | return receiver['unknownGlobal:'](globals.Symbol._new(name)) 40 | } 41 | 42 | export function setGlobal (globals, name, value, receiver) { 43 | globals[name] = value 44 | } 45 | -------------------------------------------------------------------------------- /src/test/ClassLoader.test.mjs: -------------------------------------------------------------------------------- 1 | import test from 'ava' 2 | import path from 'path' 3 | 4 | import { ClassLoader } from '../ClassLoader.mjs' 5 | import { createKernel } from '../kernel.mjs' 6 | import { testDataPath } from '../paths.mjs' 7 | import { createKernelPrimitivesForTesting } from '../primitives/index.mjs' 8 | 9 | function createKernelForTesting (globals) { 10 | const primitives = createKernelPrimitivesForTesting(globals) 11 | return createKernel(primitives) 12 | } 13 | 14 | function createClassLoaderForTesting () { 15 | const globals = Object.create(null) 16 | const loader = new ClassLoader(createKernelForTesting(globals), globals) 17 | 18 | globals.Object = loader.loadClass('Object') 19 | 20 | // Install a fake String constructor that just returns a native string 21 | globals.String = { _new: str => str } 22 | 23 | return loader 24 | } 25 | 26 | test('primitive methods', t => { 27 | const loader = createClassLoaderForTesting() 28 | loader._registerPrimitives({ 29 | Thing: { 30 | primitiveMethod: () => 'primitive method' 31 | }, 32 | 'Thing class': { 33 | primitiveMethod: () => 'primitive class method' 34 | } 35 | }) 36 | loader.registerClass('Thing', path.join(testDataPath, 'Thing.som')) 37 | const Thing = loader.loadClass('Thing') 38 | 39 | const aThing = Thing.new() 40 | t.is(typeof aThing.primitiveMethod, 'function') 41 | t.is(aThing.primitiveMethod(), 'primitive method') 42 | 43 | t.is(typeof Thing.primitiveMethod, 'function') 44 | t.is(Thing.primitiveMethod(), 'primitive class method') 45 | }) 46 | 47 | test('compiled methods', t => { 48 | const loader = createClassLoaderForTesting() 49 | loader.registerClass('Thing', path.join(testDataPath, 'Thing.som')) 50 | const Thing = loader.loadClass('Thing') 51 | 52 | const aThing = Thing.new() 53 | t.is(typeof aThing.asString, 'function') 54 | t.is(aThing.asString(), 'a thing') 55 | 56 | t.is(typeof Thing.className, 'function') 57 | t.is(Thing.className(), 'Thing!') 58 | }) 59 | -------------------------------------------------------------------------------- /src/test/evaluation.test.mjs: -------------------------------------------------------------------------------- 1 | import test from 'ava' 2 | 3 | import { doIt, Environment } from '../evaluation.mjs' 4 | import { integerValue, stringValue } from '../helpers.mjs' 5 | 6 | test('class hierarchy', t => { 7 | t.is(stringValue(doIt('Object name')), 'Object') 8 | t.is(stringValue(doIt('Object class name')), 'Object class') 9 | t.is(stringValue(doIt('Object superclass asString')), 'nil') 10 | t.is(stringValue(doIt('Object class class name')), 'Metaclass') 11 | t.is(stringValue(doIt('Metaclass class class name')), 'Metaclass') 12 | // t.is(doIt('Set class methods size asString'), '1') 13 | }) 14 | 15 | test('isKindOf', t => { 16 | const env = new Environment() 17 | const Class = env.get('Class') 18 | const Metaclass = env.get('Metaclass') 19 | t.true(Class.new()._isKindOf(Class)) 20 | t.true(Metaclass.new()._isKindOf(Class)) 21 | }) 22 | 23 | test('basic eval w/ PrimitiveInteger', t => { 24 | t.is(stringValue(doIt('(3 + 4) asString')), '7') 25 | t.is(stringValue(doIt('| x y | x := 3. y := 4. ^(x + y) asString')), '7') 26 | }) 27 | 28 | test('full eval with real Integer class', t => { 29 | t.is(stringValue(doIt('4 negated asString')), '-4') 30 | t.is(stringValue(doIt('(3 + (1 negated - 2)) asString')), '0') 31 | 32 | t.is(stringValue(doIt("(Integer fromString: '42') asString")), '42') 33 | t.is(stringValue(doIt('(2 < 1) asString')), 'false') 34 | }) 35 | 36 | test('evaluation with boolean classes', t => { 37 | t.is(stringValue(doIt('true asString')), 'true') 38 | t.is(stringValue(doIt('(true or: []) asString')), 'true') 39 | 40 | t.is(stringValue(doIt('false asString')), 'false') 41 | t.is(stringValue(doIt('(false and: []) asString')), 'false') 42 | }) 43 | 44 | test('block value', t => { 45 | t.is(stringValue(doIt('[true] value asString')), 'true') 46 | t.is(stringValue(doIt('[[true] value] value asString')), 'true') 47 | t.is(stringValue(doIt('[|x| x := 3. x + 1] value asString')), '4') 48 | }) 49 | 50 | test('non-local returns', t => { 51 | t.is(stringValue(doIt("[^'a'] value. 'b'")), 'a') 52 | t.is(stringValue(doIt("[[^'a'] value. 'b'] value. 'c'")), 'a') 53 | t.is(stringValue(doIt("true ifTrue: ['a'] ifFalse: ['b']")), 'a') 54 | }) 55 | 56 | test('class methods', t => { 57 | const env = new Environment() 58 | const Thing = env._loadClassFromSource('Thing = (---- twiddle = ())') 59 | t.is(typeof Thing.twiddle, 'function') 60 | 61 | t.is(stringValue(env.eval('Thing twiddle name')), 'Thing') 62 | t.is(stringValue(env.eval('Thing new isNil asString')), 'false') 63 | }) 64 | 65 | test('classes are objects too', t => { 66 | t.is(stringValue(doIt('True isNil asString')), 'false') 67 | t.is(stringValue(doIt('Integer name')), 'Integer') 68 | t.is(stringValue(doIt('Integer new class name')), 'Integer') 69 | }) 70 | 71 | test('implicit self return', t => { 72 | const env = new Environment() 73 | const Thing = env._loadClassFromSource( 74 | 'Thing = (yourself = () yourself2 = (2))' 75 | ) 76 | t.is(env.globals.Thing, Thing) 77 | t.is(env.eval('Thing new yourself class'), Thing) 78 | t.is(env.eval('Thing new yourself2 class'), Thing) 79 | }) 80 | 81 | test('Integer>>to:do:', t => { 82 | const env = new Environment() 83 | let count = 0 84 | env._classLoader._registerPrimitives({ 85 | Test: { 86 | incrementCount () { 87 | count += 1 88 | return this.$nil 89 | } 90 | } 91 | }) 92 | const Test = env._loadClassFromSource( 93 | `Test = ( 94 | run = (1 to: 5 do: [ :i | self incrementCount]) 95 | run2 = (1 to: 1 do: [ :i | self incrementCount]) 96 | run3 = (1 to: 0 do: [ :i | self incrementCount]) 97 | )` 98 | ) 99 | const aTest = Test.new() 100 | aTest.run() 101 | t.is(count, 5) 102 | 103 | aTest.run2() 104 | t.is(count, 6) 105 | 106 | aTest.run3() 107 | t.is(count, 6) 108 | }) 109 | 110 | test('Instance variables initialized to nil', t => { 111 | const env = new Environment() 112 | env._loadClassFromSource(` 113 | Thing = ( 114 | | instVar | 115 | instVar = (^instVar) 116 | ---- 117 | | classVar | 118 | classVar = (^classVar) 119 | ) 120 | `) 121 | t.is(env.eval('Thing new instVar'), env.get('nil')) 122 | t.is(env.eval('Thing classVar'), env.get('nil')) 123 | }) 124 | 125 | test('Class variables', t => { 126 | const env = new Environment() 127 | env._loadClassFromSource(` 128 | Thing = ( 129 | ---- 130 | | x | 131 | setX: value = (x := value) 132 | x = (^x) 133 | ) 134 | `) 135 | t.is(integerValue(env.eval('(Thing setX: 3) x')), 3) 136 | }) 137 | -------------------------------------------------------------------------------- /src/test/kernel.test.mjs: -------------------------------------------------------------------------------- 1 | import test from 'ava' 2 | 3 | import { createKernelPrimitivesForTesting } from '../primitives/index.mjs' 4 | import { createKernel } from '../kernel.mjs' 5 | 6 | function createKernelForTesting () { 7 | const globals = Object.create(null) 8 | 9 | // Fake the Symbol constructor to make it return a native string. 10 | globals.Symbol = { _new: str => str } 11 | 12 | const primitives = createKernelPrimitivesForTesting(globals) 13 | return createKernel(primitives) 14 | } 15 | 16 | test('kernel classes', t => { 17 | const { Object, Class, Metaclass, Nil, nil } = createKernelForTesting() 18 | 19 | t.is(Object.name(), 'Object') 20 | t.is(Object.class().name(), 'Object class') 21 | t.is(Object.superclass(), nil) 22 | t.is( 23 | Object.class() 24 | .class() 25 | .name(), 26 | 'Metaclass' 27 | ) 28 | t.is( 29 | Metaclass.class() 30 | .class() 31 | .name(), 32 | 'Metaclass' 33 | ) 34 | t.is(nil.class(), Nil) 35 | t.is(Metaclass.superclass(), Class) 36 | t.is(Class.superclass(), Object) 37 | }) 38 | -------------------------------------------------------------------------------- /src/test/snapshots/compilation.test.mjs.md: -------------------------------------------------------------------------------- 1 | # Snapshot report for `src/test/compilation.test.mjs` 2 | 3 | The actual snapshot is saved in `compilation.test.mjs.snap`. 4 | 5 | Generated by [AVA](https://avajs.dev). 6 | 7 | ## codegen: class and method definitions 8 | 9 | > Snapshot 1 10 | 11 | '({className:\'Dog\',superclassName:\'\',instanceSlots:{\'run\'(){const _rv={};try{}catch(e){if(e===_rv)return e.v;throw e}return this}},classSlots:{_instVarNames: [],}})' 12 | 13 | > Snapshot 2 14 | 15 | '({className:\'Dog\',superclassName:\'\',instanceSlots:{\'barkAt:and:\'(x, y){const _rv={};try{}catch(e){if(e===_rv)return e.v;throw e}return this}},classSlots:{_instVarNames: [],}})' 16 | 17 | > Snapshot 3 18 | 19 | '({className:\'Dog\',superclassName:\'\',instanceSlots:{\'>>\'(dist){const _rv={};try{}catch(e){if(e===_rv)return e.v;throw e}return this}},classSlots:{_instVarNames: [],}})' 20 | 21 | ## codegen: method bodies 22 | 23 | > Snapshot 1 24 | 25 | '\'doIt\'(){const _rv={};try{_rv.v=$g(\'Integer\')._new(3);throw _rv}catch(e){if(e===_rv)return e.v;throw e}return this}' 26 | 27 | > Snapshot 2 28 | 29 | '\'do:\'(x){const _rv={};try{_rv.v=x;throw _rv}catch(e){if(e===_rv)return e.v;throw e}return this}' 30 | 31 | > Snapshot 3 32 | 33 | '\'doIt\'(){const _rv={};try{let a,b;_rv.v=a;throw _rv}catch(e){if(e===_rv)return e.v;throw e}return this}' 34 | 35 | > Snapshot 4 36 | 37 | '\'doIt\'(){const _rv={};try{let x;x=$g(\'Integer\')._new(3);_rv.v=x;throw _rv}catch(e){if(e===_rv)return e.v;throw e}return this}' 38 | 39 | ## codegen: message sends 40 | 41 | > Snapshot 1 42 | 43 | '$($g(\'Integer\')._new(4), \'between:and:\', $g(\'Integer\')._new(2),$g(\'Integer\')._new(3))' 44 | 45 | > Snapshot 2 46 | 47 | '$($($g(\'Integer\')._new(4), \'+\', $g(\'Integer\')._new(1)), \'between:and:\', $g(\'Integer\')._new(2),$g(\'Integer\')._new(3))' 48 | 49 | > Snapshot 3 50 | 51 | '$($($($g(\'Integer\')._new(16), \'sqrt\', ), \'+\', $g(\'Integer\')._new(1)), \'between:and:\', $($g(\'Integer\')._new(2), \'negated\', ),$($g(\'Integer\')._new(8), \'+\', $g(\'Integer\')._new(1)))' 52 | 53 | ## codegen: literals 54 | 55 | > Snapshot 1 56 | 57 | '$g(\'Symbol\')._new(`between:and:`)' 58 | 59 | > Snapshot 2 60 | 61 | '$g(\'Symbol\')._new(`x`)' 62 | 63 | > Snapshot 3 64 | 65 | '$g(\'String\')._new(``)' 66 | 67 | > Snapshot 4 68 | 69 | '$g(\'Integer\')._new(4)' 70 | 71 | > Snapshot 5 72 | 73 | '$g(\'Double\')._new(-3.14)' 74 | 75 | > Snapshot 6 76 | 77 | '$g(\'Array\')._new([$g(\'Integer\')._new(4),$g(\'String\')._new(`hey`)])' 78 | 79 | ## codegen: blocks 80 | 81 | > Snapshot 1 82 | 83 | '$g(\'_block1\')(()=>{})' 84 | 85 | > Snapshot 2 86 | 87 | '$g(\'_block2\')((x)=>{})' 88 | 89 | > Snapshot 3 90 | 91 | '$g(\'_block3\')((x,y)=>{})' 92 | 93 | > Snapshot 4 94 | 95 | '$g(\'_block3\')((x,y)=>{})' 96 | 97 | > Snapshot 5 98 | 99 | '$g(\'_block3\')((x,y)=>{_rv.v=$g(\'Double\')._new(3.0);throw _rv})' 100 | 101 | ## codegen: other expressions 102 | 103 | > Snapshot 1 104 | 105 | '$setG(\'x\',$setG(\'y\',$g(\'Double\')._new(3.0), this), this)' 106 | 107 | > Snapshot 2 108 | 109 | '$setG(\'x\',$($g(\'Double\')._new(3.0), \'+\', $g(\'Double\')._new(4.0)), this)' 110 | -------------------------------------------------------------------------------- /src/test/snapshots/compilation.test.mjs.snap: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pdubroy/ohm-som/f53c057a482283fddfc48aff4a5e141db999419b/src/test/snapshots/compilation.test.mjs.snap -------------------------------------------------------------------------------- /test/compileSomTestSuite.mjs: -------------------------------------------------------------------------------- 1 | import test from 'ava' 2 | import fs from 'fs' 3 | import path from 'path' 4 | import walkSync from 'walk-sync' 5 | 6 | import { compileClass } from '../src/compilation.mjs' 7 | import { somTestSuitePath } from '../src/paths.mjs' 8 | 9 | // An AVA "macro function" that tests that the SOM source file at `filename` can be parsed. 10 | function testSourceFile (t, filename) { 11 | const source = fs.readFileSync(path.join(somTestSuitePath, filename)) 12 | t.notThrows(() => compileClass(source)) 13 | } 14 | 15 | // Use the filename as the title for each test case. 16 | testSourceFile.title = (_, filename) => filename 17 | 18 | // Test all .som files under `somTestSuitePath`. 19 | for (const filename of walkSync(somTestSuitePath, { globs: ['**/*.som'] })) { 20 | test(testSourceFile, filename) 21 | } 22 | -------------------------------------------------------------------------------- /test/data/HelloWorld.som: -------------------------------------------------------------------------------- 1 | HelloWorld = ( 2 | run = ('Hello SOM!' println.) 3 | ) 4 | -------------------------------------------------------------------------------- /test/data/Thing.som: -------------------------------------------------------------------------------- 1 | Thing = ( 2 | asString = (^'a thing') 3 | 4 | ---- 5 | className = (^'Thing!') 6 | ) 7 | -------------------------------------------------------------------------------- /test/somTestSuite.mjs: -------------------------------------------------------------------------------- 1 | import test from 'ava' 2 | 3 | import { Environment } from '../src/evaluation.mjs' 4 | 5 | test('SOM test suite', t => { 6 | const env = new Environment() 7 | env.registerClasspath('third_party/SOM-st/SOM/TestSuite') 8 | t.notThrows(() => env.run(['TestHarness'])) 9 | }) 10 | -------------------------------------------------------------------------------- /test/testCli.mjs: -------------------------------------------------------------------------------- 1 | import test from 'ava' 2 | import childProcess from 'child_process' 3 | 4 | test.cb('HelloWorld', t => { 5 | const cmd = 'node bin/som.mjs --classpath test/data HelloWorld' 6 | childProcess.exec(cmd, (err, stdout, stderr) => { 7 | t.is(err, null) 8 | t.is(stdout, 'Hello SOM!\n') 9 | t.is(stderr, '') 10 | t.end() 11 | }) 12 | }) 13 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009 Michael Haupt, michael.haupt@hpi.uni-potsdam.de 2 | Software Architecture Group, Hasso Plattner Institute, Potsdam, Germany 3 | http://www.hpi.uni-potsdam.de/swa/ 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. 22 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Array.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Array.som 29 2009-07-31 11:28:44Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Array = ( 27 | 28 | "Accessing" 29 | at: index = primitive 30 | at: index put: value = primitive 31 | length = primitive 32 | putAll: block = ( self doIndexes: [ :i | 33 | self at: i put: block value ] ) 34 | first = ( ^ self at: 1 ) 35 | last = ( ^ self at: self length ) 36 | 37 | 38 | "Iterating" 39 | do: block = ( self doIndexes: [ :i | 40 | block value: (self at: i) ] ) 41 | doIndexes: block = ( 1 to: self length do: [:i | 42 | block value: i. ] ) 43 | 44 | from: start to: end do: block = ( 45 | start to: end do: [:i | block value: (self at: i) ] ) 46 | 47 | "Copying (inclusively)" 48 | copyFrom: start to: end = ( 49 | | result i | 50 | 51 | result := Array new: end - start + 1. 52 | i := 1. 53 | self from: start to: end do: [ :e | 54 | result at: i put: e. 55 | i := i + 1 ]. 56 | 57 | ^result 58 | ) 59 | 60 | copyFrom: start = ( ^self copyFrom: start to: self length ) 61 | 62 | replaceFrom: start to: stop with: replacement startingAt: repStart = ( 63 | "This destructively replaces elements from start to stop in the 64 | receiver starting at index, repStart, in the sequenceable collection, 65 | replacementCollection. Answer the receiver. No range checks are 66 | performed." 67 | | index repOff | 68 | repOff := repStart - start. 69 | index := start - 1. 70 | [(index := index + 1) <= stop] 71 | whileTrue: [self at: index put: (replacement at: repOff + index)] 72 | ) 73 | 74 | copy = (^self copyFrom: 1) 75 | 76 | "Numerical" 77 | sum = ( ^self inject: 0 into: [ :sub :elem | sub + elem ] ) 78 | average = ( ^self sum / self length ) 79 | 80 | "Containment check" 81 | contains: element = ( self do: [ :e | e = element ifTrue: [ ^true ] ]. 82 | ^false ) 83 | indexOf: element = ( 84 | self doIndexes: [ :i | (self at: i) = element ifTrue: [ ^ i ]]. 85 | ^ nil 86 | ) 87 | 88 | lastIndexOf: element = ( 89 | self length downTo: 1 do: [: i | (self at: i) = element ifTrue: [ ^ i ]]. 90 | ^ nil 91 | ) 92 | 93 | "Collection" 94 | collect: aBlock = ( 95 | | result | 96 | result := Array new: self length. 97 | self doIndexes: [ :i | result at: i put: (aBlock value: (self at: i)) ]. 98 | ^result 99 | ) 100 | 101 | inject: sub into: aBlock = ( | next | 102 | next := sub. 103 | self do: [ :e | next := aBlock value: next with: e ]. 104 | ^next 105 | ) 106 | 107 | reject: aBlock = ( 108 | ^ self select: [:element | (aBlock value: element) == false ] 109 | ) 110 | 111 | select: aBlock = ( 112 | "TODO: fix the hard reference to Vector..." 113 | | newCollection | 114 | newCollection := Vector new: self length. 115 | self do: [:each | (aBlock value: each) 116 | ifTrue: [newCollection append: each]]. 117 | ^ newCollection 118 | ) 119 | 120 | union: aCollection = ( 121 | | new | 122 | new := Set new. 123 | new addAll: self. 124 | new addAll: aCollection. 125 | ^ new 126 | ) 127 | 128 | ---------------------------- 129 | 130 | "Allocation" 131 | new = ( ^self new: 0 ) 132 | new: length = primitive 133 | new: length withAll: block = ( ^((self new: length) putAll: block) ) 134 | 135 | "Convenience" 136 | with: a = ( 137 | | arr | 138 | arr := self new: 1. 139 | arr at: 1 put: a. 140 | ^ arr 141 | ) 142 | 143 | with: a with: b = ( 144 | | arr | 145 | arr := self new: 2. 146 | arr at: 1 put: a. 147 | arr at: 2 put: b. 148 | ^ arr 149 | ) 150 | 151 | with: a with: b with: c = ( 152 | | arr | 153 | arr := self new: 3. 154 | arr at: 1 put: a. 155 | arr at: 2 put: b. 156 | arr at: 3 put: c. 157 | ^ arr 158 | ) 159 | ) 160 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Block.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Block.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Block = ( 27 | 28 | "For the creation of Block instances, see Universe_new_block()." 29 | 30 | "Evaluation" 31 | value = primitive 32 | 33 | "Looping" 34 | whileFalse: block = ( 35 | [ self value not ] whileTrue: block 36 | ) 37 | 38 | whileTrue: block = ( 39 | self value ifFalse: [ ^nil ]. 40 | block value. 41 | self restart 42 | ) 43 | 44 | "Restarting" 45 | restart = primitive 46 | 47 | ) 48 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Block1.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Block1.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Block1 = Block ( 27 | 28 | "For the creation of Block instances, see Universe_new_block()." 29 | 30 | "Evaluating" 31 | value = primitive 32 | 33 | ) 34 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Block2.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Block2.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Block2 = Block ( 27 | 28 | "For the creation of Block instances, see Universe_new_block()." 29 | 30 | "Evaluating" 31 | value = ( self value: nil ) 32 | value: argument = primitive 33 | 34 | ) 35 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Block3.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Block3.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Block3 = Block ( 27 | 28 | "For the creation of Block instances, see Universe_new_block()." 29 | 30 | "Evaluating" 31 | value = ( self value: nil with: nil ) 32 | value: arg = ( self value: arg with: nil ) 33 | value: arg1 with: arg2 = primitive 34 | 35 | ) 36 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Boolean.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Boolean.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Boolean = ( 27 | 28 | "Conditional evaluation" 29 | ifTrue: trueBlock ifFalse: falseBlock = ( 30 | self ifTrue: [ ^trueBlock value ]. 31 | self ifFalse: [ ^falseBlock value ]. 32 | ) 33 | 34 | "Logical operations" 35 | || boolean = ( ^self or: boolean ) 36 | && boolean = ( ^self and: boolean ) 37 | 38 | ) 39 | 40 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Class.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Class.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Class = ( 27 | 28 | "Accessing" 29 | name = primitive 30 | 31 | "Converting" 32 | asString = ( ^self name asString ) 33 | 34 | "Allocation" 35 | new = primitive 36 | 37 | "Meta Information" 38 | superclass = primitive 39 | fields = primitive 40 | methods = primitive 41 | selectors = ( ^self methods collect: [:inv | inv signature ] ) 42 | 43 | hasMethod: aSymbol = ( 44 | self methods do: [ :m | 45 | m signature = aSymbol ifTrue: [ ^true ] ]. 46 | ^false 47 | ) 48 | 49 | ) 50 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Dictionary.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Dictionary.som 29 2009-07-31 11:28:44Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Dictionary = ( 27 | 28 | | pairs | 29 | 30 | at: aKey put: aValue = ( 31 | (self containsKey: aKey) 32 | ifTrue: [ (self pairAt: aKey) value: aValue ] 33 | ifFalse: [ pairs add: (Pair withKey: aKey andValue: aValue) ] 34 | ) 35 | 36 | at: aKey = ( 37 | pairs do: [ :p | p key = aKey ifTrue: [ ^p value ] ]. 38 | ^nil 39 | ) 40 | 41 | containsKey: aKey = ( 42 | pairs do: [ :p | p key = aKey ifTrue: [ ^true ] ]. 43 | ^false 44 | ) 45 | 46 | keys = ( ^pairs collect: [ :p | p key ] ) 47 | values = ( ^pairs collect: [ :p | p value ] ) 48 | 49 | "Iteration" 50 | do: block = ( pairs do: block ) 51 | 52 | "Private" 53 | pairs: aSet = ( pairs := aSet ) 54 | pairAt: aKey = ( 55 | pairs do: [ :p | p key = aKey ifTrue: [ ^p ] ]. 56 | ^nil 57 | ) 58 | 59 | "Printing" 60 | print = ( '{' print. pairs do: [ :p | p print ]. '}' print ) 61 | println = ( self print. '' println ) 62 | 63 | ---- 64 | 65 | new = ( 66 | | newDictionary | 67 | newDictionary := super new. 68 | newDictionary pairs: Set new. 69 | ^newDictionary 70 | ) 71 | 72 | ) 73 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Double.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Double.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Double = ( 27 | 28 | "Arithmetic" 29 | + argument = primitive 30 | - argument = primitive 31 | * argument = primitive 32 | // argument = primitive 33 | % argument = primitive 34 | abs = ( ^(self < 0.0) ifTrue: (0.0 - self) ifFalse: self ) 35 | sqrt = primitive 36 | negated = ( ^0.0 - self ) 37 | round = primitive 38 | asInteger = primitive 39 | cos = primitive 40 | sin = primitive 41 | 42 | "Comparing" 43 | = argument = primitive 44 | < argument = primitive 45 | > argument = ( ^(self >= argument) and: [ self <> argument ] ) 46 | >= argument = ( ^(self < argument) not ) 47 | <= argument = ( ^(self < argument) or: [ self = argument ] ) 48 | negative = ( ^self < 0.0 ) 49 | between: a and: b = ( ^(self > a) and: [ self < b ] ) 50 | 51 | "Converting" 52 | asString = primitive 53 | 54 | "Iterating" 55 | to: limit do: block = ( 56 | | i | 57 | i := self. 58 | [ i <= limit ] whileTrue: [ block value: i. i := i + 1.0 ] 59 | ) 60 | 61 | downTo: limit do: block = ( 62 | | i | 63 | i := self. 64 | [ i >= limit ] whileTrue: [ block value: i. i := i - 1.0 ] 65 | ) 66 | 67 | ---- 68 | 69 | PositiveInfinity = primitive 70 | ) 71 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/False.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: False.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | False = Boolean ( 27 | 28 | "Converting" 29 | asString = ( ^'false' ) 30 | 31 | "Conditional evaluation" 32 | ifTrue: block = ( ^nil ) 33 | ifFalse: block = ( ^block value ) 34 | 35 | "Logical operations" 36 | not = ( ^true ) 37 | or: block = ( ^block value ) 38 | and: block = ( ^false ) 39 | 40 | ) 41 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/HashEntry.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: HashEntry.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | " 27 | This class is not meant for direct use - it's an internal datastructure 28 | for Hashtable 29 | " 30 | 31 | HashEntry = ( 32 | 33 | | key value next hash | 34 | 35 | key = ( ^key ) 36 | value = ( ^value ) 37 | next = ( ^next ) 38 | hash = ( ^hash ) 39 | 40 | key: k = ( key := k ) 41 | value: v = ( value := v ) 42 | next: n = ( next := n ) 43 | hash: h = ( hash := h ) 44 | 45 | setKey: key value: value = ( 46 | key = self key 47 | ifTrue: [ self value: value. ^false. ] 48 | ifFalse: [ 49 | next isNil 50 | ifTrue: [ 51 | self next: (HashEntry newKey: key value: value next: nil). 52 | ^true. ] 53 | ifFalse: [ 54 | ^(self next setKey: key value: value) ] ]. 55 | ) 56 | 57 | getValue: key = ( 58 | key = self key ifTrue: [ ^value ]. 59 | next isNil ifTrue: [ ^nil ]. 60 | ^next getValue: key. 61 | ) 62 | 63 | containsKey: key = ( 64 | key = self key ifTrue: [ ^true ]. 65 | next isNil ifTrue: [ ^false ]. 66 | ^next containsKey: key. 67 | ) 68 | 69 | containsValue: value = ( 70 | value = self value ifTrue: [ ^true ]. 71 | next isNil ifTrue: [ ^false ]. 72 | ^next containsValue: value. 73 | ) 74 | 75 | keys = ( 76 | next isNil 77 | ifTrue: [ ^Vector new append: key ] 78 | ifFalse: [ ^(next keys), key ] 79 | ) 80 | 81 | values = ( 82 | next isNil 83 | ifTrue: [ ^Vector new append: value ] 84 | ifFalse: [ ^(next values), value ] 85 | ) 86 | 87 | ---- 88 | 89 | newKey: k value: v next: n = ( 90 | | newEntry | 91 | newEntry := super new. 92 | newEntry key: k. 93 | newEntry value: v. 94 | newEntry next: n. 95 | newEntry hash: (k hashcode). 96 | ^newEntry 97 | ) 98 | 99 | ) 100 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Hashtable.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Hashtable.som 29 2009-07-31 11:28:44Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Hashtable = ( 27 | 28 | | table count | 29 | 30 | "Testing" 31 | containsKey: key = ( | idx e | 32 | idx := self indexForKey: key. 33 | e := table at: idx. 34 | e isNil ifFalse: [ e keys do: [ :k | k = key ifTrue: [ ^true ] ] ]. 35 | ^false. 36 | ) 37 | 38 | containsValue: val = ( 39 | table do: [ :ent | 40 | ent isNil ifFalse: [ 41 | ent values do: [ :v | v = val ifTrue: [ ^true ] ] ] ]. 42 | ^false. 43 | ) 44 | 45 | isEmpty = ( ^count = 0 ) 46 | size = ( ^count ) 47 | 48 | "Accessing" 49 | get: key = ( | idx e | 50 | idx := self indexForKey: key. 51 | e := table at: idx. 52 | e isNil ifTrue: [ ^nil ]. 53 | ^e getValue: key. 54 | ) 55 | 56 | at: key put: value = ( | idx | 57 | idx := self indexForKey: key. 58 | (table at: idx) isNil 59 | ifTrue: [ 60 | table at: idx put: 61 | (HashEntry newKey: key value: value next: nil). 62 | count := count + 1 ] 63 | ifFalse: [ 64 | ((table at: idx) setKey: key value: value) 65 | ifTrue: [ count := count + 1 ] ]. 66 | "TODO: enlarge table, rehash if too large" 67 | ) 68 | 69 | "TODO: some way to delete keys'd be nice..." 70 | 71 | "Enumerate" 72 | keys = ( | vec | 73 | vec := Vector new. 74 | table do: [ :ent | 75 | ent isNil ifFalse: [ ent keys do: [ :k | vec append: k ] ] ]. 76 | ^vec. 77 | ) 78 | 79 | values = ( | vec | 80 | vec := Vector new. 81 | table do: [ :ent | 82 | ent isNil ifFalse: [ ent values do: [ :v | vec append: v ] ] ]. 83 | ^vec. 84 | ) 85 | 86 | "Clearing" 87 | clear = ( table := Array new: 11. 88 | count := 0 ) 89 | 90 | "Private" 91 | indexForKey: aKey = ( ^(aKey hashcode % table length) abs + 1 ) 92 | 93 | ---------------- 94 | 95 | "Allocation" 96 | new = ( | ht | 97 | ht := super new. 98 | ht clear. 99 | ^ht. 100 | ) 101 | 102 | ) 103 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Integer.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Integer.som 29 2009-07-31 11:28:44Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Integer = ( 27 | 28 | "Arithmetic" 29 | + argument = primitive 30 | - argument = primitive 31 | * argument = primitive 32 | / argument = primitive 33 | // argument = primitive 34 | % argument = primitive "modulo with sign of divisor" 35 | rem: argument=primitive "modulo with sign of dividend" 36 | & argument = primitive 37 | << argument = primitive 38 | >>> argument= primitive 39 | bitXor: argument = primitive 40 | abs = ( ^(self < 0) ifTrue: (0 - self) ifFalse: self ) 41 | sqrt = primitive 42 | negated = ( ^0 - self ) 43 | 44 | "Random numbers" 45 | atRandom = primitive 46 | 47 | "Comparing" 48 | = argument = primitive 49 | ~= argument = (^ (self = argument) not ) 50 | < argument = primitive 51 | > argument = ( ^(self >= argument) and: [ self <> argument ] ) 52 | >= argument = ( ^(self < argument) not ) 53 | <= argument = ( ^(self < argument) or: [ self = argument ] ) 54 | negative = ( ^self < 0 ) 55 | between: a and: b = ( ^(self > a) and: [ self < b ] ) 56 | 57 | "Converting" 58 | asString = primitive 59 | as32BitSignedValue = primitive " returns an int, with the value that a signed 32-bit integer would have" 60 | as32BitUnsignedValue = primitive " returns an int, with the value that a unsigned 32-bit integer would have" 61 | hashcode = ( ^self ) 62 | 63 | "Iterating" 64 | to: limit do: block = ( 65 | self to: limit by: 1 do: block 66 | ) 67 | 68 | to: limit by: step do: block = ( 69 | | i | 70 | i := self. 71 | [ i <= limit ] whileTrue: [ block value: i. i := i + step ] 72 | ) 73 | 74 | downTo: limit do: block = ( 75 | self downTo: limit by: 1 do: block 76 | ) 77 | 78 | downTo: limit by: step do: block = ( 79 | | i | 80 | i := self. 81 | [ i >= limit ] whileTrue: [ block value: i. i := i - step ] 82 | ) 83 | 84 | "More Iterations" 85 | timesRepeat: block = ( 86 | 1 to: self do: [ :i | block value ] 87 | ) 88 | 89 | "Range Creation" 90 | to: upper = ( 91 | | range | 92 | range := Array new: upper - self + 1. 93 | self to: upper do: [ :i | range at: i put: i ]. 94 | ^range 95 | ) 96 | 97 | max: otherInt = ( 98 | (self < otherInt) ifTrue: [^otherInt] ifFalse: [^self]. 99 | ) 100 | 101 | min: otherInt = ( 102 | (self < otherInt) ifTrue: [^self] ifFalse: [^otherInt]. 103 | ) 104 | 105 | ---- 106 | 107 | fromString: aString = primitive 108 | 109 | ) 110 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Metaclass.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Metaclass.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Metaclass = Class ( ) 27 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Method.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Method.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Method = ( 27 | 28 | "Meta Information" 29 | signature = primitive 30 | holder = primitive 31 | 32 | "Printing" 33 | asString = ( ^self holder asString + '>>' + self signature asString ) 34 | 35 | invokeOn: obj with: args = primitive 36 | 37 | ) 38 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Nil.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Nil.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Nil = ( 27 | 28 | "Converting" 29 | asString = ( ^'nil' ) 30 | 31 | "Comparing" 32 | isNil = ( ^true ) 33 | notNil = ( ^false ) 34 | 35 | "Convenience" 36 | ifNil: aBlock = (^aBlock value) 37 | ifNotNil: aBlock = (^self) 38 | ifNil: goBlock ifNotNil: noGoBlock = (^goBlock value) 39 | 40 | ) 41 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Object.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Object.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Object = nil ( 27 | class = primitive 28 | objectSize = primitive "size in bytes" 29 | 30 | "Comparing" 31 | 32 | " If you override =, you MUST override hashcode as well. The rule 33 | obj1 = obj2 => obj1 hashcode = obj2 hashcode 34 | must be valid for all objects, or Hashtable will not work" 35 | = other = ( ^self == other ) 36 | <> argument = ( ^(self = argument) not ) 37 | == other = primitive 38 | ~= other = (^ (self == other) not ) 39 | isNil = ( ^false ) 40 | notNil = ( ^true ) 41 | 42 | "Converting" 43 | asString = ( ^'instance of ' + (self class) ) 44 | , element = ( ^(Vector new append: self) append: element ) 45 | hashcode = primitive 46 | 47 | "Evaluating" 48 | value = ( ^self ) 49 | 50 | "Convenience" 51 | ifNil: aBlock = (^self) 52 | ifNotNil: aBlock = (^aBlock value) 53 | ifNil: noGoBlock ifNotNil: goBlock = (^goBlock value) 54 | 55 | "Printing" 56 | print = ( self asString print ) 57 | println = ( self print. system printNewline ) 58 | 59 | "Debugging" 60 | inspect = primitive 61 | halt = primitive 62 | 63 | "Error handling" 64 | error: string = ( '' println. ('ERROR: ' + string) println. system exit: 1 ) 65 | 66 | "Abstract method support" 67 | subclassResponsibility = ( 68 | self error: 'This method is abstract and should be overridden' 69 | ) 70 | 71 | "Error recovering" 72 | doesNotUnderstand: selector arguments: arguments = ( 73 | self error: 74 | ('Method ' + selector + ' not found in class ' + self class name) 75 | ) 76 | 77 | escapedBlock: block = ( 78 | self error: 'Block has escaped and cannot be executed' 79 | ) 80 | 81 | unknownGlobal: name = ( ^system resolve: name ) 82 | 83 | "Reflection" 84 | respondsTo: aSymbol = ( 85 | (self class hasMethod: aSymbol) 86 | ifTrue: [ ^true ] 87 | ifFalse: [ | cls | 88 | cls := self class superclass. 89 | [ cls isNil ] whileFalse: [ 90 | (cls hasMethod: aSymbol) 91 | ifTrue: [ ^true ] 92 | ifFalse: [ cls := cls superclass ] ]. 93 | ^ false ] 94 | ) 95 | 96 | perform: aSymbol = primitive 97 | perform: aSymbol withArguments: args = primitive 98 | 99 | perform: aSymbol inSuperclass: cls = primitive 100 | perform: aSymbol withArguments: args inSuperclass: cls = primitive 101 | 102 | instVarAt: idx = primitive 103 | instVarAt: idx put: obj = primitive 104 | instVarNamed: sym = primitive 105 | 106 | ) 107 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Pair.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Pair.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Pair = ( 27 | 28 | | key value | 29 | 30 | key = ( ^key ) 31 | value = ( ^value ) 32 | 33 | "Private" 34 | key: aKey = ( key := aKey ) 35 | value: aValue = ( value := aValue ) 36 | 37 | "Printing" 38 | print = ( '[' print. key print. '=>' print. value print. ']' print ) 39 | println = ( self print. '' println ) 40 | 41 | ---- 42 | 43 | withKey: aKey andValue: aValue = ( 44 | | newPair | 45 | newPair := super new. 46 | newPair key: aKey. 47 | newPair value: aValue. 48 | ^newPair 49 | ) 50 | 51 | ) 52 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Primitive.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Primitive.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Primitive = ( 27 | 28 | signature = primitive 29 | holder = primitive 30 | 31 | invokeOn: obj with: args = primitive 32 | 33 | ) 34 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Set.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Set.som 29 2009-07-31 11:28:44Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Set = ( 27 | 28 | | items | 29 | 30 | = otherSet = ( 31 | self size = otherSet size ifFalse: [^ false ]. 32 | 33 | self do: [:item | (otherSet contains: item) ifFalse: [^ false]. ]. 34 | 35 | ^ true. 36 | ) 37 | 38 | add: anObject = ( 39 | (self contains: anObject) 40 | ifFalse: [ items append: anObject ] 41 | ) 42 | 43 | addAll: aCollection = ( 44 | aCollection do: [:each | 45 | self add: each] 46 | ) 47 | 48 | union: aCollection = ( 49 | | new | 50 | new := Set new. 51 | new addAll: self. 52 | new addAll: aCollection. 53 | ^ new 54 | ) 55 | 56 | intersection: aCollection = ( 57 | | new | 58 | new := Set new. 59 | self do: [:it | 60 | (aCollection contains: it) ifTrue: [ new add: it ]]. 61 | ^ new 62 | ) 63 | 64 | - aCollection = ( "set difference" 65 | | new | 66 | new := Set new. 67 | self do: [:it | 68 | (aCollection contains: it) ifFalse: [ new add: it ]]. 69 | ^ new 70 | ) 71 | 72 | contains: anObject = ( 73 | items do: [ :it | it == anObject ifTrue: [ ^true ] ]. 74 | ^false 75 | ) 76 | 77 | remove: anObject = ( 78 | | newItems | 79 | newItems := Vector new. 80 | [ items isEmpty ] 81 | whileFalse: [ | it | 82 | it := items remove. 83 | it = anObject ifFalse: [ newItems append: it ] ]. 84 | items := newItems 85 | ) 86 | 87 | "Sets do not have the notion of ordering, but 88 | for convenience we provide those accessors" 89 | first = ( 90 | ^items at: 1 91 | ) 92 | 93 | isEmpty = ( 94 | ^items isEmpty 95 | ) 96 | 97 | "Iteration" 98 | do: block = ( items do: block ) 99 | 100 | "Collection" 101 | collect: block = ( | coll | 102 | coll := Vector new. 103 | self do: [ :e | coll append: (block value: e) ]. 104 | ^coll 105 | ) 106 | 107 | "Printing" 108 | println = ( 109 | '(' print. 110 | self do: [ :it | '(' print. it print. ')' print ]. 111 | ')' println 112 | ) 113 | 114 | asString = ( 115 | | result | 116 | result := 'a Set('. 117 | items do: [:e | result := result + e asString + ', ']. 118 | result := result + ')'. 119 | ^ result 120 | ) 121 | 122 | size = ( 123 | ^ items size 124 | ) 125 | 126 | "Private" 127 | items: it = ( items := it ) 128 | 129 | ---- 130 | 131 | new = ( 132 | | newSet | 133 | newSet := super new. 134 | newSet items: Vector new. 135 | ^newSet 136 | ) 137 | 138 | ) 139 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/String.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: String.som 29 2009-07-31 11:28:44Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | String = ( 27 | "Strings are immutable" 28 | 29 | "Concatenate: returns a new string object" 30 | concatenate: argument = primitive 31 | + argument = ( ^self concatenate: argument asString ) 32 | 33 | "Converting" 34 | asString = ( ^self ) 35 | asSymbol = primitive 36 | hashcode = primitive 37 | 38 | "Info" 39 | length = primitive 40 | 41 | "Returns true if all characters in the string are whitespace. 42 | False otherwise, including for the empty string." 43 | isWhiteSpace = primitive 44 | 45 | "Returns true if all characters in the string are letters. 46 | False otherwise, including for the empty string." 47 | isLetters = primitive 48 | 49 | "Returns true if all characters in the string are digits. 50 | False otherwise, including for the empty string." 51 | isDigits = primitive 52 | 53 | "Comparing" 54 | = argument = primitive 55 | 56 | "substring: from 'start' to (and including) 'end'." 57 | primSubstringFrom: start to: end = primitive 58 | 59 | substringFrom: start to: end = ( 60 | ((end <= self length) && (start > 0) && (start <= end)) 61 | ifTrue: [^self primSubstringFrom: start to: end] 62 | ifFalse: [ 63 | self error: 'Attempting to index string out of its bounds (start: ' + start asString + ' end: ' + end asString + ' length: ' + self length asString + ')' ] 64 | ) 65 | 66 | beginsWith: prefix = ( 67 | self length < prefix length ifTrue: [ ^ false ]. 68 | 69 | 1 to: prefix length do: [:i | 70 | ((self charAt: i) = (prefix charAt: i)) ifFalse: [ ^ false ]. 71 | ]. 72 | 73 | ^ true 74 | ) 75 | 76 | endsWith: suffix = ( 77 | | l sufL | 78 | l := self length. 79 | sufL := suffix length. 80 | l < sufL ifTrue: [ ^ false ]. 81 | 82 | 1 to: sufL do: [:i | 83 | (self charAt: l - sufL + i) = (suffix charAt: i) ifFalse: [ ^ false ] 84 | ]. 85 | ^ true 86 | ) 87 | 88 | asInteger = ( 89 | ^ Integer fromString: self 90 | ) 91 | 92 | charAt: argument = ( 93 | ^self substringFrom: argument to: argument 94 | ) 95 | 96 | "Printing" 97 | print = ( system printString: self ) 98 | 99 | ) 100 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Symbol.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Symbol.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | Symbol = String ( 27 | 28 | "Converting" 29 | asString = primitive 30 | asSymbol = ( ^self ) 31 | 32 | "Printing" 33 | print = ( '#' print. super print ) 34 | 35 | ) 36 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/System.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: System.som 29 2009-07-31 11:28:44Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | System = ( 27 | 28 | "Accessing" 29 | global: name = primitive 30 | global: name put: value = primitive 31 | hasGlobal: name = primitive 32 | 33 | "Initializing" 34 | initialize: arguments = ( 35 | | application | 36 | 37 | "Make sure we have got at least one argument" 38 | (arguments length < 1) ifTrue: [ 'No class specified' println. ^nil ]. 39 | 40 | "Load the class with the specified name, create an instance of it, and 41 | run it. If there is more than only the class given on the command line, 42 | and the class has a method #run:, the arguments array is passed to it, 43 | otherwise, #run is sent." 44 | application := (self resolve: (arguments at: 1) asSymbol) new. 45 | 46 | (application respondsTo: #run:) 47 | ifTrue: [ application run: arguments ] 48 | ifFalse: [ application run ] 49 | ) 50 | 51 | "Loading and resolving" 52 | load: symbol = primitive 53 | resolve: symbol = ( 54 | | class current_class | 55 | 56 | "Check if we've already got the global" 57 | (self global: symbol) == nil ifFalse: [ ^self global: symbol ]. 58 | 59 | "Try loading the class" 60 | class := self load: symbol. 61 | (class == nil) ifFalse: [ 62 | "Put class and its super-classes into global dictionary. We can stop 63 | as soon as we find a super-class in the globals dictionary because 64 | in this case, all its super-classes must have been added to the 65 | dictionary earlier" 66 | current_class := class. 67 | [ (self global: (current_class name)) == nil ] whileTrue: [ 68 | self global: (current_class name) put: current_class. 69 | current_class := current_class superclass. ]. 70 | ^class ]. 71 | self error: 'Unable to resolve ' + symbol 72 | ) 73 | 74 | "Exiting" 75 | exit: error = primitive 76 | exit = ( self exit: 0 ) 77 | 78 | "Printing" 79 | printString: string = primitive 80 | printNewline = primitive 81 | 82 | "Time" 83 | time = primitive 84 | ticks = primitive "returns the microseconds since start" 85 | 86 | "Force Garbage Collection" 87 | fullGC = primitive 88 | 89 | ---------------------------------- 90 | 91 | "Allocation" 92 | new = ( self error: 'The system object is singular' ) 93 | 94 | ) 95 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/True.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: True.som 27 2009-07-31 11:17:53Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | True = Boolean ( 27 | 28 | "Converting" 29 | asString = ( ^'true' ) 30 | 31 | "Conditional evaluation" 32 | ifTrue: block = ( ^block value ) 33 | ifFalse: block = ( ^nil ) 34 | 35 | "Logical operations" 36 | not = ( ^false ) 37 | or: block = ( ^true ) 38 | and: block = ( ^block value ) 39 | 40 | ) 41 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/Smalltalk/Vector.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: Vector.som 29 2009-07-31 11:28:44Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | "FIXME: Implement pushFront and popFront..." 27 | 28 | Vector = ( 29 | 30 | | first last storage | 31 | 32 | "Accessing" 33 | at: index = ( ^ self checkIndex: index ifValid: [ storage at: index ] ) 34 | 35 | at: index put: value = ( 36 | ^ self checkIndex: index ifValid: [ storage at: index put: value ] 37 | ) 38 | 39 | first = ( ^ (self size > 0) ifTrue: [storage at: 1] ifFalse: [nil] ) 40 | 41 | "Iterating" 42 | do: block = ( 43 | first to: last - 1 do: [ :i | block value: (storage at: i) ] 44 | ) 45 | 46 | doIndexes: block = ( 47 | first to: last - 1 do: block 48 | ) 49 | 50 | "Adding" 51 | , element = ( ^self append: element ) 52 | 53 | append: element = ( 54 | (last >= storage length) ifTrue: [ 55 | "Need to expand capacity first" 56 | | newStorage | 57 | newStorage := Array new: (2 * storage length). 58 | storage doIndexes: [ :i | newStorage at: i put: (storage at: i) ]. 59 | storage := newStorage. ]. 60 | 61 | storage at: last put: element. 62 | last := last + 1. 63 | ^self 64 | ) 65 | 66 | "Removing" 67 | remove = ( 68 | (last > first) 69 | ifTrue: [ last := last - 1. ^storage at: last ] 70 | ifFalse: [ 71 | self error: 72 | 'Vector: Attempting to pop element from empty Vector' ] 73 | ) 74 | 75 | remove: object = ( 76 | | newArray newLast found | 77 | newArray := Array new: self capacity. 78 | newLast := 1. 79 | found := false. 80 | 81 | self do: [ :it | 82 | (it == object) 83 | ifTrue: [ found := true ] 84 | ifFalse: [ 85 | newArray at: newLast put: it. 86 | newLast := newLast + 1. 87 | ] 88 | ]. 89 | 90 | storage := newArray. 91 | last := newLast. 92 | first := 1. 93 | ^found 94 | ) 95 | 96 | contains: anObject = ( 97 | ^ storage contains: anObject 98 | ) 99 | 100 | "Printing" 101 | println = ( 102 | '(' print. 103 | self do: [ :it | '(' print. it print. ')' print ]. 104 | ')' println 105 | ) 106 | 107 | "Sizing" 108 | isEmpty = ( ^last = first ) 109 | size = ( ^last - first ) 110 | capacity = ( ^storage length ) 111 | 112 | "Conversion" 113 | asArray = ( | arr | 114 | arr := Array new: self size. 115 | self doIndexes: [ :i | arr at: i put: (self at: i) ]. 116 | ^arr 117 | ) 118 | 119 | "Private" 120 | initialize: size = ( 121 | storage := Array new: size. 122 | first := 1. 123 | last := 1. 124 | ) 125 | 126 | checkIndex: index ifValid: block = ( 127 | ^ ((first <= index) && (index <= last) 128 | ifTrue: [ block value ] 129 | ifFalse: [ 130 | self error: 131 | 'Vector[' + first asString + '..' + last asString + 132 | ']: Index ' + index asString + ' out of bounds' ]) 133 | ) 134 | 135 | "DeltaBlue" 136 | removeFirst = ( 137 | self isEmpty ifTrue: [ self error: 'OrderedCollection is empty' ]. 138 | first := first + 1. 139 | ^ storage at: first - 1 140 | ) 141 | 142 | "Conversion" 143 | asSet = ( 144 | ^ Set new addAll: self 145 | ) 146 | 147 | ---------------------------- 148 | 149 | "Allocation" 150 | new = ( ^ self new: 50 ) 151 | new: initialSize = ( ^ super new initialize: initialSize ) 152 | 153 | with: elem = ( 154 | | newVector | 155 | newVector := self new: 1. 156 | newVector append: elem. 157 | ^ newVector 158 | ) 159 | 160 | ) 161 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/ArrayTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: ArrayTest.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2007-2013 see AUTHORS file 6 | Software Architecture Group, Hasso Plattner Institute, Potsdam, Germany 7 | http://www.hpi.uni-potsdam.de/swa/ 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining a copy 10 | of this software and associated documentation files (the 'Software'), to deal 11 | in the Software without restriction, including without limitation the rights 12 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the Software is 14 | furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included in 17 | all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 25 | THE SOFTWARE. 26 | " 27 | 28 | ArrayTest = TestCase ( 29 | | a | 30 | 31 | setUp = ( 32 | a := Array new: 3. 33 | a at: 1 put: 'hello'. 34 | a at: 2 put: #world. 35 | a at: 3 put: 23. 36 | ) 37 | 38 | testLength = ( 39 | self assert: 3 equals: a length 40 | ) 41 | 42 | testAt = ( 43 | self assert: #world equals: (a at: 2). 44 | self assert: 23 equals: (a at: 3). 45 | ) 46 | 47 | testContains = ( 48 | self assert: (a contains: 23). 49 | self deny: (a contains: #notInThere). 50 | ) 51 | 52 | testDo = ( 53 | | j | 54 | j := 1. 55 | 56 | a do: [:i | 57 | self assert: (a at: j) is: i. 58 | j := j + 1. 59 | ] 60 | ) 61 | 62 | testSumAndAverage = ( 63 | | arr | 64 | arr := Array new: 3. 65 | 1 to: 3 do: [ :i | arr at: i put: i ]. 66 | 67 | self assert: 6 equals: arr sum. 68 | self assert: 2 equals: arr average. 69 | ) 70 | 71 | testCopyFrom = ( 72 | | arr b | 73 | arr := Array new: 5. 74 | 1 to: 5 do: [ :i | arr at: i put: i ]. 75 | 76 | b := arr copyFrom: 2 to: 4. 77 | self assert: 2 equals: (b at: 1). 78 | self assert: 3 equals: (b at: 2). 79 | self assert: 4 equals: (b at: 3). 80 | 81 | b := arr copyFrom: 3. 82 | self assert: 3 equals: (b at: 1). 83 | self assert: 4 equals: (b at: 2). 84 | self assert: 5 equals: (b at: 3). 85 | ) 86 | 87 | testIndexOf = ( 88 | | arr | 89 | arr := Array new: 6. 90 | arr at: 1 put: #one. 91 | arr at: 2 put: #two. 92 | arr at: 3 put: #three. 93 | arr at: 4 put: #four. 94 | arr at: 5 put: #five. 95 | arr at: 6 put: #one. 96 | 97 | self assert: 2 equals: (arr indexOf: #two). 98 | self assert: 4 equals: (arr indexOf: #four). 99 | self assert: 5 equals: (arr indexOf: #five). 100 | 101 | self assert: nil equals: (arr indexOf: #notIncluded). 102 | 103 | self assert: 1 equals: (arr indexOf: #one). 104 | ) 105 | 106 | testLastIndexOf = ( 107 | | arr | 108 | arr := Array new: 6. 109 | arr at: 1 put: #one. 110 | arr at: 2 put: #two. 111 | arr at: 3 put: #three. 112 | arr at: 4 put: #four. 113 | arr at: 5 put: #five. 114 | arr at: 6 put: #one. 115 | 116 | self assert: 2 equals: (arr lastIndexOf: #two). 117 | self assert: 4 equals: (arr lastIndexOf: #four). 118 | self assert: 5 equals: (arr lastIndexOf: #five). 119 | 120 | self assert: nil equals: (arr indexOf: #notIncluded). 121 | 122 | self assert: 6 equals: (arr lastIndexOf: #one). 123 | ) 124 | 125 | testNewWithAll = ( 126 | | arr | 127 | arr := Array new: 5 withAll: [1]. 128 | 1 to: 5 do: [:i | self assert: 1 equals: (arr at: i)]. 129 | 130 | arr := Array new: 5 withAll: 1. 131 | 1 to: 5 do: [:i | self assert: 1 equals: (arr at: i)]. 132 | ) 133 | 134 | testPutAllIntAndObjects = ( 135 | | arr o | 136 | arr := Array new: 5 withAll: 5. 137 | self assert: 5 equals: (arr at: 3). 138 | arr at: 3 put: nil. 139 | self assert: nil equals: (arr at: 3). 140 | 141 | o := Object new. 142 | arr at: 2 put: o. 143 | self assert: o equals: (arr at: 2). 144 | ) 145 | 146 | testLiteralArrays = ( 147 | self assert: (#(1 2) at: 1) equals: 1. 148 | self assert: (#(1 2) at: 2) equals: 2. 149 | 150 | self assert: (#(-1 -200.0) at: 1) equals: -1. 151 | self assert: (#(-1 -200.0) at: 2) equals: -200.0. 152 | ) 153 | ) 154 | 155 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/Arrays.som: -------------------------------------------------------------------------------- 1 | Arrays = ( 2 | ---- 3 | 4 | testEmptyToInts = ( 5 | | arr | 6 | arr := Array new: 5. 7 | (arr at: 1) ifNotNil: [self error: 'should be initialized to nil']. 8 | 9 | 1 to: 5 do: [:i | 10 | arr at: i put: i. 11 | (arr at: i) = i ifFalse: [self error: 'should be i']. 12 | ]. 13 | 14 | (arr at: 1) = 1 ifFalse: [self error: 'should be 1']. 15 | (arr at: 5) = 5 ifFalse: [self error: 'should be 1']. 16 | ^ arr at: 3 17 | ) 18 | 19 | testPutAllInt = ( 20 | | arr | 21 | arr := Array new: 5. 22 | arr putAll: 5. 23 | ^ arr at: 3 24 | ) 25 | 26 | testPutAllNil = ( 27 | | arr | 28 | arr := Array new: 5. 29 | (arr at: 4) ifNotNil: [self error: 'should be initialized to nil']. 30 | 31 | arr putAll: 5. 32 | (arr at: 4) = 5 ifFalse: [self error: 'should be set to 5']. 33 | 34 | arr putAll: nil. 35 | 36 | ^ (arr at: 3) class 37 | ) 38 | 39 | testPutAllBlock = ( 40 | | arr b cnt | 41 | cnt := 0. 42 | b := [cnt := cnt + 1. cnt]. 43 | arr := Array new: 5. 44 | arr putAll: b. 45 | 46 | 1 to: 5 do: [:i| 47 | (arr at: i) = i ifFalse: [self error: 'block not properly evaluated?'] 48 | ]. 49 | 50 | ^ arr at: 3 51 | ) 52 | 53 | testNewWithAll = ( 54 | | arr | 55 | arr := Array new: 5 withAll: [1]. 56 | 1 to: 5 do: [:i | (arr at: i) = 1 ifFalse: [self error: 'wrong result']]. 57 | ^ arr at: 3 58 | ) 59 | 60 | ) -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/BinaryOperation.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2001-2013 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | BinaryOperation = ( 24 | 25 | ---- 26 | 27 | test = ( 28 | ^ (self foo: 1) + (self foo2: 2) 29 | ) 30 | 31 | foo: aNumber = ( 32 | ^ 3 33 | ) 34 | 35 | foo2: aNumber = ( 36 | ^ 8 37 | ) 38 | 39 | 40 | ) 41 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/BlockInlining.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2015 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | BlockInlining = ( 24 | ---- 25 | 26 | testNoInlining = ( 27 | | a block | 28 | a := 1. 29 | block := [ a ]. 30 | ^ block value 31 | ) 32 | 33 | testOneLevelInlining = ( 34 | | a | 35 | a := 1. 36 | ^ true ifTrue: [ a ] ifFalse: [ 42 ] 37 | ) 38 | 39 | oneLevelInliningWithLocalShadow: bool = ( 40 | | a | 41 | a := 1. 42 | ^ bool 43 | ifTrue: [ | a | 44 | a := 2. 45 | a 46 | ] ifFalse: [ a "that's outer a" ] 47 | ) 48 | 49 | testOneLevelInliningWithLocalShadowTrue = ( 50 | ^ self oneLevelInliningWithLocalShadow: true 51 | ) 52 | 53 | testOneLevelInliningWithLocalShadowFalse = ( 54 | ^ self oneLevelInliningWithLocalShadow: false 55 | ) 56 | 57 | deepNestedInlinedIf: bool = ( 58 | | block a block2 | 59 | a := 1. 60 | block := [ "not inlined" 61 | a := a + 1. 62 | block2 := [ "not inlined" 63 | bool ifTrue: [ ^ a := a + 1.] 64 | ifFalse:[ |a| a := 42. a ] 65 | ]. 66 | block2 value 67 | ]. 68 | ^ block value 69 | ) 70 | 71 | testDeepNestedInlinedIfTrue = ( ^ self deepNestedInlinedIf: true ) 72 | testDeepNestedInlinedIfFalse = ( ^ self deepNestedInlinedIf: false ) 73 | 74 | blockNestedInIf: bool = ( 75 | | a | 76 | a := 1. 77 | bool ifTrue: [ 78 | | block | 79 | block := [ a := a + 1 ]. 80 | block value 81 | ] ifFalse: [ 82 | a := 42. 83 | ]. 84 | ^ a 85 | ) 86 | 87 | testBlockNestedInIfTrue = ( ^ self blockNestedInIf: true ) 88 | testBlockNestedInIfFalse = ( ^ self blockNestedInIf: false ) 89 | 90 | deepNestedBlocksInInlinedIf: bool = ( 91 | | block a block2 block3 | 92 | a := 1. 93 | block := [ "not inlined" 94 | a := a + 1. 95 | block2 := [ "not inlined" 96 | bool ifTrue: [ a := a + 1. "inlined" 97 | block3 := [ |block4| 98 | a := a + 1. 99 | block4 := [ "not inlined" 100 | a := a + 1. 101 | a 102 | ]. 103 | block4 value 104 | ]. 105 | block3 value 106 | ] ifFalse:[ |a block4| "inlined" 107 | a := 42. 108 | block4 := [ ^ a := a + 1 ]. "not inlined" 109 | block4 value 110 | ] 111 | ]. 112 | block2 value 113 | ]. 114 | ^ block value 115 | ) 116 | 117 | testDeepNestedBlocksInInlinedIfTrue = ( ^ self deepNestedBlocksInInlinedIf: true ) 118 | testDeepNestedBlocksInInlinedIfFalse = ( ^ self deepNestedBlocksInInlinedIf: false ) 119 | 120 | deepDeepNested: bool = ( 121 | | block a block2 block3 | 122 | a := 1. 123 | block := [ "not inlined" 124 | a := a + 1. 125 | block2 := [ "not inlined" 126 | bool ifTrue: [ a := a + 1. "inlined" 127 | block3 := [ |block4| 128 | a := a + 1. 129 | block4 := [ "not inlined" 130 | a := a + 1. 131 | 132 | 133 | block := [ "not inlined" 134 | a := a + 1. 135 | block2 := [ "not inlined" 136 | bool ifTrue: [ a := a + 1. "inlined" 137 | block3 := [ |block4| 138 | a := a + 1. 139 | block4 := [ "not inlined" 140 | a := a + 1. 141 | a 142 | ]. 143 | block4 value 144 | ]. 145 | block3 value 146 | ] ifFalse:[ |a block4| a := 42. "inlined" 147 | block4 := [^ a := a + 1]. "not inlined" 148 | block4 value 149 | ] 150 | ]. 151 | block2 value 152 | ]. 153 | block value 154 | 155 | 156 | ]. 157 | block4 value 158 | ]. 159 | block3 value 160 | ] ifFalse:[ |a block4| a := 42. "inlined" 161 | block4 := [^ a := a + 1]. "not inlined" 162 | block4 value 163 | ] 164 | ]. 165 | block2 value 166 | ]. 167 | ^ block value 168 | ) 169 | 170 | testDeepDeepNestedTrue = ( ^ self deepDeepNested: true ) 171 | testDeepDeepNestedFalse = ( ^ self deepDeepNested: false ) 172 | 173 | testToDoNestDoNestIfTrue = ( 174 | "from the bounce benchmark" 175 | | balls bounces | 176 | balls := Array new: 1 withAll: true. 177 | bounces := 0. 178 | 179 | 1 to: 2 do: [ :i | 180 | balls do: [ :ball | 181 | ball ifTrue: [ bounces := bounces + 1 ] ] ]. 182 | 183 | ^ bounces 184 | ) 185 | ) 186 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/Blocks.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2001-2013 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | Blocks = ( 24 | 25 | ---- 26 | 27 | testArg1 = ( ^ [:a | a - 1] value: 43 ) 28 | 29 | testArg2 = ( ^ [:a :b | a * b ] value: 11 with: 7 ) 30 | 31 | testArgAndLocal = ( 32 | ^ ([:a | 33 | | blockLocal | 34 | blockLocal := 3. 35 | a + blockLocal] value: 5) 36 | ) 37 | 38 | testArgAndContext = ( | methodLocal | 39 | ^ ([:a | 40 | methodLocal := 3. 41 | a + methodLocal] value: 5) 42 | ) 43 | 44 | testEmptyZeroArg = ( 45 | [] value == nil ifTrue: [ ^ 1 ]. 46 | ^ 2 47 | ) 48 | 49 | testEmptyOneArg = ( 50 | ([:x | ] value: 4) == nil ifTrue: [ ^ 1 ]. 51 | ^ 2 52 | ) 53 | 54 | testEmptyTwoArg = ( 55 | ([:x :y | ] value: 4 with: 5) == nil ifTrue: [ ^ 1 ]. 56 | ^ 2 57 | ) 58 | ) 59 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/CompilerSimplification.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2014 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | CompilerSimplification = ( 24 | ---- 25 | | aField | 26 | 27 | testReturnConstantSymbol = ( ^ #constant ) 28 | testReturnConstantInt = ( ^ 42 ) 29 | 30 | testReturnSelf = (^ self) 31 | testReturnSelfImplicitly = () 32 | 33 | testReturnArgument: n = ( ^ n ) 34 | testReturnArgument: n a: a = ( ^ a ) 35 | 36 | testReturnArgumentN = ( ^ self testReturnArgument: 55 ) 37 | testReturnArgumentA = ( ^ self testReturnArgument: 55 a: 44 ) 38 | 39 | 40 | setField: val = ( aField := val ) 41 | testSetField = ( 42 | aField := #bar. 43 | self setField: #foo. 44 | ^ aField 45 | ) 46 | 47 | getField = (^ aField) 48 | testGetField = ( 49 | aField := 40. 50 | ^ self getField 51 | ) 52 | ) 53 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/Hash.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2001-2013 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | Hash = ( 24 | 25 | ---- 26 | 27 | testHash = ( 28 | | ht string array t | 29 | 30 | ht := Hashtable new. 31 | ht isEmpty 32 | ifFalse: [ 'New Hashtable not empty!'. ^ #notEmpty ]. 33 | 34 | ht at: 'a' put: 'b'. 35 | (ht containsValue: 'b') 36 | ifFalse: [ '1 not in Hashtable'. ^ 1 ]. 37 | ht isEmpty 38 | ifTrue: [ 'Nonempty Hashtable empty!'. ^ #notEmpty ]. 39 | ((ht size) = 1) 40 | ifFalse: [ 'Hashtable has wrong size!'. ^ #wrongSize ]. 41 | 42 | ht at: 'c' put: 'd'. 43 | ((ht size) = 2) 44 | ifFalse: [ 'Hashtable has wrong size!'. ^ #wrongSize ]. 45 | 46 | ht at: 1 put: 2. 47 | t := Hashtable new. 48 | ht at: Hashtable put: t. 49 | (ht containsValue: 'b') 50 | ifFalse: [ '1 not in Hashtable'. ^ 1 ]. 51 | (ht containsValue: 'd') 52 | ifFalse: [ '2 not in Hashtable'. ^ 2 ]. 53 | 54 | (ht containsValue: 2) 55 | ifFalse: [ '3 not in Hashtable'. ^ 3 ]. 56 | (ht containsValue: t) 57 | ifFalse: [ '4 not in Hashtable'. ^ 4 ]. 58 | (ht containsKey: Hashtable) 59 | ifFalse: [ 'key not found'. ^ #keyNotFound ]. 60 | 61 | ht clear. 62 | ht isEmpty ifFalse: [ 'cleared hashtable is not empty!'. ^ #notEmpty ]. 63 | ht size = 0 ifFalse: ['cleared hashtable has elements!'. ^ #hasElementsAfterCleaning ]. 64 | 65 | string := (ht get: 'a'). 66 | (string = 'b') ifTrue: [ 'get from Hashtable'. ^ 5 ]. 67 | 68 | ^ 444 69 | ) 70 | ) 71 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/IfTrueIfFalse.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2001-2013 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | IfTrueIfFalse = ( 24 | 25 | ---- 26 | 27 | test = ( 28 | ^ self resolve: 42. 29 | ) 30 | 31 | test2 = ( 32 | self resolve: 42. 33 | self resolve: 42. 34 | ^ self resolve: 33 35 | ) 36 | 37 | test3 = ( 38 | | i a | 39 | i := 4. 40 | [ i > 0 ] whileTrue: [ 41 | a := self resolve: 4. 42 | i := i - 1. 43 | ]. 44 | ^ 4 45 | ) 46 | 47 | resolve: a = ( 48 | (a == nil) ifFalse: [ ^ a ]. 49 | ) 50 | 51 | value: aBlock = ( 52 | ^ aBlock value 53 | ) 54 | ) 55 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/MethodCall.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2001-2013 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | MethodCall = ( 24 | ---- 25 | 26 | test = ( 27 | ^ self test2 28 | ) 29 | 30 | test2 = ( ^ 42 ) 31 | ) 32 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/NonLocalReturn.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2001-2013 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | NonLocalReturn = ( 24 | 25 | ---- 26 | 27 | test1 = ( | t1Frame | 28 | [ | nlrFrame | 29 | ^ 42 ] value 30 | ) 31 | test2 = ( ^ self test1 + 1 ) 32 | test3 = ( [ self test1. ^ 3 ] value ) 33 | 34 | test4 = ( ^ self at: 11 ) 35 | test5 = ( ^ self at: 10000 ) 36 | 37 | "Test case borrowed from Vector" 38 | at: index = ( self checkIndex: index ifValid: [ ^ 42 ]. 39 | "else" ^ 22 ) 40 | checkIndex: index ifValid: block = ( 41 | (10 <= index) && (index <= 100) 42 | ifTrue: [ ^ block value ] 43 | ifFalse: [ #dontcare ] 44 | ) 45 | ) 46 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/NonLocalVars.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2016 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | NonLocalVars = ( 24 | ---- 25 | 26 | testWriteDifferentTypes = ( 27 | | value | 28 | 1 to: 10 do: [:index | 29 | value := 0. 30 | self collection do: [:index | value := value + index]. 31 | value := value // 4. 32 | ]. 33 | ^value. 34 | ) 35 | 36 | collection = (^#(7 8)) 37 | ) 38 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/NumberOfTests.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2019 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | NumberOfTests = ( 24 | 25 | ---- 26 | 27 | "Return the known number of tests, 28 | should be used in basic interpreter test harness to confirm completeness" 29 | numberOfTests = ( ^ 57 ) 30 | ) 31 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/ObjectCreation.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2001-2013 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | ObjectCreation = ( 24 | 25 | ---- 26 | 27 | test = ( 28 | | i | 29 | i := 0. 30 | 31 | [i < 1000000] whileTrue: [ 32 | self new. 33 | i := i + 1. 34 | ]. 35 | ^ i 36 | ) 37 | ) 38 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/Regressions.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2019 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | Regressions = ( 24 | 25 | ---- 26 | 27 | testSymbolEquality = ( 28 | 'foo:' asSymbol = #foo: ifTrue: [ ^ 1 ]. 29 | ^ 2 30 | ) 31 | 32 | testSymbolReferenceEquality = ( 33 | 'foo:' asSymbol == #foo: ifTrue: [ ^ 1 ]. 34 | ^ 2 35 | ) 36 | 37 | testUninitializedLocal = ( 38 | | local | 39 | local == nil ifTrue: [ ^ 1 ]. 40 | ^ 2 41 | ) 42 | 43 | testUninitializedLocalInBlock = ( 44 | [ | local | 45 | local == nil ifTrue: [ ^ 1 ] ] value. 46 | ^ 2 47 | ) 48 | ) 49 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/Return.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2001-2013 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | Return = ( 24 | 25 | ---- 26 | 27 | testReturnSelf = ( ^ self ) 28 | 29 | testReturnSelfImplicitly = ( ) 30 | 31 | testNoReturnReturnsSelf = ( 1 ) 32 | 33 | testBlockReturnsImplicitlyLastValue = ( ^ ([4] value) ) 34 | ) 35 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/Self.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2001-2018 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | Self = ( 24 | 25 | ---- 26 | 27 | testAssignSuper = ( 28 | super := 42. 29 | ^ super 30 | ) 31 | 32 | testAssignSelf = ( 33 | self := 42. 34 | ^ self 35 | ) 36 | ) 37 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BasicInterpreterTests/number-of-tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | SCRIPT_PATH=`dirname $0` 3 | TEST_FILE="${SCRIPT_PATH}/NumberOfTests.som" 4 | 5 | # find all tests, count them, trim whitespace from result 6 | NUM_TESTS=`grep -R "test[^[:space:]]*[[:space:]]\+= (" "${SCRIPT_PATH}" | wc -l | tr -d '[:space:]'` 7 | 8 | TEST_CODE=" numberOfTests = ( ^ ${NUM_TESTS} )" 9 | 10 | sed -i'.old' -e 's/.*numberOfTests.*/'"${TEST_CODE}/" "${TEST_FILE}" 11 | 12 | git --no-pager diff --exit-code "${TEST_FILE}" 13 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/BlockTest.som: -------------------------------------------------------------------------------- 1 | BlockTest = TestCase ( 2 | |escape_count escaped_block| 3 | 4 | simpleBlock = ( 5 | ^[42] 6 | ) 7 | 8 | incBlock = ( 9 | ^[ :val | val + 1] 10 | ) 11 | 12 | "This requires a closure" 13 | adderBlock: amount = ( 14 | ^[ :val | amount + val] 15 | ) 16 | 17 | "Closure with mutable state in block" 18 | counterBlock = ( 19 | |count| 20 | count := 0. 21 | ^[count := count + 1. count] 22 | ) 23 | 24 | selfKeeper = ( 25 | ^[self] 26 | ) 27 | 28 | escapingBlock = ( 29 | ^[^42] 30 | ) 31 | 32 | testSimpleBlocks = ( 33 | self assert: 42 equals: self simpleBlock value. 34 | self assert: 4 equals: (self incBlock value: 3). 35 | self assert: 43 equals: ((self adderBlock: 13) value: 30). 36 | ) 37 | 38 | testClosure = ( 39 | | counter | 40 | counter := self counterBlock. 41 | self assert: 1 equals: counter value. 42 | self assert: 2 equals: counter value. 43 | self assert: 1 equals: self counterBlock value. "make sure each copy is independent" 44 | self assert: 3 equals: counter value. 45 | ) 46 | 47 | testSelfInBlock = ( 48 | | test_inst | 49 | test_inst := BlockTest new. 50 | self assert: test_inst equals: test_inst selfKeeper value. 51 | self assert: self equals: self selfKeeper value. 52 | ) 53 | 54 | testEscapedBlock = ( 55 | | escaping_block | 56 | 57 | escape_count := 0. 58 | 59 | escaping_block := self escapingBlock. 60 | 61 | self assert: 0 equals: escape_count. 62 | self assert: 666 equals: escaping_block value. 63 | self assert: 1 equals: escape_count. 64 | 65 | self assert: escaping_block is: escaped_block. 66 | ) 67 | 68 | escapedBlock: block = ( 69 | escape_count := escape_count + 1. 70 | escaped_block := block. 71 | 72 | "return some dummy value to the object that sent 'value' to block" 73 | ^666 74 | ) 75 | ) 76 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/ClassA.som: -------------------------------------------------------------------------------- 1 | ClassA = ( 2 | | a b | 3 | result = ( 4 | ^42 5 | ) 6 | ---- 7 | | c1 c2 c3 | 8 | ) 9 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/ClassB.som: -------------------------------------------------------------------------------- 1 | ClassB = ClassA ( 2 | | c d | 3 | ---- 4 | | c4 c5 c6 | 5 | ) 6 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/ClassC.som: -------------------------------------------------------------------------------- 1 | ClassC = ClassB ( 2 | | e f | 3 | a = ( ^ a ) 4 | a: val = ( a := val ) 5 | 6 | f = ( ^ f ) 7 | f: val = ( f := val ) 8 | 9 | ---- 10 | 11 | | c7 c8 c9 | 12 | 13 | setAllAndInc: anInt = ( 14 | c1 := anInt. 15 | c2 := c1 + 1. 16 | c3 := c2 + 1. 17 | c4 := c3 + 1. 18 | c5 := c4 + 1. 19 | c6 := c5 + 1. 20 | c7 := c6 + 1. 21 | c8 := c7 + 1. 22 | c9 := c8 + 1. 23 | ) 24 | 25 | getAll = ( 26 | | arr | 27 | arr := Array new: 9. 28 | arr at: 1 put: c1. 29 | arr at: 2 put: c2. 30 | arr at: 3 put: c3. 31 | arr at: 4 put: c4. 32 | arr at: 5 put: c5. 33 | arr at: 6 put: c6. 34 | arr at: 7 put: c7. 35 | arr at: 8 put: c8. 36 | arr at: 9 put: c9. 37 | ^ arr 38 | ) 39 | ) 40 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/ClassLoadingTest.som: -------------------------------------------------------------------------------- 1 | ClassLoadingTest = TestCase ( 2 | testEqualityOfClasses = ( 3 | | a b c | 4 | b := ClassB new. 5 | a := ClassA new. 6 | c := ClassC new. 7 | 8 | self assert: 42 equals: b result. 9 | self assert: 42 equals: c result. 10 | 11 | self assert: a class equals: b class superclass. 12 | self assert: b class equals: c class superclass. 13 | ) 14 | ) 15 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/ClassStructureTest.som: -------------------------------------------------------------------------------- 1 | ClassStructureTest = TestCase ( 2 | 3 | testClassIdentity = ( 4 | self assert: Array equals: Array new class. 5 | self assert: Integer equals: 1 class. 6 | self assert: Integer equals: 10000000000 class. 7 | self assert: Double equals: (1 // 2) class. 8 | self assert: Double equals: 0.5 class. 9 | self assert: Block1 equals: [42] class. 10 | self assert: Object equals: Object new class. 11 | self assert: Set equals: Set new class. 12 | self assert: String equals: 'foo' class. 13 | self assert: Symbol equals: #foo class. 14 | self assert: True equals: true class. 15 | self assert: False equals: false class. 16 | self assert: Nil equals: nil class. 17 | 18 | self assert: True superclass equals: False superclass. 19 | self assert: True superclass equals: Boolean. 20 | self assert: True superclass equals: Boolean. 21 | ) 22 | 23 | testThatCertainMethodsArePrimitives = ( 24 | | m | 25 | "This is a little fragile. 26 | Index needs to be adapted with changing Class definition." 27 | m := Object methods at: 1. 28 | "self expect: #class equals: m signature." 29 | 30 | self optional: #invokableTypes assert: Primitive equals: m class. "Class>>#name should be a primitive." 31 | 32 | m := Object methods at: 7. 33 | "self expect: #asString equals: m signature." 34 | 35 | self optional: #invokableTypes assert: Method equals: m class. "Class>>#asString should be a normal method." 36 | ) 37 | 38 | testAccessToInstanceFields = ( 39 | | o | 40 | o := ClassC new. 41 | o a: 333. 42 | self assert: 333 equals: o a. 43 | 44 | o f: 333. 45 | self assert: 333 equals: o f. 46 | ) 47 | 48 | testAccessToClassFields = ( 49 | | arr | 50 | ClassC setAllAndInc: 4. 51 | arr := ClassC getAll. 52 | 1 to: 9 do: [:i | 53 | self assert: i + (4 - 1) equals: (arr at: i). 54 | ]. 55 | 56 | "We do that here to make sure that class fields do not interfere with 57 | other class properties." 58 | self assert: ClassB is: ClassC superclass. 59 | self assert: Metaclass is: ClassC class class. 60 | self assert: #ClassC equals: ClassC name. 61 | ) 62 | 63 | testMetaclasses = ( 64 | self assert: nil is: Object superclass. 65 | self assert: Integer is: 1 class. 66 | self assert: #'Integer class' is: 1 class class name. 67 | self assert: Metaclass is: 1 class class class. 68 | 69 | self assert: #'Metaclass class' is: Metaclass class name. 70 | self assert: Metaclass is: Metaclass class class. 71 | 72 | self assert: Object is: 1 class superclass. 73 | self assert: #'Object class' is: 1 class class superclass name. 74 | self assert: Class is: Object class superclass. 75 | self assert: Metaclass is: Class class class. 76 | ) 77 | 78 | testInstanceFields = ( 79 | self assert: 2 equals: ClassA fields length. 80 | self assert: 4 equals: ClassB fields length. 81 | self assert: 6 equals: ClassC fields length. 82 | ) 83 | ) 84 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/ClosureTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: ClosureTest.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | "This test verifies that SOM blocks are indeed closures. The test was found on 27 | Eliot Miranda's Cog Blog." 28 | 29 | ClosureTest = TestCase ( 30 | testClosureProperty = ( 31 | | factorial result facs | 32 | 33 | facs := Array new: 10. 34 | facs at: 1 put: 1. 35 | facs at: 2 put: 2. 36 | facs at: 3 put: 6. 37 | facs at: 4 put: 24. 38 | facs at: 5 put: 120. 39 | facs at: 6 put: 720. 40 | facs at: 7 put: 5040. 41 | facs at: 8 put: 40320. 42 | facs at: 9 put: 362880. 43 | facs at: 10 put: 3628800. 44 | 45 | factorial := [ :n | 46 | n = 1 47 | ifTrue: [ 1 ] 48 | ifFalse: [ (factorial value: n - 1) * n ] ]. 49 | 50 | result := (1 to: 10) collect: factorial. 51 | result doIndexes: [ :i | 52 | self assert: (facs at: i) equals: (result at: i) ] 53 | ) 54 | ) 55 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/CoercionTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: CoercionTest.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2007-2013 see AUTHORS file 6 | Software Architecture Group, Hasso Plattner Institute, Potsdam, Germany 7 | http://www.hpi.uni-potsdam.de/swa/ 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining a copy 10 | of this software and associated documentation files (the 'Software'), to deal 11 | in the Software without restriction, including without limitation the rights 12 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the Software is 14 | furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included in 17 | all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 25 | THE SOFTWARE. 26 | " 27 | 28 | CoercionTest = TestCase ( 29 | 30 | testBasicNumberCoercion = ( 31 | self assert: 5 equals: 25 sqrt. 32 | self assert: 1 equals: (2 // 4) * 2. 33 | self assert: 1 equals: 2 * (2 // 4). 34 | ) 35 | ) 36 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/CompilerReturnTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: CompilerReturnTest.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2009-2013 see AUTHORS file 6 | Software Architecture Group, Hasso Plattner Institute, Potsdam, Germany 7 | http://www.hpi.uni-potsdam.de/swa/ 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining a copy 10 | of this software and associated documentation files (the 'Software'), to deal 11 | in the Software without restriction, including without limitation the rights 12 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the Software is 14 | furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included in 17 | all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 25 | THE SOFTWARE. 26 | " 27 | 28 | CompilerReturnTest = TestCase ( 29 | 30 | return1 = ( ^self ) 31 | return2 = ( ) 32 | 33 | return3: arg = ( ^self ) 34 | return4: arg = ( ) 35 | 36 | testExplicitAndImplicitReturns = ( 37 | self assert: self is: self return1. 38 | self assert: self is: self return2. 39 | self assert: self is: (self return3: 23). 40 | self assert: self is: (self return4: 23). 41 | ) 42 | 43 | 44 | "In SOM++, code after the #ifTrue: does not seem to be executed, if the 45 | block expression ends with a dot." 46 | testIfTrueWithDot = ( 47 | | arr | 48 | arr := Array new: 3. 49 | self usesIfTrueWithDot: arr. 50 | self assertArrayCorrectness: arr. 51 | ) 52 | 53 | assertArrayCorrectness: arr = ( 54 | self assert: 1 equals: (arr at: 1). "method was not executed" 55 | self assert: 2 equals: (arr at: 2). "ifTrue was not executed" 56 | self assert: 3 equals: (arr at: 3). "remainder was not executed" 57 | ) 58 | 59 | testIfTrueWithoutDot = ( 60 | | arr | 61 | arr := Array new: 3. 62 | self usesIfTrueWithoutDot: arr. 63 | self assertArrayCorrectness: arr. 64 | ) 65 | 66 | testIfFalseWithDot = ( 67 | | arr | 68 | arr := Array new: 3. 69 | self usesIfFalseWithDot: arr. 70 | self assertArrayCorrectness: arr. 71 | ) 72 | 73 | testIfFalseWithoutDot = ( 74 | | arr | 75 | arr := Array new: 3. 76 | self usesIfFalseWithoutDot: arr. 77 | self assertArrayCorrectness: arr. 78 | ) 79 | 80 | usesIfTrueWithDot: arr = ( 81 | arr at: 1 put: 1. 82 | (3 >= 1) ifTrue: [arr at: 2 put: 2. "WITH DOT"]. 83 | arr at: 3 put: 3. 84 | ) 85 | 86 | usesIfTrueWithoutDot: arr = ( 87 | arr at: 1 put: 1. 88 | (3 >= 1) ifTrue: [arr at: 2 put: 2 "WITHOUT DOT"]. 89 | arr at: 3 put: 3. 90 | ) 91 | 92 | usesIfFalseWithDot: arr = ( 93 | arr at: 1 put: 1. 94 | (3 >= 1) ifTrue: [arr at: 2 put: 2. "WITH DOT"]. 95 | arr at: 3 put: 3. 96 | ) 97 | 98 | usesIfFalseWithoutDot: arr = ( 99 | arr at: 1 put: 1. 100 | (3 >= 1) ifTrue: [arr at: 2 put: 2 "WITHOUT DOT"]. 101 | arr at: 3 put: 3. 102 | ) 103 | 104 | testWriteArgument = ( 105 | self assert: 42 equals: (self dec: 43). 106 | ) 107 | 108 | dec: anInt = ( 109 | anInt := anInt - 1. 110 | ^ anInt 111 | ) 112 | ) 113 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/DoesNotUnderstandMessage.som: -------------------------------------------------------------------------------- 1 | DoesNotUnderstandMessage = ( 2 | | target selector arguments | 3 | 4 | initializeWith: targetObj selector: aSelector arguments: argArray = ( 5 | target := targetObj. 6 | selector := aSelector. 7 | arguments := argArray. 8 | ) 9 | 10 | target = ( ^ target ) 11 | selector = ( ^ selector ) 12 | arguments = ( ^ arguments ) 13 | 14 | ---- 15 | 16 | to: target selector: selector arguments: args = ( 17 | | m | 18 | m := self new. 19 | m initializeWith: target selector: selector arguments: args. 20 | ^ m 21 | ) 22 | ) -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/DoesNotUnderstandTest.som: -------------------------------------------------------------------------------- 1 | DoesNotUnderstandTest = TestCase ( 2 | 3 | testSimpleUnknownFoo = ( 4 | | result | 5 | result := self foo. 6 | self assert: DoesNotUnderstandMessage is: result class. 7 | self assert: self is: result target. 8 | self assert: #foo is: result selector. 9 | ) 10 | 11 | testArguments = ( 12 | | result | 13 | result := self foo. 14 | self assert: Array is: result arguments class. 15 | self assert: 0 equals: result arguments length. 16 | 17 | result := self foo: 1. 18 | self assert: 1 equals: result arguments length. 19 | self assert: 1 equals: (result arguments at: 1). 20 | 21 | result := self foo: 1 bar: 2 baz: 3. 22 | self assert: 3 equals: result arguments length. 23 | self assert: 1 equals: (result arguments at: 1). 24 | self assert: 2 equals: (result arguments at: 2). 25 | self assert: 3 equals: (result arguments at: 3). 26 | ) 27 | 28 | testRepeat = ( 29 | | result | 30 | result := Array new: 5. 31 | 1 to: result length do: [:i | 32 | result at: i put: self foo. 33 | 34 | i > 1 ifTrue: [ 35 | self assert: (result at: i - 1) ~= (result at: i). 36 | ] 37 | ]. 38 | ) 39 | 40 | doesNotUnderstand: selector arguments: arguments = ( 41 | ^ DoesNotUnderstandMessage to: self selector: selector arguments: arguments. 42 | ) 43 | ) 44 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/DoubleTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: DoubleTest.som 48 2009-08-12 12:57:20Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | DoubleTest = TestCase ( 27 | 28 | testIntegerDivision = ( 29 | self assert: 1 equals: (4/3) + (4/5) 30 | ) 31 | 32 | testDoubleDivision = ( 33 | self assert: 32 // 15 equals: (4//3) + (4//5) 34 | ) 35 | 36 | testAsString = ( 37 | self assert: '0.5' equals: (1//2) asString. 38 | self assert: '0.5' equals: 0.5 asString. 39 | ) 40 | 41 | testEquals = ( 42 | self assert: (1.0 = 1). 43 | ) 44 | 45 | testRound = ( 46 | self assert: 1 equals: (5//10) round. 47 | self assert: 1 equals: (14//10) round. 48 | self assert: 445 equals: (44534//100) round. 49 | ) 50 | 51 | testAsInteger = ( 52 | self assert: 1 equals: 1.0 asInteger. 53 | self assert: 1 equals: 1.1 asInteger. 54 | self assert: 1 equals: 1.999 asInteger. 55 | 56 | self assert: -1 equals: -1.0 asInteger. 57 | self assert: -1 equals: -1.999 asInteger. 58 | ) 59 | 60 | testSin = ( 61 | | pi | 62 | pi := 3.141592653589. 63 | self assert: 0.0 equals: 0.0 sin. 64 | self assert: pi sin abs < 0.00000000001. 65 | self assert: (pi // 2.0) sin > 0.9999999999. 66 | ) 67 | 68 | testCos = ( 69 | | pi | 70 | pi := 3.141592653589. 71 | self assert: 1.0 equals: 0.0 cos. 72 | self assert: (pi // 2.0) cos abs < 0.00000000001. 73 | self assert: pi cos < -0.9999999999. 74 | ) 75 | 76 | testInfinity = ( 77 | self assert: Double PositiveInfinity > 1. 78 | self assert: Double PositiveInfinity equals: Double PositiveInfinity + 1. 79 | self assert: Double PositiveInfinity equals: Double PositiveInfinity - 1. 80 | ) 81 | ) 82 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/EmptyTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: EmptyTest.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | EmptyTest = TestCase ( 27 | 28 | "This is just an empty TestCase. 29 | It only tests the basic infrastructure" 30 | 31 | ) 32 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/GlobalTest.som: -------------------------------------------------------------------------------- 1 | GlobalTest = TestCase ( 2 | | doesntKnow | 3 | unknownGlobal: name = ( doesntKnow := name. ^ name ) 4 | 5 | testUnknownGlobalHandler = ( 6 | self assert: #foobar equals: foobar. "should return the unknown globals name" 7 | self assert: #foobar equals: doesntKnow. "and should have set it in the field" 8 | ) 9 | 10 | testKnownGlobals = ( 11 | self assert: True equals: true class. 12 | self assert: False equals: false class. 13 | self assert: Nil equals: nil class. 14 | self assert: System equals: system class. 15 | ) 16 | ) 17 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/HashTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: HashTest.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | HashTest = TestCase ( 27 | 28 | testHashtable = ( 29 | | ht string array t | 30 | 31 | ht := Hashtable new. 32 | self assert: ht isEmpty description: 'new ht needs to be empty'. 33 | 34 | ht at: 'a' put: 'b'. 35 | self assert: (ht containsValue: 'b') description: 'needs to contain "b"'. 36 | self deny: ht isEmpty. 37 | 38 | self assert: 1 equals: ht size. 39 | 40 | ht at: 'c' put: 'd'. 41 | self assert: 2 equals: ht size. 42 | 43 | ht at: 1 put: 2. 44 | t := Hashtable new. 45 | ht at: Hashtable put: t. 46 | system fullGC. 47 | 48 | self assert: (ht containsValue: 'b') description: 'needs to contain "b"'. 49 | self assert: (ht containsValue: 'd') description: 'needs to contain "d"'. 50 | self assert: (ht containsValue: 2) description: 'needs to contain "2"'. 51 | self assert: (ht containsValue: t) description: 'needs to contain t'. 52 | self assert: (ht containsKey: Hashtable) description: 'needs to contain Hashtable'. 53 | 54 | ht clear. 55 | self assert: ht isEmpty. 56 | self assert: 0 equals: ht size. 57 | 58 | self assert: nil equals: (ht get: 'a'). 59 | ) 60 | ) 61 | 62 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/PreliminaryTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: PreliminaryTest.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | "... something just a bit complicated that tests iteration with 27 | blocks, so that we might fail here rather than when the other tests 28 | start, in case things are broken." 29 | 30 | PreliminaryTest = TestCase ( 31 | 32 | testBasicSanity = ( 33 | | sum | 34 | sum := 0. 35 | 1, 2, 3 do: [ :i | 36 | sum := sum + i. 37 | i<2 ifTrue: [ sum := sum*2 ]. 38 | i>2 ifFalse: [ sum := sum*2 ] ]. 39 | self assert: 15 equals: sum 40 | ) 41 | 42 | ) 43 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/ReflectionTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: ReflectionTest.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2007-2013 see AUTHORS file 6 | Software Architecture Group, Hasso Plattner Institute, Potsdam, Germany 7 | http://www.hpi.uni-potsdam.de/swa/ 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining a copy 10 | of this software and associated documentation files (the 'Software'), to deal 11 | in the Software without restriction, including without limitation the rights 12 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the Software is 14 | furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included in 17 | all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 25 | THE SOFTWARE. 26 | " 27 | 28 | ReflectionTest = TestCase ( 29 | testResondsTo = ( 30 | self assert: (Object new respondsTo: #isNil). 31 | self assert: (23 respondsTo: #isNil). 32 | self assert: (23 respondsTo: #+). 33 | ) 34 | 35 | testMethods = ( 36 | "First method in Object should be #class." 37 | self assert: #class equals: (Object methods at: 1) signature. 38 | self assert: (Object hasMethod: #==). 39 | ) 40 | 41 | testPerform = ( 42 | | o | 43 | self assert: Integer equals: (23 perform: #class). 44 | self assert: (23 perform: #between:and: withArguments: (Array with: 22 with: 24)). 45 | 46 | o := SuperTest new. 47 | self assert: #super equals: (o perform: #something inSuperclass: SuperTestSuperClass). 48 | 49 | "Trying to see whether the stack in bytecode-based SOMs works properly" 50 | self assert: #a equals: ((23 perform: #class) = Integer ifTrue: [#a] ifFalse: [#b]). 51 | 52 | self assert: 28 equals: 5 + (23 perform: #value). 53 | ) 54 | 55 | testInstVarAtAndPut = ( 56 | | tmp | 57 | "Testing #at: and #at:put:" 58 | tmp := Pair withKey: 3 andValue: 42. 59 | 60 | self assert: tmp key equals: (tmp instVarAt: 1). 61 | 62 | tmp instVarAt: 1 put: #foo. 63 | self assert: #foo equals: tmp key. 64 | ) 65 | ) 66 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/SelfBlockTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: SelfBlockTest.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2007-2013 see AUTHORS file 6 | Software Architecture Group, Hasso Plattner Institute, Potsdam, Germany 7 | http://www.hpi.uni-potsdam.de/swa/ 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining a copy 10 | of this software and associated documentation files (the 'Software'), to deal 11 | in the Software without restriction, including without limitation the rights 12 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the Software is 14 | furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included in 17 | all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 25 | THE SOFTWARE. 26 | " 27 | 28 | SelfBlockTest = TestCase ( 29 | 30 | testEscapedBlock = ( 31 | self assert: 42 equals: self give42 value 32 | ) 33 | 34 | give42 = ( 35 | ^[ self giveBlock value ] 36 | ) 37 | 38 | giveBlock = ( 39 | ^self returnBlock value 40 | ) 41 | 42 | returnBlock = ( 43 | ^[ self returnBlock2 value ] 44 | ) 45 | 46 | returnBlock2 = ( 47 | ^[ 42 ] 48 | ) 49 | ) 50 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/SetTest.som: -------------------------------------------------------------------------------- 1 | SetTest = TestCase ( 2 | testBasics = ( 3 | | a b t | 4 | a := Set new. 5 | b := Set new. 6 | 7 | a add: #a. 8 | b add: #b. 9 | 10 | self deny: a = b. 11 | 12 | t := Set new. 13 | t add: #a. 14 | 15 | self deny: a == t. "different objects" 16 | self assert: a equals: t. "but with equal value" 17 | ) 18 | ) 19 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/SpecialSelectorsTest.som: -------------------------------------------------------------------------------- 1 | SpecialSelectorsTest = TestCase ( 2 | testMinusMinsPrefix = ( 3 | self assert: self --> 1 equals: 1. 4 | self assert: self -- 1 equals: 1. 5 | ) 6 | 7 | --> aValue = ( 8 | ^1 9 | ) 10 | 11 | -- aValue = ( 12 | ^1 13 | ) 14 | ) 15 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/StringTest.som: -------------------------------------------------------------------------------- 1 | " 2 | Copyright (c) 2001-2013 see AUTHORS file 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining a copy 5 | of this software and associated documentation files (the 'Software'), to deal 6 | in the Software without restriction, including without limitation the rights 7 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 | copies of the Software, and to permit persons to whom the Software is 9 | furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included in 12 | all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 | THE SOFTWARE. 21 | " 22 | 23 | StringTest = TestCase ( 24 | 25 | testEquality = ( 26 | | str1 str2 | 27 | str1 := 'foo'. 28 | str2 := 'bar'. 29 | 30 | self assert: str1 = str1. 31 | self assert: str1 = 'foo'. 32 | self assert: str1 = ('f' + 'oo'). 33 | self deny: str1 = str2. 34 | self assert: str2 = str2. 35 | ) 36 | 37 | testLength = ( 38 | self assert: 1 equals: 't' length. 39 | self assert: 6 equals: ('foo' + 'bar') length. 40 | ) 41 | 42 | testCharAt = ( 43 | | str | 44 | str := 'foobar'. 45 | self assert: 'f' equals: (str charAt: 1). 46 | self assert: 'o' equals: (str charAt: 2). 47 | self assert: 'o' equals: (str charAt: 3). 48 | self assert: 'b' equals: (str charAt: 4). 49 | self assert: 'a' equals: (str charAt: 5). 50 | self assert: 'r' equals: (str charAt: 6). 51 | ) 52 | 53 | testStringLiteralLineBreak = ( 54 | | str | 55 | "Some parsers get the literals and line bounderies wrong" 56 | str := ' 57 | '. 58 | self assert: '\n' equals: (str charAt: 1). 59 | self assert: 1 equals: str length. 60 | ) 61 | 62 | testPrimSubstringFrom = ( 63 | | str | 64 | str := 'foobar'. 65 | self assert: 'foo' equals: (str primSubstringFrom: 1 to: 3). 66 | self assert: 'bar' equals: (str primSubstringFrom: 4 to: 6). 67 | self assert: 'foobar' equals: (str primSubstringFrom: 1 to: 6). 68 | self assert: 'oob' equals: ('foobar' substringFrom: 2 to: 4). 69 | ) 70 | 71 | testBeginsWith = ( 72 | self deny: ('foo' beginsWith: 'oo'). 73 | self assert: ('foo' beginsWith: 'foo'). 74 | ) 75 | 76 | testEndsWith = ( 77 | self assert: ('foo' endsWith: 'foo'). 78 | self assert: ('foo' endsWith: 'oo'). 79 | self deny: ('f' endsWith: 'bar'). 80 | self deny: ('f' endsWith: 'foo'). 81 | ) 82 | 83 | testMultiLineString = ( 84 | "Test whether the parser will parse multi-line strings correctly." 85 | self assert: ' 86 | 1234567890 87 | 1234567890 88 | 1234567890 89 | 1234567890 90 | 1234567890' equals: ' 91 | 1234567890 92 | 1234567890 93 | 1234567890 94 | 1234567890 95 | 1234567890' 96 | ) 97 | 98 | testEscapeSequences = ( 99 | "Tests for escape sequences, not all of them are reliable represented as 100 | proper strings. So, we do a simple equality test, and check substring or 101 | length. 102 | 103 | \t a tab character 104 | \b a backspace character 105 | \n a newline character 106 | \r a carriage return character 107 | \f a formfeed character 108 | \' a single quote character 109 | \\ backslash character 110 | \0 zero byte character 111 | " 112 | 113 | self assert: '\t' equals: '\t'. 114 | self assert: 1 equals: '\t' length. 115 | 116 | self assert: '\b' equals: '\b'. 117 | self assert: 1 equals: '\b' length. 118 | 119 | self assert: '\n' equals: '\n'. 120 | self assert: 1 equals: '\n' length. 121 | self deny: ('\n' endsWith: 'n'). 122 | 123 | self assert: '\r' equals: '\r'. 124 | self assert: 1 equals: '\n' length. 125 | self deny: ('\r' endsWith: 'r'). 126 | 127 | self assert: '\f' equals: '\f'. 128 | self assert: 1 equals: '\f' length. 129 | self deny: ('\f' endsWith: 'f'). 130 | 131 | self assert: '\'' equals: '\''. 132 | self assert: 1 equals: '\'' length. 133 | 134 | self assert: '\\' equals: '\\'. 135 | self assert: 1 equals: '\\' length. 136 | 137 | self assert: '\0' equals: '\0'. 138 | self assert: 1 equals: '\0' length. 139 | self assert: 5 equals: '\0rest' length. 140 | ) 141 | 142 | testHash = ( 143 | | str | 144 | "Hash should be identical for strings that are identical, 145 | whether given literal or composed at runtime" 146 | self assert: 'foobar' hashcode equals: 'foobar' hashcode. 147 | self assert: 'ssdf aksdf; kasd;fk a;dfk a;dfk a;d' hashcode 148 | equals: 'ssdf aksdf; kasd;fk a;dfk a;dfk a;d' hashcode. 149 | 150 | str := 'foo' + 'bar'. 151 | str := str + str. 152 | self assert: 'foobarfoobar' hashcode equals: str hashcode. 153 | 154 | str := 'dfadf fgsfg sfg sdfg sfg sfg' + '345243n 24n5 kwertlw erltnwrtln'. 155 | self assert: 'dfadf fgsfg sfg sdfg sfg sfg345243n 24n5 kwertlw erltnwrtln' hashcode 156 | equals: str hashcode. 157 | ) 158 | 159 | testWhiteSpace = ( 160 | self assert: ' ' isWhiteSpace. 161 | self assert: '\t' isWhiteSpace. 162 | self assert: '\t\n \n \n' isWhiteSpace. 163 | 164 | self deny: '' isWhiteSpace. 165 | self deny: '\t\n N \n \n' isWhiteSpace. 166 | self deny: 'N' isWhiteSpace. 167 | self deny: '3' isWhiteSpace. 168 | ) 169 | 170 | testLetters = ( 171 | self assert: 'a' isLetters. 172 | self assert: 'all' isLetters. 173 | self optional: #unicode assert: 'aOoöéÉíä' isLetters description: 'Does not support Unicode'. 174 | 175 | self deny: '' isLetters. 176 | self deny: ' ' isLetters. 177 | self deny: '3' isLetters. 178 | self deny: '3333' isLetters. 179 | self deny: 'aOo öéÉíä' isLetters. 180 | self deny: 'aOo1öéÉíä' isLetters. 181 | ) 182 | 183 | testDigits = ( 184 | self assert: '0' isDigits. 185 | self assert: '0123' isDigits. 186 | self assert: '0123456789' isDigits. 187 | 188 | self deny: '' isDigits. 189 | self deny: ' ' isDigits. 190 | self deny: 'S' isDigits. 191 | self deny: '333 3' isDigits. 192 | self deny: '66i77' isDigits. 193 | self deny: '66e7' isDigits. 194 | self deny: 'aOo1öéÉíä' isDigits. 195 | ) 196 | ) 197 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/SuperTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | Copyright (c) 2007-2018 see AUTHORS file 4 | Software Architecture Group, Hasso Plattner Institute, Potsdam, Germany 5 | http://www.hpi.uni-potsdam.de/swa/ 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | SuperTest = SuperTestSuperClass ( 27 | 28 | testSuper = ( 29 | self assert: 42 equals: self give42. 30 | self assert: 42 equals: self blockGive42. 31 | ) 32 | 33 | yourself = ( 34 | record := record + 1000. 35 | ^ self 36 | ) 37 | 38 | give42 = ( 39 | ^super give42 40 | ) 41 | 42 | blockGive42 = ( 43 | ^[ super give42 ] value 44 | ) 45 | 46 | something = ( 47 | ^ #sub 48 | ) 49 | 50 | number = ( 51 | ^ 10 52 | ) 53 | 54 | testWithBinaryUnaryMessage = ( 55 | | val | 56 | record := 0. 57 | val := super number * super number. 58 | self assert: 1 equals: val. 59 | ) 60 | 61 | testWithBinaryUnaryUnaryMessage = ( 62 | | val | 63 | record := 0. 64 | super yourself yourself @ super yourself yourself. 65 | self assert: 2002 equals: record. 66 | ) 67 | 68 | testWithKeywordUnaryUnaryMessage = ( 69 | | val | 70 | record := 0. 71 | super key: super yourself yourself key: super yourself yourself. 72 | self assert: 2002 equals: record. 73 | 74 | record := 0. 75 | self key: super yourself yourself key: super yourself yourself. 76 | self assert: 2002 equals: record. 77 | ) 78 | 79 | "Note: testing assigning self was moved to basic interpreter tests" 80 | 81 | testGlobalSelfDoesNotShadowKeyword = ( 82 | | that | 83 | that := self. 84 | system global: #self put: 42. 85 | that optional: #selfSuperBug assert: that is: self. 86 | 87 | self assert: 42 equals: (system global: #self) 88 | ) 89 | 90 | testGlobalSuperDoesNotShadowKeyword = ( 91 | | that | 92 | that := super. 93 | system global: #super put: 42. 94 | that optional: #selfSuperBug assert: that is: super. 95 | 96 | self assert: 42 equals: (system global: #super) 97 | ) 98 | ) 99 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/SuperTestSuperClass.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: SuperTestSuperClass.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2007-2013 see AUTHORS file 6 | Software Architecture Group, Hasso Plattner Institute, Potsdam, Germany 7 | http://www.hpi.uni-potsdam.de/swa/ 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining a copy 10 | of this software and associated documentation files (the 'Software'), to deal 11 | in the Software without restriction, including without limitation the rights 12 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the Software is 14 | furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included in 17 | all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 25 | THE SOFTWARE. 26 | " 27 | 28 | SuperTestSuperClass = TestCase ( 29 | | record | 30 | 31 | yourself = ( 32 | record := record + 1. 33 | ^ self 34 | ) 35 | 36 | give42 = ( 37 | ^ 42 38 | ) 39 | 40 | something = ( 41 | ^ #super 42 | ) 43 | 44 | number = ( 45 | ^ 1 46 | ) 47 | 48 | key: a key: b = ( 49 | ^ self 50 | ) 51 | 52 | @ o = ( ^ self ) 53 | ) 54 | 55 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/SymbolTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: SymbolTest.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2007-2013 see AUTHORS file 6 | Software Architecture Group, Hasso Plattner Institute, Potsdam, Germany 7 | http://www.hpi.uni-potsdam.de/swa/ 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining a copy 10 | of this software and associated documentation files (the 'Software'), to deal 11 | in the Software without restriction, including without limitation the rights 12 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the Software is 14 | furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included in 17 | all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 25 | THE SOFTWARE. 26 | " 27 | 28 | SymbolTest = TestCase ( 29 | 30 | testConversion = ( 31 | self assert: 'gunk' equals: 'gunk' asSymbol asString. 32 | self assert: 'oink' equals: #oink asString. 33 | ) 34 | 35 | testEquality = ( 36 | self assert: #oink is: 'oink' asSymbol. 37 | ) 38 | 39 | testSymbolIsString = ( 40 | self assert: (#oink beginsWith: 'oink'). 41 | self assert: 100 equals: #'100' asInteger. 42 | self assert: String equals: #foo class superclass 43 | ) 44 | ) 45 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/SystemTest.som: -------------------------------------------------------------------------------- 1 | SystemTest = TestCase ( 2 | 3 | testFullGCSupport = ( 4 | "Test whether #fullGC is support. We expect the VM now to return true, 5 | to indicate the a GC was done." 6 | self optional: #fullGCWithEffect assert: system fullGC description: '#fullGC is not supported or has not immediate effect.' 7 | ) 8 | 9 | testTicks = ( 10 | | ticks | 11 | ticks := system ticks. 12 | self assert: ticks class equals: Integer. 13 | self assert: ticks > 0 description: 'Should return the microseconds since the start' 14 | ) 15 | ) 16 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/TestCase.som: -------------------------------------------------------------------------------- 1 | TestCase = ( 2 | | testSelector runner failed | 3 | 4 | selector = ( ^ testSelector ) 5 | selector: aSym = ( testSelector := aSym ) 6 | 7 | "asserting" 8 | assert: aBoolean = ( 9 | runner countAssert. 10 | aBoolean ifFalse: [ 11 | self signalFailure: 'Assertion failed' ] ) 12 | 13 | assert: aBoolean description: aStringOrBlock = ( 14 | runner countAssert. 15 | aBoolean ifFalse: [ 16 | self signalFailure: aStringOrBlock value ] ) 17 | 18 | assert: expected equals: actual = ( 19 | "test value equality" 20 | self assert: (expected = actual) 21 | description: [self comparingStringBetween: expected and: actual] 22 | ) 23 | 24 | assert: expected is: actual = ( 25 | "test reference equality" 26 | self assert: (expected == actual) 27 | description: [self comparingStringBetween: expected and: actual] 28 | ) 29 | 30 | optional: aSymbol assert: aBoolean = ( 31 | runner countAssert. 32 | aBoolean ifFalse: [ 33 | self signalUnsupported: aSymbol description: nil ] ) 34 | 35 | optional: aSymbol assert: expected equals: actual = ( 36 | self optional: aSymbol 37 | assert: (expected = actual) 38 | description: [self comparingStringBetween: expected and: actual] 39 | ) 40 | 41 | optional: aSymbol assert: expected is: actual = ( 42 | self optional: aSymbol 43 | assert: (expected == actual) 44 | description: [self comparingStringBetween: expected and: actual] 45 | ) 46 | 47 | optional: aSymbol assert: aBoolean description: aStringOrBlock = ( 48 | runner countAssert. 49 | aBoolean ifFalse: [ 50 | self signalUnsupported: aSymbol description: aStringOrBlock value ] ) 51 | 52 | deny: aBoolean = ( 53 | self assert: aBoolean not 54 | ) 55 | 56 | deny: aBooleanOrBlock description: aString = ( 57 | self assert: aBooleanOrBlock value not description: aString 58 | ) 59 | 60 | optional: aSymbol deny: aBoolean = ( 61 | self optional: aSymbol assert: aBoolean not 62 | ) 63 | 64 | optional: aSymbol deny: aBooleanOrBlock description: aString = ( 65 | self optional: aSymbol assert: aBooleanOrBlock value not description: aString 66 | ) 67 | 68 | signalFailure: aString = ( 69 | failed := true. 70 | runner fail: self class name + '>>#' + testSelector 71 | because: aString. 72 | ) 73 | 74 | signalUnsupported: aSymbol description: aDescription = ( 75 | runner unsupported: aSymbol 76 | test: self class name + '>>#' + testSelector 77 | because: aDescription. 78 | ) 79 | 80 | comparingStringBetween: expected and: actual = ( 81 | ^ 'Expected ' + expected asString + 82 | ' but was ' + actual asString + '.' 83 | ) 84 | 85 | "running" 86 | run: aRunner = ( 87 | runner := aRunner. 88 | failed := false. 89 | 90 | self setUp. 91 | self performTest. 92 | self tearDown. 93 | 94 | failed ifFalse: [ 95 | runner passed: self class name + '>>#' + testSelector 96 | ]. 97 | ) 98 | 99 | setUp = () 100 | tearDown = () 101 | 102 | performTest = ( self perform: testSelector ) 103 | 104 | ---- 105 | 106 | for: aSelector = ( 107 | | case | 108 | case := self new. 109 | case selector: aSelector. 110 | ^ case 111 | ) 112 | 113 | tests = ( 114 | | tests | 115 | tests := Vector new: self methods length. 116 | self methods do: [:m | 117 | (m signature beginsWith: #test) ifTrue: [ 118 | tests append: (self for: m signature). 119 | ]. 120 | ]. 121 | 122 | ^ tests 123 | ) 124 | ) 125 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/TestHarness.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: TestHarness.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2001-2013 see AUTHORS file 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the 'Software'), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | " 25 | 26 | TestHarness = ( 27 | | failOnUnsupportedOptionals | 28 | 29 | 30 | tests = ( "Now ordered by alphabetical order to improve maintainability" 31 | ^ EmptyTest, 32 | SpecialSelectorsTest, 33 | ArrayTest, 34 | "BlockTest," 35 | ClassLoadingTest, 36 | ClassStructureTest, 37 | ClosureTest, 38 | CoercionTest, 39 | CompilerReturnTest, 40 | DoesNotUnderstandTest, 41 | DoubleTest, 42 | GlobalTest, 43 | HashTest, 44 | IntegerTest, 45 | PreliminaryTest, 46 | ReflectionTest, 47 | SelfBlockTest, 48 | SetTest, 49 | StringTest, 50 | SuperTest, 51 | SymbolTest, 52 | SystemTest, 53 | VectorTest 54 | ) 55 | 56 | 57 | runAllSuites = ( 58 | | totalTestNum successfulTestNum unsupportedTestNum totalAssertionNum | 59 | totalTestNum := 0. 60 | unsupportedTestNum := 0. 61 | successfulTestNum := 0. 62 | totalAssertionNum := 0. 63 | 64 | self tests do: [ :test | 65 | | runner | 66 | test name println. 67 | runner := TestRunner new. 68 | runner initializeOn: test. 69 | runner runAllTests. 70 | (runner hasUnsupported or: [runner hasFailures]) 71 | ifTrue: [ 72 | 'Test Suite: ' print. 73 | test name println. 74 | runner overviewReport. 75 | '' println ]. 76 | 77 | totalTestNum := totalTestNum + runner expectedPasses. 78 | unsupportedTestNum := unsupportedTestNum + runner actualUnsupported. 79 | successfulTestNum := successfulTestNum + runner actualPasses. 80 | totalAssertionNum := totalAssertionNum + runner numAsserts. 81 | ]. 82 | 83 | 'Total number of tests: ' print. 84 | totalTestNum println. 85 | 'Number of unsupported optionals: ' print. 86 | unsupportedTestNum println. 87 | 'Number of successful tests: ' print. 88 | successfulTestNum println. 89 | 'Number of assertions tested: ' print. 90 | totalAssertionNum println. 91 | 92 | (failOnUnsupportedOptionals and: [unsupportedTestNum > 0]) 93 | ifTrue: [system exit: 1]. 94 | totalTestNum = successfulTestNum 95 | ifFalse: [system exit: 1]. 96 | ) 97 | 98 | runOneSuite: name = ( 99 | | testName runner | 100 | testName := name. 101 | (testName endsWith: 'Test') ifFalse: [ 102 | testName := testName + 'Test']. 103 | 104 | runner := TestRunner new. 105 | runner initializeOn: (system resolve: testName asSymbol). 106 | runner run. 107 | runner hasFailures ifTrue: [system exit: 1] 108 | ) 109 | 110 | run: args = ( 111 | failOnUnsupportedOptionals := false. 112 | 113 | args length = 1 ifTrue: [ self runAllSuites. ]. 114 | args length = 2 ifTrue: [ 115 | ((args at: 2) beginsWith: '--') ifTrue: [ 116 | (args at: 2) = '--help' ifTrue: [ 117 | 'TestHarness.som [--help] [--fail-on-optionals] [TestSuiteName]' println. 118 | system exit: 0 ]. 119 | 120 | (args at: 2) = '--fail-on-optionals' ifTrue: [ 121 | failOnUnsupportedOptionals := true ]. 122 | 123 | self runAllSuites 124 | ] ifFalse: [ 125 | self runOneSuite: (args at: 2) ]]. 126 | ) 127 | ) 128 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/TestRunner.som: -------------------------------------------------------------------------------- 1 | TestRunner = ( 2 | | suite passes unsupported failures numAsserts | 3 | 4 | initializeOn: aSuite = ( 5 | suite := aSuite. 6 | 7 | passes := Vector new. 8 | unsupported := Vector new. 9 | failures := Vector new. 10 | 11 | numAsserts := 0. 12 | ) 13 | 14 | hasUnsupported = ( ^ unsupported size > 0 ) 15 | hasFailures = ( ^ failures size > 0 ) 16 | 17 | actualUnsupported = ( ^ unsupported size ) 18 | expectedPasses = ( ^ suite tests size ) 19 | actualPasses = ( ^ passes size ) 20 | 21 | run = ( 22 | self reportPreRun. 23 | self runAllTests. 24 | self reportPostRun. 25 | self overviewReport. 26 | ) 27 | 28 | countAssert = ( 29 | numAsserts := numAsserts + 1. 30 | ) 31 | 32 | numAsserts = ( 33 | ^ numAsserts 34 | ) 35 | 36 | reportPreRun = ( 37 | ('TestSuite ' + suite name + ':') println. 38 | ('Tests: ' + suite tests size asString) println. 39 | ) 40 | 41 | reportPostRun = ( 42 | self hasUnsupported ifTrue: [ 43 | ('Unsupported optional: ' + unsupported size asString) println 44 | ]. 45 | self hasFailures ifTrue: [ 46 | ('Failures: ' + failures size asString) println 47 | ]. 48 | ) 49 | 50 | runAllTests = ( 51 | suite tests do: [ :each | 52 | each run: self ]. 53 | ) 54 | 55 | overviewReport = ( 56 | ('Tests passed: ' + passes size asString) println. 57 | 58 | (self hasFailures or: [self hasUnsupported]) ifTrue: [ 59 | '------------------------------' println ]. 60 | 61 | self hasUnsupported ifTrue: [ 62 | | lastCategory | 63 | ('Unsupported optional features: ' + unsupported size asString) println. 64 | unsupported do: [:each | 65 | | cat | 66 | cat := each at: 1. 67 | cat == lastCategory ifFalse: [ 68 | lastCategory := cat. 69 | ('\t' + cat) println ]. 70 | ('\t\t' + (each at: 2) asString) println. 71 | ('\t\t\t' + (each at: 3) value asString) println ]. 72 | ]. 73 | 74 | self hasFailures ifTrue: [ 75 | ('Failures: ' + failures size asString) println. 76 | failures do: [:each | 77 | (' ' + each key asString) println. 78 | (' ' + each value asString) println ]. 79 | ]. 80 | ) 81 | 82 | fail: aSignature because: aReason = ( 83 | | pair | 84 | pair := Pair withKey: aSignature andValue: aReason. 85 | failures append: pair. 86 | ) 87 | 88 | unsupported: aSymbol test: aSignature because: aReason = ( 89 | | array | 90 | array := Array with: aSymbol with: aSignature with: aReason. 91 | unsupported append: array. 92 | ) 93 | 94 | passed: aSignature = ( 95 | passes append: aSignature 96 | ) 97 | ) 98 | -------------------------------------------------------------------------------- /third_party/SOM-st/SOM/TestSuite/VectorTest.som: -------------------------------------------------------------------------------- 1 | " 2 | 3 | $Id: ArrayTest.som 30 2009-07-31 12:20:25Z michael.haupt $ 4 | 5 | Copyright (c) 2007-2013 see AUTHORS file 6 | Software Architecture Group, Hasso Plattner Institute, Potsdam, Germany 7 | http://www.hpi.uni-potsdam.de/swa/ 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining a copy 10 | of this software and associated documentation files (the 'Software'), to deal 11 | in the Software without restriction, including without limitation the rights 12 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | copies of the Software, and to permit persons to whom the Software is 14 | furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included in 17 | all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 25 | THE SOFTWARE. 26 | " 27 | 28 | VectorTest = TestCase ( 29 | | a | 30 | 31 | setUp = ( 32 | a := Vector new. 33 | a append: 'hello'. 34 | a append: #world. 35 | a append: 23. 36 | ) 37 | 38 | testSize = ( 39 | self assert: 3 equals: a size. 40 | ) 41 | 42 | testAt = ( 43 | self assert: #world equals: (a at: 2). 44 | self assert: 23 equals: (a at: 3). 45 | ) 46 | 47 | testContains = ( 48 | self assert: (a contains: 23). 49 | ) 50 | 51 | testDo = ( 52 | | j | 53 | j := 1. 54 | a do: [:i | 55 | self assert: i equals: (a at: j). 56 | j := j + 1. 57 | ]. 58 | ) 59 | ) 60 | --------------------------------------------------------------------------------