Eliot Miranda uploaded a new version of VMMakerCompatibilityForPharo6 to project VM Maker: http://source.squeak.org/VMMaker/VMMakerCompatibilityForPharo6-eem.6.mcz
==================== Summary ====================
Name: VMMakerCompatibilityForPharo6-eem.6 Author: eem Time: 9 September 2018, 6:48:54.587661 pm UUID: 10e0cac0-d431-0d00-bccf-c5da012ef449 Ancestors: VMMakerCompatibilityForPharo6-eem.5
Add translation support to RBProgramNode such that simple methods such as primitiveMakePoint can be translated to C. Still work needed to run the workspace translation scripts, which translate everything to be able to run inlining before generating C for a single method.
Add ClosureExtractor, DisplayText and TranscriptStream as needed support classes now missing in Pharo6.
Add bytesPerElement to the Collection hierarchy, again support dropped from Pharo6 (perhaps because image segments are not supported?).
=============== Diff against VMMakerCompatibilityForPharo6-eem.5 ===============
Item was added: + DisplayObject subclass: #DisplayText + instanceVariableNames: 'text textStyle offset form foreColor backColor' + classVariableNames: '' + poolDictionaries: 'TextConstants' + category: 'VMMakerCompatibilityForPharo6'! + + !DisplayText commentStamp: '<historical>' prior: 0! + I represent Text whose emphasis changes are mapped to a set of fonts. My instances have an offset used in determining screen placement for displaying. They get used two different ways in the system. In the user interface, they mainly hold onto some text which is viewed by some form of ParagraphEditor. However, as a DisplayObject, they may need to display efficiently, so my instances have a cache for the bits.!
Item was added: + ----- Method: DisplayText class>>example (in category 'examples') ----- + example + "Continually prints two lines of text wherever you point with the cursor. Terminate by pressing any button on the + mouse." + | tx | + tx := 'this is a line of characters and + this is the second line.' asDisplayText. + tx foregroundColor: Color black backgroundColor: Color transparent. + tx := tx alignedTo: #center. + [Sensor anyButtonPressed] + whileFalse: + [tx displayOn: Display at: Sensor cursorPoint] + + "DisplayText example."!
Item was added: + ----- Method: DisplayText class>>text: (in category 'instance creation') ----- + text: aText + "Answer an instance of me such that the text displayed is aText + according to the system's default text style." + + ^self new + setText: aText + textStyle: DefaultTextStyle copy + offset: 0 @ 0!
Item was added: + ----- Method: DisplayText class>>text:textStyle: (in category 'instance creation') ----- + text: aText textStyle: aTextStyle + "Answer an instance of me such that the text displayed is aText + according to the style specified by aTextStyle." + + ^self new + setText: aText + textStyle: aTextStyle + offset: 0 @ 0!
Item was added: + ----- Method: DisplayText class>>text:textStyle:offset: (in category 'instance creation') ----- + text: aText textStyle: aTextStyle offset: aPoint + "Answer an instance of me such that the text displayed is aText + according to the style specified by aTextStyle. The display of the + information should be offset by the amount given as the argument, + aPoint." + + ^self new + setText: aText + textStyle: aTextStyle + offset: aPoint!
Item was added: + ----- Method: DisplayText>>alignedTo: (in category 'accessing') ----- + alignedTo: alignPointSelector + "Return a copy with offset according to alignPointSelector which is one of... + #(topLeft, topCenter, topRight, leftCenter, center, etc)" + | boundingBox | + boundingBox := 0@0 corner: self form extent. + ^ self shallowCopy offset: (0@0) - (boundingBox perform: alignPointSelector)!
Item was added: + ----- Method: DisplayText>>backgroundColor (in category 'color') ----- + backgroundColor + backColor == nil ifTrue: [^ Color transparent]. + ^ backColor!
Item was added: + ----- Method: DisplayText>>boundingBox (in category 'display box access') ----- + boundingBox + "Refer to the comment in DisplayObject|boundingBox." + + ^self form boundingBox!
Item was added: + ----- Method: DisplayText>>composeForm (in category 'private') ----- + composeForm + | tmpText canvas | + tmpText := TextMorph new contentsAsIs: self text deepCopy. + self foregroundColor ifNotNil: [:color | + tmpText text addAttribute: (TextColor color: color)]. + self backgroundColor ifNotNil: [:color | + tmpText backgroundColor: color]. + tmpText setTextStyle: "displayText textStyle" TextStyle default. + canvas := FormCanvas on: (Form extent: tmpText extent depth: 32). + tmpText drawOn: canvas. + form := canvas form!
Item was added: + ----- Method: DisplayText>>computeBoundingBox (in category 'display box access') ----- + computeBoundingBox + "Compute minimum enclosing rectangle around characters." + + | character font width carriageReturn lineWidth lineHeight | + carriageReturn := Character cr. + width := lineWidth := 0. + font := textStyle defaultFont. + lineHeight := textStyle lineGrid. + 1 to: text size do: + [:i | + character := text at: i. + character = carriageReturn + ifTrue: + [lineWidth := lineWidth max: width. + lineHeight := lineHeight + textStyle lineGrid. + width := 0] + ifFalse: [width := width + (font widthOf: character)]]. + lineWidth := lineWidth max: width. + ^offset extent: lineWidth @ lineHeight!
Item was added: + ----- Method: DisplayText>>displayOn:at:clippingBox:rule:fillColor: (in category 'displaying') ----- + displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm + "For TT font, rule 34 is used if possible." + "Refer to the comment in + DisplayObject|displayOn:at:clippingBox:rule:mask:." + + | form1 rule | + form1 := self form. + rule := (ruleInteger = Form over and: [backColor isTransparent]) + ifTrue: [form1 depth = 32 ifTrue: [rule := 34] ifFalse: [Form paint]] + ifFalse: [ruleInteger]. + form1 depth = 32 ifTrue: [rule := 34]. + form1 + displayOn: aDisplayMedium + at: aDisplayPoint + offset + clippingBox: clipRectangle + rule: rule + fillColor: aForm!
Item was added: + ----- Method: DisplayText>>displayOn:transformation:clippingBox:align:with:rule:fillColor: (in category 'displaying') ----- + displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm + "Refer to the comment in + DisplayObject|displayOn:transformation:clippingBox:align:with:rule:mask:." + + | absolutePoint | + absolutePoint := displayTransformation applyTo: relativePoint. + absolutePoint := absolutePoint x asInteger @ absolutePoint y asInteger. + self displayOn: aDisplayMedium + at: absolutePoint - alignmentPoint + clippingBox: clipRectangle + rule: ruleInteger + fillColor: aForm!
Item was added: + ----- Method: DisplayText>>displayOnPort:at: (in category 'displaying') ----- + displayOnPort: aPort at: location + self form displayOnPort: aPort at: location + offset!
Item was added: + ----- Method: DisplayText>>fontsUsed (in category 'accessing') ----- + fontsUsed + "Return a list of all fonts used currently in this text. 8/19/96 tk" + + ^ text runs values asSet collect: [:each | textStyle fontAt: each]!
Item was added: + ----- Method: DisplayText>>foregroundColor (in category 'color') ----- + foregroundColor + foreColor == nil ifTrue: [^ Color black]. + ^ foreColor!
Item was added: + ----- Method: DisplayText>>foregroundColor:backgroundColor: (in category 'color') ----- + foregroundColor: cf backgroundColor: cb + foreColor := cf. + backColor := cb!
Item was added: + ----- Method: DisplayText>>form (in category 'accessing') ----- + form + "Answer the form into which the receiver's display bits are cached." + + form == nil ifTrue: [self composeForm]. + ^form!
Item was added: + ----- Method: DisplayText>>lineGrid (in category 'accessing') ----- + lineGrid + "Answer the relative space between lines of the receiver's text." + + ^textStyle lineGrid!
Item was added: + ----- Method: DisplayText>>numberOfLines (in category 'accessing') ----- + numberOfLines + "Answer the number of lines of text in the receiver." + + ^self height // text lineGrid!
Item was added: + ----- Method: DisplayText>>offset (in category 'accessing') ----- + offset + "Refer to the comment in DisplayObject|offset." + + ^offset!
Item was added: + ----- Method: DisplayText>>offset: (in category 'accessing') ----- + offset: aPoint + "Refer to the comment in DisplayObject|offset:." + + offset := aPoint!
Item was added: + ----- Method: DisplayText>>setText:textStyle:offset: (in category 'private') ----- + setText: aText textStyle: aTextStyle offset: aPoint + + text := aText. + textStyle := aTextStyle. + offset := aPoint. + form := nil!
Item was added: + ----- Method: DisplayText>>string (in category 'accessing') ----- + string + "Answer the string of the characters displayed by the receiver." + + ^text string!
Item was added: + ----- Method: DisplayText>>text (in category 'accessing') ----- + text + "Answer the text displayed by the receiver." + + ^text!
Item was added: + ----- Method: DisplayText>>text: (in category 'accessing') ----- + text: aText + "Set the receiver to display the argument, aText." + + text := aText. + form := nil. + self changed. + !
Item was added: + ----- Method: DisplayText>>textStyle (in category 'accessing') ----- + textStyle + "Answer the style by which the receiver displays its text." + + ^textStyle!
Item was added: + ----- Method: DisplayText>>textStyle: (in category 'accessing') ----- + textStyle: aTextStyle + "Set the style by which the receiver should display its text." + + textStyle := aTextStyle. + form := nil. + self changed. + !
Item was added: + ----- Method: MenuMorph>>add:action: (in category '*VMMakerCompatibilityForPharo6-construction') ----- + add: aString action: aSymbolOrValuable + "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." + "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." + aSymbolOrValuable isSymbol + ifTrue: + [ self + add: aString + target: defaultTarget + selector: aSymbolOrValuable + argumentList: Array empty ] + ifFalse: + [ self + add: aString + target: aSymbolOrValuable + selector: #value + argumentList: Array empty ]!
Item was added: + ----- Method: MenuMorph>>add:target:action: (in category '*VMMakerCompatibilityForPharo6-construction') ----- + add: aString target: aTarget action: aSymbol + self + add: aString + target: aTarget + selector: aSymbol + argumentList: Array empty!
Item was added: + ----- Method: RBAssignmentNode>>anyReturns: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- + anyReturns: aSequenceOfNodes + aSequenceOfNodes do: + [:node| + node nodesDo: + [:n| + n isReturn ifTrue: + [^true]]]. + ^false!
Item was changed: ----- Method: RBAssignmentNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of me" | varNode valueNode | varNode := variable asTranslatorNodeIn: aTMethod. valueNode := value asTranslatorNodeIn: aTMethod. valueNode isStmtList ifFalse: [^TAssignmentNode new setVariable: varNode expression: valueNode; + comment: self missingCommentNeededForCTranslation]. - comment: comment]. "This is a super expansion. We are in trouble if any statement other than the last is a return." (self anyReturns: valueNode statements allButLast) ifTrue: [self error: 'haven''t implemented pushing down assignments into other than the last return']. "As of 6/25/2012 19:30 superExpansionNodeFor:args: elides the final return." self assert: valueNode statements last isReturn not. ^TStmtListNode new setStatements: valueNode statements allButLast, { TAssignmentNode new setVariable: varNode expression: valueNode statements last; + comment: self missingCommentNeededForCTranslation }; - comment: comment }; yourself!
Item was changed: ----- Method: RBBlockNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of me" | statementList | statementList := OrderedCollection new. body statements do: [:s | | newS | newS := s asTranslatorNodeIn: aTMethod. "inline the statement list returned when a CascadeNode is translated and/or when ifNotNil: is transformed" newS isStmtList ifTrue: [statementList addAll: newS statements] ifFalse: [statementList add: newS]]. ^TStmtListNode new + setArguments: (arguments asArray collect: [:arg | arg name]) - setArguments: (arguments asArray collect: [:arg | arg key]) statements: statementList; comment: self missingCommentNeededForCTranslation!
Item was changed: ----- Method: RBCascadeNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of me." ^TStmtListNode new setArguments: #() statements: (Array streamContents: [:s| | receiverNode | + receiverNode := messages first receiver asTranslatorNodeIn: aTMethod. - receiverNode := receiver asTranslatorNodeIn: aTMethod. "don't expand the receiver if it is a send to get an implicit receiver, e.g self interpreter printHex: oop => printHex(oop), /not/ printHex(cascade0,oop)." (receiverNode isSend and: [aTMethod definingClass isNonArgumentImplicitReceiverVariableName: receiverNode selector]) ifTrue: [receiverNode := TVariableNode new setName: receiverNode selector]. receiverNode isLeaf ifFalse: [| varNode | varNode := aTMethod newCascadeTempFor: receiverNode. s nextPut: (TAssignmentNode new setVariable: varNode expression: receiverNode). receiverNode := varNode]. messages do: [ :msg | s nextPut: ((msg asTranslatorNodeIn: aTMethod) receiver: receiverNode)]]); + comment: self missingCommentNeededForCTranslation! - comment: comment!
Item was changed: ----- Method: RBLiteralNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of me"
+ ^TConstantNode new setValue: self value! - ^TConstantNode new setValue: key!
Item was changed: ----- Method: RBMessageNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of me" "selector is sometimes a Symbol, sometimes a SelectorNode!! On top of this, numArgs is needed due to the (truly grody) use of arguments as a place to store the extra expressions needed to generate code for in-line to:by:do:, etc. see below, where it is used.
Expand super nodes in place. Elide sends of halt so that halts can be sprinkled through the simulator but will be eliminated from the generated C." | rcvrOrNil sel args ifNotNilBlock | rcvrOrNil := receiver ifNotNil: [receiver asTranslatorNodeIn: aTMethod]. (rcvrOrNil notNil and: [rcvrOrNil isVariable and: [rcvrOrNil name = 'super']]) ifTrue: [^aTMethod superExpansionNodeFor: selector key args: arguments]. sel := selector isSymbol ifTrue: [selector] ifFalse: [selector key]. sel == #halt ifTrue: [^rcvrOrNil]. (sel == #cCode:inSmalltalk: "extracting here rather than in translation allows inlining in the block." or: [sel == #cCode:]) ifTrue: [arguments first isBlockNode ifTrue: [| block | ^(block := arguments first asTranslatorNodeIn: aTMethod) statements size = 1 ifTrue: [block statements first] ifFalse: [block]]. (arguments first isLiteralNode + and: [arguments first value isString + and: [arguments first value isEmpty]]) ifTrue: - and: [arguments first key isString - and: [arguments first key isEmpty]]) ifTrue: [^arguments first asTranslatorNodeIn: aTMethod]]. args := arguments select: [:arg| arg notNil] thenCollect: [:arg| arg asTranslatorNodeIn: aTMethod]. + false ifTrue: + [(sel = #to:by:do: and: [arguments size = 7 and: [(arguments at: 7) notNil]]) ifTrue: - (sel = #to:by:do: and: [arguments size = 7 and: [(arguments at: 7) notNil]]) ifTrue: ["Restore limit expr that got moved by transformToDo:" args := {(arguments at: 7) value asTranslatorNodeIn: aTMethod. args second. args third. "add the limit var as a hidden extra argument; we may need it later" TVariableNode new setName: arguments first key}]. (sel == #ifTrue:ifFalse: and: [arguments first isNodeNil]) ifTrue: [sel := #ifFalse:. args := {args last}]. (sel == #ifTrue:ifFalse: and: [arguments last isNodeNil]) ifTrue: [sel := #ifTrue:. args := {args first}]. (sel == #ifFalse:ifTrue: and: [arguments first isNodeNil]) ifTrue: [sel := #ifTrue:. args := {args last}]. (sel == #ifFalse:ifTrue: and: [arguments last isNodeNil]) ifTrue: [sel := #ifTrue:. args := {args first}]. ((sel == #ifFalse: or: [sel == #or:]) and: [arguments size = 2 and: [(arguments at: 2) notNil]]) ifTrue: ["Restore argument block that got moved by transformOr: or transformIfFalse:" args := {(arguments at: 2) asTranslatorNodeIn: aTMethod}]. (args size > sel numArgs and: [sel ~~ #to:by:do:]) ifTrue: "to:by:do: has iLimiT hidden in last arg" ["prune the extra blocks left by ifTrue:, ifFalse:, and: & or:" self assert: args size - sel numArgs = 1. self assert: (args last isStmtList and: [args last statements size = 1 and: [(args last statements first isVariable or: [args last statements first isConstant]) and: [#('nil' true false) includes: args last statements first nameOrValue]]]). args := args first: sel numArgs]. "For the benefit of later passes, e.g. value: inlining, transform e ifNotNil: [:v| ...] into v := e. v ifNotNil: [...], which in fact means transforming (v := e) ifTrue: [:v|...] into v := e. v ifTrue: [...]." ((sel == #ifTrue: or: [sel == #ifFalse: or: [sel == #ifTrue:ifFalse: or: [sel == #ifFalse:ifTrue:]]]) and: [receiver notNil and: [receiver isAssignmentEqualsEqualsNil and: [(ifNotNilBlock := args detect: [:arg| arg isStmtList and: [arg args size = 1]] ifNone: []) notNil]]]) ifTrue: [ifNotNilBlock setArguments: #(). ^TStmtListNode new setArguments: #() statements: { receiver receiver asTranslatorNodeIn: aTMethod. TSendNode new setSelector: sel receiver: (TSendNode new setSelector: #== receiver: (receiver receiver variable asTranslatorNodeIn: aTMethod) arguments: {receiver arguments first asTranslatorNodeIn: aTMethod}) + arguments: args }]]. - arguments: args }]. ((CCodeGenerator isVarargsSelector: sel) and: [args last isCollection and: [args last isSequenceable]]) ifTrue: [args := args allButLast, args last]. ^TSendNode new setSelector: sel receiver: rcvrOrNil arguments: args!
Item was changed: ----- Method: RBMethodNode>>asTranslationMethodOfClass: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslationMethodOfClass: aTMethodClass "Answer a TMethod (or subclass) derived from the receiver." ^aTMethodClass new setSelector: selector + definingClass: scope instanceScope outerScope getClass - definingClass: scope instanceScope outerScope class args: arguments locals: ((self allDefinedVariables copyWithoutAll: arguments) collect: [:string| string -> string]) block: body primitive: ((pragmas ifNotNil: [pragmas detect: [:pragmaNode| pragmaNode selector beginsWith: #primitve:] ifNone: []]) ifNil: [0] ifNotNil: [:pragmaNode| pragmaNode arguments first value]) properties: (properties ifNil: [AdditionalMethodState new]) comment: self missingCommentNeededForCTranslation!
Item was changed: ----- Method: RBReturnNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of a return." | exprTranslation lastExpr | + exprTranslation := value asTranslatorNodeIn: aTMethod. + (value isMessage + and: [value receiver isVariable + and: [value receiver name = 'super' - exprTranslation := expr asTranslatorNodeIn: aTMethod. - (expr isMessage - and: [expr receiver isVariableNode - and: [expr receiver key = 'super' and: [exprTranslation isStmtList]]]) ifTrue: ["super expansions containing returns are fine, and (as of 6/25/2012 19:27) the last return is elided from the expansion by TMethod>>superExpansionNodeFor:args:. So we need to ensure the last expression is a return and simply reuse any other returns in the expansion." lastExpr := exprTranslation statements last. (lastExpr isReturn or: [lastExpr isReturningIf]) ifFalse: [exprTranslation statements at: exprTranslation statements size put: (TReturnNode new setExpression: lastExpr; + comment: self missingCommentNeededForCTranslation; - comment: comment; yourself)]. ^exprTranslation]. ^TReturnNode new setExpression: exprTranslation; + comment: self missingCommentNeededForCTranslation; - comment: comment; yourself!
Item was changed: ----- Method: RBSequenceNode>>asTranslatorNodeIn: (in category '*VMMakerCompatibilityForPharo6-C translation') ----- asTranslatorNodeIn: aTMethod "Answer a TParseNode subclass equivalent of me" | statementList | statementList := OrderedCollection new. statements do: [:s | | newS | newS := s asTranslatorNodeIn: aTMethod. "inline the statement list returned when a CascadeNode is translated and/or when ifNotNil: is transformed" newS isStmtList ifTrue: [statementList addAll: newS statements] ifFalse: [statementList add: newS]]. ^TStmtListNode new + setArguments: (parent arguments asArray collect: [:arg | arg name]) - setArguments: (parent arguments asArray collect: [:arg | arg key]) statements: statementList; comment: self missingCommentNeededForCTranslation!
Item was added: + ----- Method: String>>asDisplayText (in category '*VMMakerCompatibilityForPharo6-converting') ----- + asDisplayText + "Answer a DisplayText whose text string is the receiver." + + ^DisplayText text: self asText!
Item was added: + WriteStream subclass: #TranscriptStream + instanceVariableNames: 'lastChar' + classVariableNames: 'AccessSema CharacterLimit ForceUpdate RedirectToStdOut' + poolDictionaries: '' + category: 'VMMakerCompatibilityForPharo6'! + + !TranscriptStream commentStamp: 'fbs 12/30/2013 09:53' prior: 0! + This class is a much simpler implementation of Transcript protocol that supports multiple views and very simple conversion to morphic. Because it inherits from Stream, it is automatically compatible with code that is designed to write to streams.!
Item was added: + ----- Method: TranscriptStream class>>characterLimit (in category 'preferences') ----- + characterLimit + <preference: 'Maximum number of characters in a transcript' + categoryList: #(printing morphic debug) + description: 'When the number of characters in a transcript exceeds this limit, characters at the start of the text are discarded.' + type: #Number> + ^CharacterLimit ifNil: [20000]!
Item was added: + ----- Method: TranscriptStream class>>characterLimit: (in category 'preferences') ----- + characterLimit: anInteger + + CharacterLimit := anInteger.!
Item was added: + ----- Method: TranscriptStream class>>forceUpdate (in category 'preferences') ----- + forceUpdate + + <preference: 'Force transcript updates to screen' + categoryList: #(printing morphic debug) + description: 'When enabled, transcript updates will immediately shown in the screen no matter how busy the UI process is.' + type: #Boolean> + ^ ForceUpdate ifNil: [true]!
Item was added: + ----- Method: TranscriptStream class>>forceUpdate: (in category 'preferences') ----- + forceUpdate: aBoolean + + ForceUpdate := aBoolean.!
Item was added: + ----- Method: TranscriptStream class>>initialize (in category 'class initialization') ----- + initialize + + self registerInFlapsRegistry. !
Item was added: + ----- Method: TranscriptStream class>>new (in category 'instance creation') ----- + new + ^ self on: (String new: 1000) + " + INSTALLING: + TextCollector allInstances do: + [:t | t breakDependents. + t become: TranscriptStream new]. + + TESTING: (Execute this text in a workspace) + Do this first... + tt := TranscriptStream new. + tt openLabel: 'Transcript test 1'. + Then this will open a second view -- ooooh... + tt openLabel: 'Transcript test 2'. + And finally make them do something... + tt clear. + [Sensor anyButtonPressed] whileFalse: + [1 to: 20 do: [:i | tt print: (2 raisedTo: i-1); cr; endEntry]]. + "!
Item was added: + ----- Method: TranscriptStream class>>newTranscript: (in category 'instance creation') ----- + newTranscript: aTextCollector + "Store aTextCollector as the value of the system global Transcript." + Smalltalk at: #Transcript put: aTextCollector!
Item was added: + ----- Method: TranscriptStream class>>redirectToStdOut (in category 'preferences') ----- + redirectToStdOut + <preference: 'Redirect transcript to stdout' + categoryList: #(printing morphic debug) + description: 'When enabled, anything sent to the transcript will be redirected to the stdout stream and (hopefully) the OS terminal.' + type: #Boolean> + ^ RedirectToStdOut ifNil: [false]!
Item was added: + ----- Method: TranscriptStream class>>redirectToStdOut: (in category 'preferences') ----- + redirectToStdOut: aBoolean + "In setting up redirection, first remove all dependents that are stdout, + which may include stale files from the last session. Then add a dependency + only if asked to redirect to stdout. Blithely doing + Transcript removeDependent: FileStream stdout + raises an error if stdout is unavailable." + Transcript dependents do: + [:dep| + (dep isStream and: [dep name = #stdout]) ifTrue: + [Transcript removeDependent: dep]]. + (RedirectToStdOut := aBoolean) ifTrue: + [Transcript addDependent: FileStream stdout]!
Item was added: + ----- Method: TranscriptStream class>>registerInFlapsRegistry (in category 'class initialization') ----- + registerInFlapsRegistry + "Register the receiver in the system's flaps registry" + self environment + at: #Flaps + ifPresent: [:cl | cl registerQuad: {#TranscriptStream. #openMorphicTranscript. 'Transcript' translatedNoop. 'A Transcript is a window usable for logging and debugging; browse references to #Transcript for examples of how to write to it.' translatedNoop} + forFlapNamed: 'Tools'] + !
Item was added: + ----- Method: TranscriptStream class>>themeProperties (in category 'preferences') ----- + themeProperties + + ^ Model themeProperties!
Item was added: + ----- Method: TranscriptStream class>>unload (in category 'class initialization') ----- + unload + "Unload the receiver from global registries" + + self environment at: #Flaps ifPresent: [:cl | + cl unregisterQuadsWithReceiver: self] !
Item was added: + ----- Method: TranscriptStream>>applyUserInterfaceTheme (in category 'model protocol') ----- + applyUserInterfaceTheme + + self dependents do: [:ea | + ea isSystemWindow ifTrue: [ + ea refreshWindowColor]].!
Item was added: + ----- Method: TranscriptStream>>bs (in category 'stream extensions') ----- + bs + self position > 0 ifTrue: [^ self skip: -1]. + self changed: #bs!
Item was added: + ----- Method: TranscriptStream>>characterLimit (in category 'accessing') ----- + characterLimit + "Tell the views how much to retain on screen" + ^self class characterLimit!
Item was added: + ----- Method: TranscriptStream>>clear (in category 'stream extensions') ----- + clear + "Clear all characters and redisplay the view" + self changed: #clearText. + self reset!
Item was added: + ----- Method: TranscriptStream>>closeAllViews (in category 'initialization') ----- + closeAllViews + "Transcript closeAllViews" + + self changed: #close + !
Item was added: + ----- Method: TranscriptStream>>contents (in category 'accessing') ----- + contents + "Override to update lastChar." + position > 0 ifTrue: + [lastChar := collection at: position]. + ^super contents!
Item was added: + ----- Method: TranscriptStream>>countOpenTranscripts (in category 'private') ----- + countOpenTranscripts + "Transcript countOpenTranscripts" + + ^ (self dependents select: [:e | e isTextView]) size + !
Item was added: + ----- Method: TranscriptStream>>endEntry (in category 'stream extensions') ----- + endEntry + "Display all the characters since the last endEntry, and reset the stream" + self semaphore critical:[ + self class forceUpdate + ifTrue: [self changed: #appendEntry] + ifFalse: [self changed: #appendEntryLater]. + self reset. + ].!
Item was added: + ----- Method: TranscriptStream>>flush (in category 'stream extensions') ----- + flush + self endEntry + !
Item was added: + ----- Method: TranscriptStream>>nextPut: (in category 'stream extensions') ----- + nextPut: anObject + self target == self ifFalse: [self target nextPut: anObject]. "delegated to stdout" + ^ super nextPut: anObject.!
Item was added: + ----- Method: TranscriptStream>>nextPutAll: (in category 'stream extensions') ----- + nextPutAll: aCollection + self target == self ifFalse: [self target nextPutAll: aCollection]. "delegated to stdout" + ^ super nextPutAll: aCollection.!
Item was added: + ----- Method: TranscriptStream>>pastEndPut: (in category 'stream extensions') ----- + pastEndPut: anObject + "If the stream reaches its limit, just output the contents and reset." + self endEntry. + ^ self nextPut: anObject!
Item was added: + ----- Method: TranscriptStream>>peekLast (in category 'character writing') ----- + peekLast + "Return that item just put at the end of the stream" + + ^ position > 0 + ifTrue: [collection at: position] + ifFalse: [lastChar]!
Item was added: + ----- Method: TranscriptStream>>perform:orSendTo: (in category 'model protocol') ----- + perform: selector orSendTo: otherTarget + "Selector was just chosen from a menu by a user. If can respond, then + perform it on myself. If not, send it to otherTarget, presumably the + editPane from which the menu was invoked." + + (self respondsTo: selector) + ifTrue: [^ self perform: selector] + ifFalse: [^ otherTarget perform: selector]!
Item was added: + ----- Method: TranscriptStream>>release (in category 'model protocol') ----- + release + + self dependents do: + [:view | (view isMorph and: [view isInWorld not]) + ifTrue: [self removeDependent: view]]!
Item was added: + ----- Method: TranscriptStream>>reset (in category 'positioning') ----- + reset + "Override to set lastChar" + position > 0 ifTrue: + [lastChar := collection at: position]. + ^super reset!
Item was added: + ----- Method: TranscriptStream>>semaphore (in category 'private') ----- + semaphore + ^AccessSema ifNil:[AccessSema := Semaphore forMutualExclusion]!
Item was added: + ----- Method: TranscriptStream>>show: (in category 'stream extensions') ----- + show: anObject + "TextCollector compatibility" + + [ + self nextPutAll: anObject asString. + self endEntry + ] on: FileWriteError do: [self class redirectToStdOut: false].!
Item was added: + ----- Method: TranscriptStream>>showln: (in category 'stream extensions') ----- + showln: anObject + "TextCollector compatibility. Ensure a new line before inserting a message." + + [ + self + cr; + nextPutAll: anObject asString. + self endEntry. + ] on: FileWriteError do: [self class redirectToStdOut: false].!
Item was added: + ----- Method: TranscriptStream>>step (in category 'model protocol') ----- + step + "Objects that may be models of SystemWindows need to respond to this, albeit vacuously"!
Item was added: + ----- Method: TranscriptStream>>target (in category 'stream extensions') ----- + target + + ^ self class redirectToStdOut + ifTrue: [FileStream stdout] + ifFalse: [self]!
Item was added: + ----- Method: TranscriptStream>>windowActiveOnFirstClick (in category 'model protocol') ----- + windowActiveOnFirstClick + + ^ Model windowActiveOnFirstClick!
Item was added: + ----- Method: TranscriptStream>>windowColorToUse (in category 'model protocol') ----- + windowColorToUse + + ^ Color colorFrom: (Model useColorfulWindows + ifTrue: [self userInterfaceTheme customWindowColor ifNil: [Color r: 0.9 g: 0.75 b: 0.45]] + ifFalse: [self userInterfaceTheme uniformWindowColor ifNil: [Color veryVeryLightGray]])!