basis/alien/prettyprint/prettyprint.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.enums alien.strings
   4 alien.syntax arrays assocs combinators combinators.short-circuit
   5 definitions effects kernel math.parser prettyprint.backend
   6 prettyprint.custom prettyprint.sections see see.private sequences
   7 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: record-pointer ( pointer -- )
  25 M: object record-pointer drop ;
  26 M: word record-pointer record-vocab ;
  27 M: pointer record-pointer to>> record-pointer ;
  28
  29 GENERIC: record-c-type ( c-type -- )
  30 M: word record-c-type record-vocab ;
  31 M: pointer record-c-type record-pointer ;
  32 M: wrapper record-c-type wrapped>> record-c-type ;
  33 M: array record-c-type first record-c-type ;
  34 PRIVATE>
  35
  36 : pprint-c-type ( c-type -- )
  37     [ record-c-type ] [ c-type-string ] [ ] tri present-text ;
  38
  39 M: pointer pprint*
  40     <flow \ pointer: pprint-word to>> pprint* block> ;
  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 PREDICATE: alien-function-alias-word < word
  76     def>> {
  77         [ length 6 = ]
  78         [ last \ alien-invoke eq? ]
  79     } 1&& ;
  80
  81 M: alien-function-alias-word definer
  82     drop \ FUNCTION-ALIAS: f ;
  83 M: alien-function-alias-word definition drop f ;
  84 M: alien-function-alias-word synopsis*
  85     {
  86         [ seeing-word ]
  87         [ def>> second pprint-library ]
  88         [ definer. ]
  89         [ pprint-word ]
  90         [ [ def>> third text ] pprint-function ]
  91     } cleave ;
  92 M: alien-function-alias-word declarations. drop ;
  93
  94 PREDICATE: alien-function-word < alien-function-alias-word
  95     [ def>> third ] [ name>> ] bi = ;
  96
  97 M: alien-function-word definer
  98     drop \ FUNCTION: f ;
  99 M: alien-function-word synopsis*
 100     {
 101         [ seeing-word ]
 102         [ def>> second pprint-library ]
 103         [ definer. ]
 104         [ [ pprint-word ] pprint-function ]
 105     } cleave ;
 106
 107 PREDICATE: alien-callback-type-word < typedef-word
 108     "callback-effect" word-prop >boolean ;
 109
 110 M: alien-callback-type-word definer
 111     drop \ CALLBACK: f ;
 112 M: alien-callback-type-word definition drop f ;
 113 M: alien-callback-type-word synopsis*
 114     {
 115         [ seeing-word ]
 116         [ "callback-library" word-prop pprint-library ]
 117         [ definer. ]
 118         [ def>> first first pprint-c-type ]
 119         [ pprint-word ]
 120         [
 121             <block "(" text
 122             [ def>> first second ] [ "callback-effect" word-prop in>> ] bi
 123             pprint-function-args
 124             ")" text block>
 125         ]
 126     } cleave ;
 127
 128 M: enum-c-type-word definer
 129     drop \ ENUM: \ ; ;
 130 M: enum-c-type-word synopsis*
 131     {
 132         [ seeing-word ]
 133         [ definer. ]
 134         [ pprint-word ]
 135         [ lookup-c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ]
 136     } cleave ;
 137 M: enum-c-type-word definition
 138     lookup-c-type members>> ;