obp/obp/fm/lib/patch.fth

\ ========== Copyright Header Begin ==========================================
\
\ Hypervisor Software File: patch.fth
\
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\
\  - Do no alter or remove copyright notices
\
\  - Redistribution and use of this software in source and binary forms, with
\    or without modification, are permitted provided that the following
\    conditions are met:
\
\  - Redistribution of source code must retain the above copyright notice,
\    this list of conditions and the following disclaimer.
\
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution.
\
\    Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\
\     This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility.
\
\ ========== Copyright Header End ============================================
\ patch.fth 2.11 01/04/06
\ Copyright 1985-1994 Bradley Forthware
\ copyright: Copyright 1995-2001 Sun Microsystems, Inc.  All Rights Reserved

\  Patch utility.  Allows you to make patches to already-defined words.
\   Usage:
\     PATCH new old word-to-patch
\         In the definition of "word-to-patch", replaces the first
\         occurence of "old" with "new".  "new" may be either a word
\         or a number.  "old" may be either a word or a number.
\
\     n-new  n-old  NPATCH  word-to-patch
\         In the definition of "word-to-patch", replaces the first
\         compiled instance of the number "n-old" with the number
\         "n-new".
\
\     n-new  n-old  start-adr  end-adr  (NPATCH
\         replaces the first occurrence of "n-old" in the word "acf"
\         with "n-new"
\
\     acf-new  acf-old  acf  (PATCH
\         replaces the first occurrence of "acf-old" in the word "acf"
\         with "acf-new"
\
\     new new-type   old old-type  acf  (PATCH)
\         replaces the first occurrence of "old" in the word "acf" with "new".
\         If "new-type" is true, "new" is a number, otherwise "new" is an acf.
\         If "old-type" is true, "old" is a number, otherwise "old" is an acf.
\
\     n  start-adr end-adr   SEARCH
\         searches for an occurrence of "n" between start-adr and
\         end-adr.  Leaves the adress where found and a success flag.
\
\     c  start-adr end-adr   CSEARCH
\         searches for a byte between start-adr and end-adr
\
\     w  start-adr end-adr   WSEARCH
\         searches for a 16-bit word between start-adr and end-adr
\
\     acf  start-adr end-adr TSEARCH
\         searches for a compiled adress between start-adr and end-adr
\
\

decimal

: csearch ( c start end -- loc true | false )
   false -rot swap  ?do                 ( c false )
      over i c@ = if
         drop i swap true leave
      then
   /c +loop  nip
;
: wsearch  ( w start end -- loc true | false )
   rot n->w             \ strip off any high bits
   false 2swap  swap  ?do               ( w false )
      over i w@ = if
         drop i swap true leave
      then
   /w +loop  nip
;
: tsearch  ( adr start end -- loc true | false )
   false -rot  swap  ?do                        ( targ false )
      over i token@ = if
         drop i swap true leave
      then
      \ Can't use /token because tokens could be 32-bits, aligned on 16-bit
      \ boundaries, with 16-bit branch offsets realigning the token list.
   #talign +loop  nip
;
: search  ( n start end -- loc true | false )
   false -rot  swap  ?do                ( n false )
      over i @ = if
         drop i swap true leave
      then
   #talign +loop  nip
;

headerless

: get-next-token  ( adr -- adr token )
   dup token@                 ( n adr token )
   dup ['] unnest =  abort" Can't find word to replace"   ( n adr token )
;

: find-lit  ( n acf -- adr )
   >body
   begin
      get-next-token             ( n adr token )
\t16  dup  ['] (wlit)  =  if     ( n adr token )
\t16     drop                    ( n adr )
\t16     2dup ta1+ w@ 1-  =  if  ( n adr )
\t16        nip exit             ( adr )
\t16     else                    ( n adr )
\t16        ta1+ wa1+            ( n adr' )
\t16     then                    ( n adr )
\t16  else                       ( n adr token )
       dup  ['] (lit) =  if      ( n adr token )
          drop                   ( n adr )
          2dup ta1+ @  =  if     ( n adr )
             nip exit            ( adr )
          else                   ( n adr )
             ta1+ na1+           ( n adr' )
          then                   ( n adr )
       else                      ( n adr token )
          ['] (llit) =  if       ( n adr )
             2dup ta1+ l@ 1-  =  if  ( n adr )
                nip exit             ( adr )
             else                    ( n adr )
                ta1+ la1+            ( n adr' )
             then                    ( n adr' )
          else                       ( n adr )
             ta1+                    ( n adr' )
          then                       ( n adr' )
       then                          ( n adr' )
\t16 then
   again
;

: find-token  ( n acf -- adr )
   >body
   begin
      get-next-token                ( n adr token )
      2 pick =  if  nip exit  then  ( n adr )
      ta1+                          ( n adr' )
   again
;

: make-name  ( n digit -- adr len )
   >r  <# u#s ascii # hold  r> hold u#>   ( adr len )
;

: put-constant  ( n adr -- )
   over
   base @  d# 16 =  if
      ascii h make-name
   else
      push-decimal
      ascii d make-name
      pop-base
   then                           ( n adr name-adr name-len )

   \ We don't use  "create .. does> @  because we want this word
   \ to decompile as 'constant'

   warning @ >r  warning off
   $header       ( n adr )
   constant-cf swap ,             ( adr )
   r> warning !

   lastacf swap token!
;

: put-noop  ( adr -- )  ta1+  ['] noop swap token!  ;

\t16 : short-number?  ( n -- flag )  -1  h# fffe  between  ;
\t32 : long-number?  ( n -- flag )  -1  h# ffff.fffe n->l between  ;

headers
: (patch)  ( new number?  old number?  word -- )
   swap  if                         ( new number? old acf )  \ Dest. is num
      find-lit                      ( new number? adr )

\t16  dup token@ ['] (wlit) =  if   ( new number? old )  \ Dest. slot is wlit
\t16     swap  if                   ( new adr )   \ replacement is a number
\t16        over short-number?  if  ( new adr )   \ replacement is short num
\t16           ta1+ swap 1+ swap w! ( )
\t16           exit
\t16        then                    ( new adr )   \ Replacement is long num
\t16        tuck put-constant       ( adr )
\t16        put-noop                ( )
\t16        exit
\t16     then                       ( new adr )  \ replacement is a word
\t16     tuck token!  put-noop      ( )
\t16     exit
\t16  then                          ( new number? adr )  \ Dest. slot is lit

\t32  dup token@ ['] (llit) =  if   ( new number? old )  \ Dest. slot is wlit
\t32     swap  if                   ( new adr )   \ replacement is a number
\t32        over long-number?  if   ( new adr )   \ replacement is short num
64\ \t32       ta1+ swap 1+ swap l! ( )
32\ \t32       ta1+ l!              ( )
\t32           exit
\t32        then                    ( new adr )   \ Replacement is long num
\t32        tuck put-constant       ( adr )
\t32        put-noop                ( )
\t32        exit
\t32     then                       ( new adr )  \ replacement is a word
\t32     tuck token!  put-noop      ( )
\t32     exit
\t32  then                          ( new number? adr )  \ Dest. slot is lit

      swap  if  ta1+ !  exit  then  ( new adr )  \ replacement is a word

      tuck token!                   ( adr )
32\ \t16  dup put-noop  ta1+               ( )
64\ \t16  dup put-noop  ta1+ dup put-noop  dup put-noop  ta1+  ( )
64\ \t32  dup put-noop  ta1+
      put-noop                             ( )
      exit
   then                             ( new number? old acf )  \ Dest. is token

   find-token                       ( new number? adr )
   swap if  put-constant exit  then ( new adr )  \ replacement is a number
   token!
;

headerless
: get-word-type  \ word  ( -- val number? )
   parse-word  $find  if  false exit  then  ( adr len )
   $dnumber?  1 <> abort" ?"  true
;

headers
: (npatch  ( newn oldn acf -- )  >r true tuck  r>  (patch)  ;

: (patch  ( new-acf old-acf acf -- )  >r false tuck r>  (patch)  ;

\ substitute new for first occurrence of old in word "name"
: npatch  \ name  ( new old -- )
   true tuck  '  ( new true old true acf )  (patch)
;

: patch  \ new old word  ( -- )
   get-word-type   get-word-type  '  (patch)
;