home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / OOP / STIX.TAR / stix / CFuncs.st < prev    next >
Encoding:
Text File  |  1991-09-13  |  8.7 KB  |  371 lines
  1. "======================================================================
  2. |
  3. |   SystemDictionary Method Definitions
  4. |
  5.  ======================================================================"
  6.  
  7.  
  8. "======================================================================
  9. |
  10. | Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  11. | Written by Steve Byrne.
  12. |
  13. | This file is part of GNU Smalltalk.
  14. |
  15. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  16. | under the terms of the GNU General Public License as published by the Free
  17. | Software Foundation; either version 1, or (at your option) any later version.
  18. | 
  19. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  20. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  21. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  22. | details.
  23. | 
  24. | You should have received a copy of the GNU General Public License along with
  25. | GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
  26. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  27. |
  28.  ======================================================================"
  29.  
  30.  
  31. "
  32. |     Change Log
  33. | ============================================================================
  34. | Author       Date       Change 
  35. | sbyrne      8 Jul 89      Created.
  36. |
  37. "
  38.  
  39. Object variableSubclass: #CFunctionDescriptor
  40.        instanceVariableNames: 'cFunction cFunctionName returnType numFixedArgs'
  41.        classVariableNames: ''
  42.        poolDictionaries: ''
  43.        category: nil !
  44.  
  45. CFunctionDescriptor comment: 
  46. 'I am not part of the Smalltalk definition.  My instances contain information
  47. about C functions that can be called from within Smalltalk, such as number
  48. and type of parameters.  This information is used by the C callout mechanism
  49. to perform the actual call-out to C routines.' !
  50.  
  51.  
  52. "A couple of simple, but useful callout functions, as examples."
  53.  
  54. Behavior defineCFunc: 'system'
  55.          withSelectorArgs: 'system: aString'
  56.      forClass: SystemDictionary
  57.      returning: #int
  58.      args: #(string)!
  59.  
  60. Behavior defineCFunc: 'getenv'
  61.          withSelectorArgs: 'getenv: aString'
  62.      forClass: SystemDictionary
  63.      returning: #string
  64.      args: #(string)!
  65.  
  66.  
  67. Smalltalk at: #XGlobals put: (Dictionary new)!
  68. XGlobals at: #Registry put: (Dictionary new)!
  69.  
  70. FileStream fileIn: 'X.st'.
  71. FileStream fileIn: 'XPacket.st'!
  72.  
  73.  
  74.  
  75. Object subclass: #Display
  76.        instanceVariableNames: 'socket majorVersion minorVersion releaseNum resourceIdBase
  77.                                resourceIdMask motionBufferSize maxRequestLen imageByteOrder
  78.                                bitmapBitOrder bitmapFormatScanUnit bitmapFormatScanPad 
  79.                                minKeycode maxKeycode vendorName formats screens idCounter'
  80.        classVariableNames: ''
  81.        poolDictionaries: ''
  82.        category: 'X hacking'
  83. !
  84.  
  85. Object subclass: #Format
  86.        instanceVariableNames: 'depth bitsPerPixel scanlinePad'
  87.        classVariableNames: ''
  88.        poolDictionaries: ''
  89.        category: 'X hacking'
  90. !
  91.  
  92. Object subclass: #Screen
  93.        instanceVariableNames: 'window defaultColormap whitePixel blackPixel
  94.                                currentInputMasks widthPixels heightPixels
  95.                                widthMM heightMM minInstalledMaps maxInstalledMaps
  96.                                rootVisual backingStores saveUnders rootDepth
  97.                                depths'
  98.        classVariableNames: ''
  99.        poolDictionaries: ''
  100.        category: 'X hacking'
  101. !
  102.  
  103. Object subclass: #Depth
  104.        instanceVariableNames: 'depth visuals'
  105.        classVariableNames: ''
  106.        poolDictionaries: ''
  107.        category: 'X hacking'
  108. !
  109.  
  110. Object subclass: #VisualType
  111.        instanceVariableNames: 'visualId class bitsPerRGB colormapEntries 
  112.                                redMask greenMask blueMask'
  113.        classVariableNames: ''
  114.        poolDictionaries: ''
  115.        category: 'X hacking'
  116. !
  117.  
  118.  
  119.  
  120. !Display class methodsFor: 'instance creation'!
  121.  
  122. host: hostName display: anInteger
  123.     | xStream result |
  124.     xStream _ X connectTo: hostName display: anInteger.
  125.  
  126.     xStream char: (Bigendian ifTrue: [ $B ] ifFalse: [ $l ]).
  127.     xStream byte: 0.
  128.     
  129.     xStream word: 11.
  130.     xStream word: 0.
  131.     xStream word: 0.        "length of auth string"
  132.     xStream word: 0.        "length of auth data"
  133.     xStream word: 0.        "unused"
  134.     
  135.     xStream byte == 1        "succeeded?"
  136.     ifTrue: [ xStream byte.    "unused here "
  137.           ^self new: xStream ]
  138.     ifFalse: [ ^nil ]    "maybe issue an error?"
  139. !
  140.  
  141. new: fromStream
  142.     ^self new init: fromStream
  143. !!
  144.  
  145.  
  146. !Display methodsFor: 'accessing'!
  147.  
  148. socket
  149.     ^socket
  150. !
  151.  
  152. nextId
  153.     | id |
  154.     id _ resourceIdBase bitOr: (idCounter bitAnd:  resourceIdMask).
  155.     idCounter _ idCounter + 1.
  156.     ^id
  157. !!
  158.  
  159.  
  160. !Display methodsFor: 'private'!
  161.  
  162. init: xStream
  163.     | vendorLen numScreens numFormats |
  164.  
  165.     idCounter _ 0.
  166.  
  167.     socket _ xStream.
  168.  
  169.     majorVersion _ socket uword.
  170.     minorVersion _ socket uword.
  171.     socket uword.        "skip length"
  172.  
  173.     releaseNum _ socket ulong.
  174.     resourceIdBase _ socket ulong.
  175.     BaseId _ resourceIdBase.
  176.     resourceIdMask _ socket ulong.
  177.     BaseMask _ resourceIdMask.
  178.  
  179.     motionBufferSize _ socket ulong.
  180.     vendorLen _ socket uword.
  181.     maxRequestLen _ socket uword.
  182.     numScreens _ socket ubyte.
  183.     numFormats _ socket ubyte.
  184.  
  185.     imageByteOrder _ socket byte.
  186.     bitmapBitOrder _ socket byte.
  187.     bitmapFormatScanUnit _ socket ubyte.
  188.     bitmapFormatScanPad _ socket ubyte.
  189.     minKeycode _ socket ubyte.
  190.     maxKeycode _ socket ubyte.
  191.     socket long.            "ignored "
  192.     
  193.     vendorName _ socket getString: vendorLen.    
  194.  
  195.     formats _ Array new: numFormats.
  196.     screens _ Array new: numScreens.
  197.  
  198.     1 to: numFormats do: 
  199.     [ :i | formats at: i put: (Format new: socket) ].
  200.     1 to: numScreens do: 
  201.     [ :i | screens at: i put: (Screen new: socket) ]
  202. !!
  203.  
  204.  
  205. !Format class methodsFor: 'instance creation'!
  206.  
  207. new: xStream
  208.     ^self new init: xStream
  209. !!
  210.  
  211. !Format methodsFor: 'private'!
  212.  
  213. init: socket
  214.     depth _ socket ubyte.
  215.     bitsPerPixel _ socket ubyte.
  216.     scanlinePad _ socket ubyte.
  217.     5 timesRepeat: [ socket ubyte ] "skip trailing junk"
  218. !!
  219.  
  220.  
  221. !Screen class methodsFor: 'instance creation'!
  222.  
  223. new: xStream
  224.     ^self new init: xStream
  225. !!
  226.  
  227. !Screen methodsFor: 'private'!
  228.  
  229. init: socket
  230.     | depthsAllowed |
  231.  
  232.     window _ socket ulong.
  233.     RootWindowID isNil
  234.     ifTrue: [ RootWindowID _ window ]. "only want first one"
  235.     defaultColormap _ socket ulong.
  236.     whitePixel _ socket ulong.
  237.     blackPixel _ socket ulong.
  238.  
  239. WhitePixel _ whitePixel.
  240. BlackPixel _ blackPixel.
  241.  
  242.     currentInputMasks _ socket ulong.
  243.     widthPixels _ socket uword.
  244.     heightPixels _ socket uword.
  245.     widthMM _ socket uword.
  246.     heightMM _ socket uword.
  247.  
  248.     minInstalledMaps _ socket uword.
  249.     maxInstalledMaps _ socket uword.
  250.     rootVisual _ socket ulong.
  251.     backingStores _ socket byte.
  252.  
  253.     saveUnders _ socket byte.
  254.     rootDepth _ socket byte.
  255.     depthsAllowed _ socket byte.
  256.  
  257.     depths _ Array new: depthsAllowed.
  258.     
  259.     1 to: depthsAllowed do:
  260.     [ :i | depths at: i put: (Depth new: socket) ]
  261. !!
  262.  
  263.  
  264. !Depth class methodsFor: 'instance creation'!
  265.  
  266. new: xStream
  267.     ^self new init: xStream
  268. !!
  269.  
  270.  
  271. !Depth methodsFor: 'private'!
  272.  
  273. init: socket
  274.     | numVisuals |
  275.     depth _ socket byte.
  276.  
  277.     socket byte.        " ignore "
  278.     numVisuals _ socket word.
  279.     socket long.        " pad "
  280.     
  281.     visuals _ Array new: numVisuals.
  282.  
  283.     1 to: numVisuals do:
  284.     [ :i | visuals at: i put: (VisualType new: socket) ]
  285. !!
  286.  
  287.  
  288.  
  289.  
  290. !VisualType class methodsFor: 'instance creation'!
  291.  
  292. new: xStream
  293.     ^self new init: xStream
  294. !!
  295.  
  296.  
  297. !VisualType methodsFor: 'accessing'!
  298.  
  299. id
  300.     ^visualId
  301. !!
  302.  
  303.  
  304. !VisualType methodsFor: 'private'!
  305.  
  306. init: socket
  307.     | visualId class bitsPerRGB colormapEntries redMask greenMask blueMask |
  308.  
  309.     visualId _ socket long.
  310.  
  311. VisualId isNil
  312.     ifTrue: [ VisualId _ visualId ]. "pick up first (bw)"
  313.  
  314.     class _ socket byte.
  315.   
  316. "(#(StaticGray GrayScale StaticColor PseudoColor TrueColor DirectColor)
  317.    at: class + 1) bugOut: 'Display type: '."
  318.  
  319.     bitsPerRGB _ socket byte.
  320.  
  321.     colormapEntries _ socket word.
  322.  
  323.     redMask _ socket long.
  324.     greenMask _ socket long.
  325.     blueMask _ socket long.
  326.  
  327.     socket long            " ignored "
  328. !!
  329.  
  330.  
  331.  
  332. FileStream fileIn: 'Point.st'!
  333. FileStream fileIn: 'Rectangle.st'!
  334.  
  335. FileStream fileIn: 'error.st'!
  336. FileStream fileIn: 'event.st'!
  337.  
  338. FileStream fileIn: 'Atom.st'!
  339.  
  340. FileStream fileIn: 'TextItem.st'!
  341.  
  342. !X methodsFor: 'reading'!
  343.  
  344. getPacket
  345.     | type err |
  346.     type _ self byte.
  347.     type == 0 ifTrue: [ err _ XError newFrom: self.
  348.             err inspect.
  349.             ^nil ].
  350.     type > 1 ifTrue: [ ^XEvent newFrom: self type: type ]
  351. !
  352.  
  353. getReply
  354.     | err |
  355.     (self byte) == 0
  356.     ifTrue: [ err _ XError newFrom: self.
  357.           err inspect.
  358.           ^false ].
  359.     self byte.            "skip the unused reply value"
  360.     self word.            "skip the sequence number"
  361.     self long.            "skip the length"
  362.     ^true
  363. !!
  364.  
  365. FileStream fileIn: 'Arc.st'!
  366. FileStream fileIn: 'Drawable.st'!
  367. FileStream fileIn: 'GC.st'!
  368. FileStream fileIn: 'Window.st'!
  369. FileStream fileIn: 'Pixmap.st'!
  370. FileStream fileIn: 'Pen.st'!
  371.