Patch title: Release 93 bulk changes
Abstract:
File: /graphic/vector/freetype.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
module "/pliant/admin/file.pli"
module "/pliant/math/curve.pli"
module "/pliant/math/vector.pli"
module "/pliant/admin/file.pli"
module "font.pli"

constant libfreetype "libfreetype.so.6"
constant direct true
module "/pliant/language/compiler.pli"
module "/pliant/admin/file.pli"
module "/pliant/math/curve.pli"
module "/pliant/math/vector.pli"
module "/pliant/admin/file.pli"
module "font.pli"

constant libfreetype "libfreetype.so.6"
constant direct true
constant multithread false






method f load_freetype filename options -> status
  arg_rw Font f ; arg Str filename options ; arg ExtendedSta
  var Address library
  if (FT_Init_FreeType (var Address library))<>0
    return failure:"failed to init freetype library"
  if (FT_New_Face library file_os_name:filename (options opt

method f do_load_freetype library filename options -> status
  arg_rw Font f ; arg Address library ; arg Str filename options ; arg ExtendedStatus status
  part new_face "FT_New_Face"
    var Int err := FT_New_Face library file_os_name:filename (options option "face" Int 0) (var Address face)
  if err<>0
    return failure:"failed to load font"
  var Pointer:FT_FaceRec facerec :> face map FT_FaceRec
  var Int unit := facerec units_per_EM
  var CBool gn := FT_Has_PS_Glyph_Names face
  for (var Int index) 0 facerec:num_glyphs-1
    return failure:"failed to load font"
  var Pointer:FT_FaceRec facerec :> face map FT_FaceRec
  var Int unit := facerec units_per_EM
  var CBool gn := FT_Has_PS_Glyph_Names face
  for (var Int index) 0 facerec:num_glyphs-1
    part record_glyph
      var Pointer:Int unicode :> null map Int
      if gn
        var Str glyph_name := repeat 256 " "
        if (FT_Get_Glyph_Name face (cast index uInt) glyph_n
          glyph_name := glyph_name 0 (glyph_name search "[0]
          unicode :> postscript_glyphs first glyph_name
    part record_glyph "FreeType glyph "+string:index+"/"+(string facerec:num_glyphs)
      part mapping "glyph mapping"
        var Pointer:Int unicode :> null map Int
        if gn
          var Str glyph_name := repeat 256 " "
          if (FT_Get_Glyph_Name face (cast index uInt) glyph_name:characters (cast glyph_name:len uInt))=0
            glyph_name := glyph_name 0 (glyph_name search "[0]" glyph_name:len)
            unicode :> postscript_glyphs first glyph_name
        if not exists:unicode
          if facerec:num_charmaps>=1
            var uInt encoding := (facerec:charmaps map Pointer:FT_CharMapRec) encoding
            if encoding=unicode_encoding and facerec:num_charmaps>=2
              encoding := (facerec:charmaps map Pointer:FT_CharMapRec 1) encoding
            if (FT_Select_Charmap face encoding)=0
              for (var Int char) 0 255
                if (FT_Get_Char_Index face (cast char uInt))=index
                  unicode :> f:encoding char
      if not exists:unicode
      if not exists:unicode
        if facerec:num_charmaps>=1
          var uInt encoding := (facerec:charmaps map Pointer
          if encoding=unicode_encoding and facerec:num_charm
            encoding := (facerec:charmaps map Pointer:FT_Cha
          if (FT_Select_Charmap face encoding)=0
            for (var Int char) 0 255
              if (FT_Get_Char_Index face (cast char uInt))=i
                unicode :> f:encoding char
      if not exists:unicode
        # console "Failed to discover Unicode value for glyp
        leave record_glyph
        # console "Failed to discover Unicode value for glyp
        leave record_glyph
      if (FT_Load_Glyph face (cast index uInt) FT_LOAD_NO_SC
      part load "FT_Load_Glyph"
        var Int err := FT_Load_Glyph face (cast index uInt) FT_LOAD_NO_SCALE
      if err<>0
        # console "Failed to load glyph " index eol
        leave record_glyph
        # console "Failed to load glyph " index eol
        leave record_glyph
      if (FT_Get_Glyph facerec:glyph (var Address glyph))<>0
      part get "FT_Get_Glyph"
        var Int err := FT_Get_Glyph facerec:glyph (var Address glyph)
      if err<>0
        # console "Failed to get glyph" eol
        leave record_glyph
        # console "Failed to get glyph" eol
        leave record_glyph
      var Pointer:FT_OutlineGlyphRec r :> glyph map FT_Outli
      (var Array:Curve curves) size := 0
      if direct
        curves size := r:outline n_contours
        var Pointer:FT_Outline o :> r:outline
        # console (cast o:n_contours Int) " contours " (cast
        for (var Int i) 0 curves:size-1
          var Pointer:Curve c :> curves i
          var Int j0
          if i=0
            j0 := 0
          else
            j0 := (o:contours map Int16 i-1)+1
          var Int j1:= (o:contours map Int16 i)+1
          # console "contout " i " " j0 " " j1 ":"
          for (var Int j) j0 j1
            var Pointer:FT_Vector v0 :> o:points map FT_Vect
            var Int t0 := o:tags map uInt8 j
            # console "   " (character 65+(t0 .and. 3)) " " 
          var Int j := j0
          while j<j1
            var Pointer:FT_Vector v0 :> o:points map FT_Vect
            var Int t0 := o:tags map uInt8 j
            if (t0 .and. FT_CURVE_TAG_ON)<>0
              c angle v0:x/unit -(v0:y/unit)
              j += 1
      part mapping "glyph conversion"
        var Pointer:FT_OutlineGlyphRec r :> glyph map FT_OutlineGlyphRec
        (var Array:Curve curves) size := 0
        if direct
          curves size := r:outline n_contours
          var Pointer:FT_Outline o :> r:outline
          # console (cast o:n_contours Int) " contours " (cast o:n_points Int) " points" eol
          for (var Int i) 0 curves:size-1
            var Pointer:Curve c :> curves i
            var Int j0
            if i=0
              j0 := 0
            else
            else
              var Pointer:CurvePoint l :> c point c:size-1
              var Pointer:FT_Vector v1 :> o:points map FT_Ve
              var Int t1 := o:tags map uInt8 (j+1-j0)%(j1-j0
              if (t1 .and. FT_CURVE_TAG_ON)<>0
                l out v0:x/unit-l:x -(v0:y/unit)-l:y
                c angle v1:x/unit -(v1:y/unit)
                var Pointer:CurvePoint l :> c point c:size-1
                l in v0:x/unit-v1:x/unit -(v0:y/unit)-(-(v1:
                j += 2
              j0 := (o:contours map Int16 i-1)+1
            var Int j1:= (o:contours map Int16 i)+1
            # console "contout " i " " j0 " " j1 ":"
            for (var Int j) j0 j1
              var Pointer:FT_Vector v0 :> o:points map FT_Vector j
              var Int t0 := o:tags map uInt8 j
              # console "   " (character 65+(t0 .and. 3)) " " v0:x " " v0:y
            var Int j := j0
            while j<j1
              var Pointer:FT_Vector v0 :> o:points map FT_Vector j
              var Int t0 := o:tags map uInt8 j
              if (t0 .and. FT_CURVE_TAG_ON)<>0
                c angle v0:x/unit -(v0:y/unit)
                j += 1
              else
              else
                var Pointer:FT_Vector v2 :> o:points map FT_
                var Int t2 := o:tags map uInt8 (j+2-j0)%(j1-
                l out v0:x/unit-l:x (-v0:y/unit)-l:y
                c angle v2:x/unit -(v2:y/unit)
                var Pointer:CurvePoint l :> c point c:size-1
                var Pointer:CurvePoint l :> c point c:size-1
                l in v1:x/unit-l:x -(v1:y/unit)-l:y
                j += 3
          # console eol
          c compute outline+bezier
      else
        var FT_Outline_Funcs funcs
        funcs move_to := (the_function move_to FT_Vector Arr
        funcs line_to := (the_function line_to FT_Vector Arr
        funcs conic_to := (the_function conic_to FT_Vector F
        funcs cubic_to := (the_function cubic_to FT_Vector F
        funcs shift := 0
        funcs delta := 0
        if r:outline:n_contours>0
          if (FT_Outline_Decompose r:outline funcs addressof
            # console "failed to decompose" eol
            leave record_glyph
        if curves:size>0
          (curves curves:size-1) compute outline+bezier
      var FontChar fchar ; fchar curves := curves
      fchar vector := vector r:root:advance:x/unit/2^10 -(r:
      f:chars insert unicode fchar
      # console "."
  if (FT_Done_FreeType library)<>0
    return failure:"failed to close freetype library"
                var Pointer:FT_Vector v1 :> o:points map FT_Vector (j+1-j0)%(j1-j0)+j0
                var Int t1 := o:tags map uInt8 (j+1-j0)%(j1-j0)+j0
                if (t1 .and. FT_CURVE_TAG_ON)<>0
                  l out v0:x/unit-l:x -(v0:y/unit)-l:y
                  c angle v1:x/unit -(v1:y/unit)
                  var Pointer:CurvePoint l :> c point c:size-1
                  l in v0:x/unit-v1:x/unit -(v0:y/unit)-(-(v1:y/unit))
                  j += 2
                else
                  var Pointer:FT_Vector v2 :> o:points map FT_Vector (j+2-j0)%(j1-j0)+j0
                  var Int t2 := o:tags map uInt8 (j+2-j0)%(j1-j0)+j0
                  l out v0:x/unit-l:x (-v0:y/unit)-l:y
                  c angle v2:x/unit -(v2:y/unit)
                  var Pointer:CurvePoint l :> c point c:size-1
                  l in v1:x/unit-l:x -(v1:y/unit)-l:y
                  j += 3
            # console eol
            c compute outline+bezier
        else
          var FT_Outline_Funcs funcs
          funcs move_to := (the_function move_to FT_Vector Array:Curve) executable
          funcs line_to := (the_function line_to FT_Vector Array:Curve) executable
          funcs conic_to := (the_function conic_to FT_Vector FT_Vector Array:Curve) executable
          funcs cubic_to := (the_function cubic_to FT_Vector FT_Vector FT_Vector Array:Curve) executable
          funcs shift := 0
          funcs delta := 0
          if r:outline:n_contours>0
            if (FT_Outline_Decompose r:outline funcs addressof:curves)<>0
              # console "failed to decompose" eol
              leave record_glyph
          if curves:size>0
            (curves curves:size-1) compute outline+bezier
        var FontChar fchar ; fchar curves := curves
        fchar vector := vector r:root:advance:x/unit/2^10 -(r:root:advance:y/unit/2^10)
        f:chars insert unicode fchar
  status := success

  status := success

if not multithread
  gvar Sem libfreetype_sem

method f load_freetype filename options -> status
  arg_rw Font f ; arg Str filename options ; arg ExtendedStatus status
  if not multithread
    libfreetype_sem request
  part load "load freetype font "+filename+" "+options
    part init "FT_Init_FreeType"
      var Int err := FT_Init_FreeType (var Address library)
    if err<>0
      status := failure "failed to init freetype library"
      leave load
    status := f do_load_freetype library filename options
    part done "FT_Done_FreeType"
      var Int err := FT_Done_FreeType library
    if err<>0
      status := failure "failed to close freetype library"
  if not multithread
    libfreetype_sem release

function font_freetype filename options -> f
  arg Str filename options ; arg Link:Font f
  f :> new Font
  if (f load_freetype filename options)=failure
    f :> null map Font


  # test "embedded:/usr/share/fonts/type1/gsfonts/n019003l.p
  test "file:/tmp/font.cff"
function font_freetype filename options -> f
  arg Str filename options ; arg Link:Font f
  f :> new Font
  if (f load_freetype filename options)=failure
    f :> null map Font


  # test "embedded:/usr/share/fonts/type1/gsfonts/n019003l.p
  test "file:/tmp/font.cff"