view modules/freetype.tp @ 331:61f5b794d939

Breaking change: method call syntax now always uses the syntactic receiver as the actual receiver. This makes its behavior different from function call syntax, but solves some problems with methods being shadowed by local variables and the like.
author Michael Pavone <pavone@retrodev.com>
date Sat, 28 Mar 2015 14:21:04 -0700
parents c1fad3d93861
children
line wrap: on
line source

{
	_helper <- #{
		includeSystemHeader: "ft2build.h"
		includeSystemHeader: FT_FREETYPE_H
		llMessage: newFace withVars: {
			libOpaque <- cpointer ptr
			opath <- object ptr
			oindex <- object ptr
			path <- string ptr
			index <- obj_int32 ptr
			faceOpaque <- cpointer ptr
			rescode <- int32_t
		} andCode: :libOpaque opath oindex {
			path <- (mcall: string 1 opath) castTo: (string ptr)
			index <- (mcall: int32 1 oindex) castTo: (obj_int32 ptr)
			faceOpaque <- make_object: (addr_of: cpointer_meta) NULL 0
			rescode <- FT_New_Face: (libOpaque val) (path data) (index num) ((addr_of: (faceOpaque val)) castTo: (FT_Face ptr))
			if: rescode = 0 {
				mcall: value 2 option faceOpaque
			} else: {
				mcall: none 1 option
			}
		}
		
		llMessage: getFirstChar withVars: {
			opaque <- cpointer ptr
			glyphIndex <- obj_uint32 ptr
			charCode <- obj_uint32 ptr
			makeChar <- lambda ptr
		} andCode: :opaque makeChar {
			glyphIndex <- make_object: (addr_of: obj_uint32_meta) NULL 0
			charCode <- make_object: (addr_of: obj_uint32_meta) NULL 0
			charCode num!: (FT_Get_First_Char: (opaque val) (addr_of: (glyphIndex num)))
			ccall: makeChar 2 charCode glyphIndex
		}
		
		llMessage: getNextChar withVars: {
			opaque <- cpointer ptr
			ocurChar <- object ptr
			curChar <- obj_uint32 ptr
			glyphIndex <- obj_uint32 ptr
			charCode <- obj_uint32 ptr
			makeChar <- lambda ptr
		} andCode: :opaque ocurChar makeChar {
			curChar <- (mcall: uint32 1 ocurChar) castTo: (obj_uint32 ptr)
			glyphIndex <- make_object: (addr_of: obj_uint32_meta) NULL 0
			charCode <- make_object: (addr_of: obj_uint32_meta) NULL 0
			charCode num!: (FT_Get_Next_Char: (opaque val) (curChar num) (addr_of: (glyphIndex num)))
			ccall: makeChar 2 charCode glyphIndex
		}
	}
	
	_makeSlot <- :opaque {
		#{
			llProperty: slot withType: FT_GlyphSlot
			llMessage: _ptr_init withVars: {
				opaque <- cpointer ptr
			} andCode: :opaque {
				slot <- opaque val
				self
			}
			
			llMessage: linearHoriAdvance withVars: {
				intret <- obj_int32 ptr
			} andCode: {
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (slot linearHoriAdvance)
				intret
			}
			
			llMessage: linearVertAdvance withVars: {
				intret <- obj_int32 ptr
			} andCode: {
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (slot linearVertAdvance)
				intret
			}
			
			llMessage: bitmapTop withVars: {
				intret <- obj_int32 ptr
			} andCode: {
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (slot bitmap_top)
				intret
			}
			
			llMessage: bitmapLeft withVars: {
				intret <- obj_int32 ptr
			} andCode: {
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (slot bitmap_left)
				intret
			}
			
			llMessage: bitmapRows withVars: {
				uintret <- obj_uint32 ptr
			} andCode: {
				uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
				uintret num!: ((addr_of: (slot bitmap)) rows)
				uintret
			}
			
			llMessage: bitmapWidth withVars: {
				uintret <- obj_uint32 ptr
			} andCode: {
				uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
				uintret num!: ((addr_of: (slot bitmap)) width)
				uintret
			}
			
			llMessage: bitmapPitch withVars: {
				intret <- obj_int32 ptr
			} andCode: {
				intret <- make_object: (addr_of: obj_uint32_meta) NULL 0
				intret num!: ((addr_of: (slot bitmap)) pitch)
				intret
			}
			
			llMessage: bitmapData withVars: {
				opaque <- cpointer ptr
				size <- obj_int32 ptr
			} andCode: {
				opaque <- make_object: (addr_of: cpointer_meta) NULL 0
				opaque val!: ((addr_of: (slot bitmap)) buffer)
				size <- make_object: (addr_of: obj_int32_meta) NULL 0
				size num!: ((addr_of: (slot bitmap)) rows) * ((addr_of: (slot bitmap)) pitch)
				mcall: fromOpaque:withSize 3 bytearray opaque size
			}
			
			llMessage: renderGlyph withVars: {
				omode <- object ptr
				mode <- obj_uint32 ptr
				intret <- obj_int32 ptr
			} andCode: :omode {
				mode <- (mcall: uint32 1 omode) castTo: (obj_uint32 ptr)
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (FT_Render_Glyph: slot (mode num))
				intret
			}
		} _ptr_init: opaque
	}
	
	_makeChar <- :_charcode _glyph {
		#{
			charcode <- _charcode
			glyph <- _glyph
		}
	}
	_makeFace <- :opaque {
		#{
			llProperty: face withType: FT_Face
			llProperty: makeSlot withType: (lambda ptr)
			llMessage: _ptr_init withVars: {
				opaque <- cpointer ptr
				makeSlotLambda <- lambda ptr
			} andCode: :opaque makeSlotLambda {
				face <- opaque val
				makeSlot <- makeSlotLambda
				self
			}
			
			llMessage: faceOpaque withVars: {
				opaque <- cpointer ptr
			} andCode: {
				opaque <- make_object: (addr_of: cpointer_meta) NULL 0
				opaque val!: face
				opaque
			}
			
			llMessage: setCharWidth:height:hRes:vRes withVars: {
				ohsize <- object ptr
				hsize <- obj_float32 ptr
				ovsize <- object ptr
				vsize <- obj_float32 ptr
				ohres <- object ptr
				hres <- obj_int32 ptr
				ovres <- object ptr
				vres <- obj_int32 ptr
				intret <- obj_int32 ptr
			} andCode: :ohsize ovsize :ohres :ovres {
				hsize <- (mcall: f32 1 ohsize) castTo: (obj_float32 ptr)
				vsize <- (mcall: f32 1 ovsize) castTo: (obj_float32 ptr)
				hres <- (mcall: int32 1 ohres) castTo: (obj_int32 ptr)
				vres <- (mcall: int32 1 ovres) castTo: (obj_int32 ptr)
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (FT_Set_Char_Size: face (hsize num) * 64 (vsize num) * 64 (hres num) (vres num))
				intret
			}
			
			setCharSize:res <- :size :res {
				setCharWidth: size height: size hRes: res vRes: res
			}
			
			llMessage: getCharIndex withVars: {
				ocharcode <- object ptr
				charcode <- obj_uint32 ptr
				uintret <- obj_uint32 ptr
			} andCode: :ocharcode {
				charcode <- (mcall: uint32 1 ocharcode) castTo: (obj_uint32 ptr)
				uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
				uintret num!: (FT_Get_Char_Index: face (charcode num))
				uintret
			}
			
			llMessage: loadGlyph:flags withVars: {
				oindex <- object ptr
				index <- obj_uint32 ptr
				oflags <- object ptr
				flags <- obj_uint32 ptr
				intret <- obj_int32 ptr
			} andCode: :oindex :oflags {
				index <- (mcall: uint32 1 oindex) castTo: (obj_uint32 ptr)
				flags <- (mcall: uint32 1 oflags) castTo: (obj_uint32 ptr)
				intret <- make_object: (addr_of: obj_int32_meta) NULL 0
				intret num!: (FT_Load_Glyph: face (index num) (flags num))
				intret
			}
			
			llMessage: glyphSlot withVars: {
				opaque <- cpointer ptr
			} andCode: {
				opaque <- make_object: (addr_of: cpointer_meta) NULL 0
				opaque val!: (face glyph)
				ccall: makeSlot 1 opaque
			}
			
			llMessage: unitsPerEm withVars: {
				u16ret <- obj_uint16 ptr
			} andCode: {
				u16ret <- make_object: (addr_of: obj_uint16_meta) NULL 0
				u16ret num!: (face units_per_EM)
				u16ret
			}
			
			llMessage: hasKerning? withVars: {
				ret <- object ptr
			} andCode: {
				if: (FT_HAS_KERNING: face) {
					true
				} else {
					false
				}
			}
			
			llMessage: getKerning:mode withVars: {
				oleft <- object ptr
				oright <- object ptr
				omode <- object ptr
				left <- obj_uint32 ptr
				right <- obj_uint32 ptr
				mode <- obj_uint32 ptr
				x <- obj_int32 ptr
				y <- obj_int32 ptr
				ret <- object ptr
				kernVec <- FT_Vector
				err <- int
			} andCode: :oleft oright :omode {
				left <- (mcall: uint32 1 oleft) castTo: (obj_uint32 ptr)
				right <- (mcall: uint32 1 oright) castTo: (obj_uint32 ptr)
				mode <- (mcall: uint32 1 omode) castTo: (obj_uint32 ptr)
				err <- FT_Get_Kerning: face (left num) (right num) (mode num) (addr_of: kernVec)
				if: err != 0 {
					mcall: none 1 option
				} else: {
					x <- make_object: (addr_of: obj_int32_meta) NULL 0
					y <- make_object: (addr_of: obj_int32_meta) NULL 0
					x num!: ((addr_of: kernVec) x)
					y num!: ((addr_of: kernVec) y)
					ret <- mcall: x:y 3 vec x y
					mcall: value 2 option ret
				}
			}
			
			firstChar <- {
				_helper getFirstChar: faceOpaque _makeChar
			}
			
			nextChar <- :curChar {
				_helper getNextChar: faceOpaque curChar _makeChar
			}
			
			charmap <- {
				d <- dict hash
				char <- firstChar
				d set: (char charcode) (char glyph)
				while: { (char glyph) != 0u32 } do: {
					char <- nextChar: (char charcode)
					d set: (char charcode) (char glyph)
				}
				d
			}
		} _ptr_init: opaque _makeSlot
	}
	
	_constant <- macro: :name cname {
		quote: (llMessage: name withVars: {
			uintret <- obj_uint32 ptr
		} andCode: {
			uintret <- make_object: (addr_of: obj_uint32_meta) NULL 0
			uintret num!: cname
			uintret
		})
	}
	
	_loadFlags <- #{
		_constant: default FT_LOAD_DEFAULT
		_constant: noScale FT_LOAD_NO_SCALE
		_constant: noHinting FT_LOAD_NO_HINTING
		_constant: render FT_LOAD_RENDER
		_constant: noBitmap FT_LOAD_NO_BITMAP
		_constant: verticalLayout FT_LOAD_VERTICAL_LAYOUT
		_constant: forceAuthohint FT_LOAD_FORCE_AUTOHINT
		_constant: pedantic FT_LOAD_PEDANTIC
		_constant: noRecurse FT_LOAD_NO_RECURSE
		_constant: ignoreTransform FT_LOAD_IGNORE_TRANSFORM
		_constant: monochrome FT_LOAD_MONOCHROME
		_constant: linearDesign FT_LOAD_LINEAR_DESIGN
		_constant: noAutohint FT_LOAD_NO_AUTOHINT
		_constant: color FT_LOAD_COLOR
	}
	
	_kerning <- #{
		_constant: default FT_KERNING_DEFAULT
		_constant: unfitted FT_KERNING_UNFITTED
		_constant: unscaled FT_KERNING_UNSCALED
	}
	
	#{
		init <- {
			
			#{
				includeSystemHeader: "ft2build.h"
				includeSystemHeader: FT_FREETYPE_H
				llProperty: library withType: FT_Library
				
				llMessage: _init withVars: {
				} andCode: {
					FT_Init_FreeType: (addr_of: library)
					self
				}
				
				llMessage: libraryOpaque withVars: {
					libOpaque <- cpointer ptr
				} andCode: {
					libOpaque <- make_object: (addr_of: cpointer_meta) NULL 0
					libOpaque val!: library
					libOpaque
				}
				
				faceFromPath:index <- :path :index {
					(_helper newFace: libraryOpaque path index) value: :opaque {
						option value: (_makeFace: opaque)
					} none: {
						option none
					}
				}
				
				llMessage: destroy withVars: {
				} andCode: {
					FT_Done_FreeType: library
					self
				}
			} _init
		}
		
		loadFlags <- { _loadFlags }
		kerning <- { _kerning }
	}
}