/pliant/language/type/pointer/pointer.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  scope "/pliant/language/" "/pliant/install/" 
 17  module "/pliant/install/ring2.pli" 
 18   
 19   
 20  meta exists e 
 21    if e:size<>1 
 22      return 
 23    e:compile ? 
 24    var Pointer:Type :> e:0:result type 
 25    if (addressof unpointerto:t)<>null 
 26      :> unpointerto t 
 27    var Link:Argument :> argument local CBool 
 28    var Link:Instruction end :> instruction the_function:'do nothing' 
 29    var Link:Expression :> 0 
 30    while addressof:t<>null 
 31      if not (cast t) 
 32        return 
 33      suckup f 
 34      :> unpointerto t 
 35      add (instruction (the_function 'address Universal' Universal -> Address) f:result a) 
 36      if addressof:t<>null 
 37        add (instruction (the_function 'jump if not' CBool) jump end) 
 38        var Link:Expression oldf :> f 
 39        :> expression ident "dummy" near e:0 
 40        set_result oldf:result oldf:access 
 41    add end 
 42    set_result access_read 
 43   
 44   
 45  meta ':>>' e 
 46    if e:size<>2 
 47      return 
 48    e:compile ? 
 49    if (e:0:access .and. access_write)=0 
 50      return 
 51    var Pointer:Type ptr2 ptr type 
 52    ptr2 :> null map Type ; ptr :> null map Type ; type :> e:0:result:type 
 53    while (addressof unpointerto:type)<>null 
 54      ptr2 :> ptr ; ptr :> type ; type :> unpointerto type 
 55    if addressof:ptr2=null or not (e:cast ptr2) or not (e:cast ptr) 
 56      return 
 57    suckup e:1 
 58    suckup e:0 
 59    if ptr2:is_pointer 
 60      add (instruction (the_function 'address Universal' Universal -> Address) e:1:result e:0:result) 
 61    else 
 62      add (instruction (the_function 'arrow Universal' Universal -> Arrow) e:1:result e:0:result) 
 63    set_void_result 
 64   
 65   
 66  meta addressof2 e 
 67    if e:size<>2 
 68      return 
 69    var Pointer:Type :> (e:constant Type) map Type 
 70    if addressof:t=null 
 71      return 
 72    if not (e:cast t) 
 73      return 
 74    suckup e:1 
 75    var Link:Argument :> argument local Address 
 76    add (instruction (the_function 'address Universal' Universal -> Address) e:1:result a) 
 77    set_result access_read 
 78  alias addressof addressof2 
 79   
 80  export exists 
 81  operator ':>>' 510h 1000000000 1000000000 
 82  export ':>>' addressof