basis/alien/prettyprint/prettyprint.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel combinators alien alien.enums
   4 alien.strings alien.c-types alien.parser alien.syntax arrays
   5 assocs effects math.parser prettyprint.backend prettyprint.custom
   6 prettyprint.sections definitions see see.private sequences
   7 strings words ;
   8 IN: alien.prettyprint
   9
  10 M: alien pprint*
  11     {
  12         { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
  13         { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
  14         [ \ ALIEN: [ alien-address >hex text ] pprint-prefix ]
  15     } cond ;
  16
  17 M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
  18
  19 M: c-type-word definer drop \ C-TYPE: f ;
  20 M: c-type-word definition drop f ;
  21 M: c-type-word declarations. drop ;
  22
  23 <PRIVATE
  24 GENERIC: pointer-string ( pointer -- string/f )
  25 M: object pointer-string drop f ;
  26 M: word pointer-string name>> ;
  27 M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
  28 PRIVATE>
  29
  30 GENERIC: pprint-c-type ( c-type -- )
  31 M: word pprint-c-type pprint-word ;
  32 M: pointer pprint-c-type
  33     dup pointer-string
  34     [ swap present-text ]
  35     [ pprint* ] if* ;
  36 M: wrapper pprint-c-type wrapped>> pprint-word ;
  37 M: string pprint-c-type text ;
  38 M: array pprint-c-type pprint* ;
  39
  40 M: pointer pprint* \ pointer: pprint-word to>> pprint-c-type ;
  41
  42 M: typedef-word definer drop \ TYPEDEF: f ;
  43
  44 M: typedef-word synopsis*
  45     {
  46         [ seeing-word ]
  47         [ definer. ]
  48         [ "c-type" word-prop pprint-c-type ]
  49         [ pprint-word ]
  50     } cleave ;
  51
  52 : pprint-function-arg ( type name -- )
  53     [ pprint-c-type ] [ text ] bi* ;
  54
  55 : pprint-function-args ( types names -- )
  56     zip [ ] [
  57         unclip-last
  58         [ [ first2 "," append pprint-function-arg ] each ] dip
  59         first2 pprint-function-arg
  60     ] if-empty ;
  61
  62 : pprint-library ( library -- )
  63     [ \ LIBRARY: [ text ] pprint-prefix ] when* ;
  64
  65 : pprint-function ( word quot -- )
  66     [ def>> first pprint-c-type ]
  67     swap
  68     [
  69         <block "(" text
  70         [ def>> fourth ] [ stack-effect in>> ] bi
  71         pprint-function-args
  72         ")" text block>
  73     ] tri ; inline
  74
  75 M: alien-function-alias-word definer
  76     drop \ FUNCTION-ALIAS: \ ; ;
  77 M: alien-function-alias-word definition drop f ;
  78 M: alien-function-alias-word synopsis*
  79     {
  80         [ seeing-word ]
  81         [ def>> second pprint-library ]
  82         [ definer. ]
  83         [ pprint-word ]
  84         [ [ def>> third text ] pprint-function ]
  85     } cleave ;
  86
  87 M: alien-function-word definer
  88     drop \ FUNCTION: \ ; ;
  89 M: alien-function-word synopsis*
  90     {
  91         [ seeing-word ]
  92         [ def>> second pprint-library ]
  93         [ definer. ]
  94         [ [ pprint-word ] pprint-function ]
  95     } cleave ;
  96
  97 M: alien-callback-type-word definer
  98     drop \ CALLBACK: \ ; ;
  99 M: alien-callback-type-word definition drop f ;
 100 M: alien-callback-type-word synopsis*
 101     {
 102         [ seeing-word ]
 103         [ "callback-library" word-prop pprint-library ]
 104         [ definer. ]
 105         [ def>> first pprint-c-type ]
 106         [ pprint-word ]
 107         [
 108             <block "(" text
 109             [ def>> second ] [ "callback-effect" word-prop in>> ] bi
 110             pprint-function-args
 111             ")" text block>
 112         ]
 113     } cleave ;
 114
 115 M: enum-c-type-word definer
 116     drop \ ENUM: \ ; ;
 117 M: enum-c-type-word synopsis*
 118     {
 119         [ seeing-word ]
 120         [ definer. ]
 121         [ pprint-word ]
 122         [ c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ]
 123     } cleave ;
 124 M: enum-c-type-word definition
 125     c-type members>> ;