Introduction

Overview Of This Document

Directory Organization

Files In This Directory

<Magic ls>=
0magic.fw
Makefile
initMagic.N
cCompile.N
exportAny.N
magic.N

This code is written to a file (or else not used).

Makefile

<Makefile>=
# define all the components in this directory, both the locs where they go, 
# and the links to their values.  
files := cCompile magic exportAny
 init := initMagic

include $(CPAMC)/MakefileNapier

Makefile: 0magic.nw
        notangle -RMakefile -t8 0magic.nw | cpif -ne Makefile
cCompile.N: 0magic.nw
        notangle -RcCompile.N 0magic.nw | cpif -ne cCompile.N
exportAny.N: 0magic.nw
        notangle -RexportAny.N 0magic.nw | cpif -ne exportAny.N
magic.N: 0magic.nw
        notangle -Rmagic.N 0magic.nw | cpif -ne magic.N

This code is written to a file (or else not used).

initMagic

<initMagic.N>=
! Dependencies : -t boot -t passes -t cPamCaseCGPass
project PS() as root onto env :
  use root with Library : env in
    use Library with Environment : env;
                     getImplementation : proc(string -> env) in
      use Environment with environment : proc(-> env) in
      use getImplementation("wizard") with CompilerImplementation : env in
        use CompilerImplementation with General,Source,Passes : env in
          use General with initMsg : proc(string) in
          use Passes with l1L2ICManager : L1L2ICManager ;
                          scopingModule : L2ScopingModule ;
                          CPamCaseCG    : env in
            use l1L2ICManager as ICM[IC,CH,Pos] in
            use scopingModule as SM[Scope] in
begin
  !*** Specialise some types
  type SpecCPamCaseCGResult is CPamCaseCGResult[IC,Scope]
  type SpecCPamCaseCGSuccess is CPamCaseCGSuccess[IC,Scope]
  type SpecCPamCaseCGState is CPamCaseCGState[IC,Scope]
  begin
    if CPamCaseCG contains Magic do drop Magic from CPamCaseCG
    let Magic = environment()
    in CPamCaseCG let Magic = Magic

    in Magic let exportAny := proc(filename : string; value : any)
        initMsg("exportAny")
    in Magic let cCompile := proc(state:SpecCPamCaseCGState -> *CPamInst)
        {initMsg("cCompile"); vector @1 of [CPamInst(pam:0)]}
    in Magic let constructCode := 
        proc(state : SpecCPamCaseCGState -> CodeObject)
        {initMsg("constructCode"); CodeObject(nil,nil)}
    in Magic let magic := proc(code : NCode -> CodeObject)
        {initMsg("magic"); CodeObject(nil,nil)}
  end
end

default : {}
?

This code is written to a file (or else not used).

*

cCompile.N

<cCompile.N>=
! Dependencies : -t general -t boot -t tables -t -t compilerGeneral -t compilerErrors -t LA -t passes -t cPamCaseCGPass -t hyperLink
project PS() as root onto env :
  use root with Library : env in
    use Library with Format,IO,String,Tables : env;
                     getImplementation : proc(string -> env) in
      use Format with iformat : proc(int -> string) in
      use IO with
          PrimitiveIO : env;
          makeReadEnv : proc(file->env);
          makeWriteEnv : proc(file->env);
          writeString : proc(string) in
        use PrimitiveIO with
            create : proc(string,int -> file);
            open : proc(string,int -> file);
            close : proc(file -> int) in
      use String with length : proc(string -> int) in
      use Tables with
          tableGen : proc[Key,Data](Comparison[Key] -> Table[Key,Data]) in
      use getImplementation("wizard") with CompilerImplementation : env in
        use CompilerImplementation with 
            Errors,General,LA,Source,Passes,Types : env in
          use Errors with Compilation : env in
            use Compilation with Error : proc(string) in
          use General with Symbols : env in
            use Symbols with eot : string in
          use LA with lexicalAnalyserGen : LAGenerator in
          use Source with IC : env in
          use Passes with l1L2ICManager : L1L2ICManager;
                          scopingModule : L2ScopingModule;
                          mkSymbolTable : proc(-> SymbolTable);
                          CPamCaseCG    : env in
            use CPamCaseCG with LexProcs,CGConstants,Magic : env in
              use LexProcs with nextSy : proc(LexInfoState) in
              use CGConstants with 
                  cvecPntrOverhead, initCVec, pEnvStart, pLitStart,
                  sEnvStart, stSize, stSize2, stSize3 : int in
              use Magic with
                  exportAny : proc(string,any);
                  magic : proc(NCode -> CodeObject) in
            use l1L2ICManager as ICM[IC,CH,Pos] in
            use scopingModule as SM[Scope] in
          use Types with UNDEFINED : TypeRep in

begin
  !*** Specialise some types
  type SpecCPamCaseCGResult is CPamCaseCGResult[IC,Scope]
  type SpecCPamCaseCGSuccess is CPamCaseCGSuccess[IC,Scope]
  type SpecCPamCaseCGState is CPamCaseCGState[IC,Scope]
  
  use Magic with
      cCompile : proc(SpecCPamCaseCGState -> *CPamInst);
      constructCode : proc(SpecCPamCaseCGState -> CodeObject) in
  begin
    <cCompile definition>
    <constructCode definition>
  end
end

default : {}
?

This code is written to a file (or else not used).

*

cCompile

<cCompile definition>=
cCompile := proc(state:SpecCPamCaseCGState -> *CPamInst)
begin
  <int2str definition>
  let mklabel = proc(lab : int -> string); "L"++int2str(lab,3)
  <macroString definition>
  <writeMacroFile definition>
  <doCompile definition>      
  <readRawCode definition>
      
  let cv := state(cvec)
  let cvcount = state(cp)-1
  writeString("*** Found "++iformat(cvcount)++" instructions'n")
  let stem = "pm"
  let macrofile = stem ++ ".c"
  let nativefile = stem ++ ".raw"
      
  !*** now start the business of writing the macros into a file
  writeMacroFile(macrofile,cv,cvcount)

  !*** now C compile the resulting file and run to get nativecode
  let cCodeError := doCCompile(macrofile,nativefile)
      
  !*** read the raw code back into a vector, and return that
  if ~ cCodeError then readRawCode(nativefile)
  else vector @1 of [CPamInst(pam:0)] ! return noop if fail
end

Used above.

int2str returns the string representation of the n in w digits, with 0 left fill as necessary. If w is too small, it is ignored.

<int2str definition>=
let int2str = proc(n,w:int -> string)
begin 
  let res := iformat(n)
  let l = length(res)
  if l<w do begin
    let pad = "00000000000000000000" ! 20 of them should be enough
    res := pad(1|w-l)++res
  end
  res
end

Used above.

*

macroString

<macroString definition>=
let macroString = proc(m : CPamMacro -> string); begin
  <compute macro label>
  <compute macro name>
  <compute macro parameters>
  label++name++parms
end

Defines macroString (links are to index).

Used above.

The label part is easy: if the value of the label is 0, issue no label, else convert the value to a string, and append a colon. The label representation of label $n$ is ``L$n$''.

<compute macro label>=
label = if m(label)=0 then "     " 
        else mklabel(m(label))++":"

Used above.

Macro names come in two forms, depending on the variant. If the variant is pamop, then the macro is a number $n$, and the string representation is ``Pam$n$''. If the variant is a direct name, then just that name is used without further conversion.

<compute macro name>=
let name = 
  project m(name) as mn onto
    pamop : "Pam"++int2str(mn,3)
    direct : mn
  default : "bad_MacroName"

Used above.

If parameters are present, then the vector of parameters is output as a comma separated list. The values of parameters can be either integers (output directly) or labels, in which case a label representation is output.

<compute macro parameters>=
let parms := ""; let sep := "("
let args = m(arguments)
if args is present then begin
  let argpres = args'present
  for i=1 to upb[Argument](argpres) do begin
    parms := parms++sep; sep := ","
    parms := parms++(project argpres(i) as argv onto
        intarg:iformat(argv)
        cvloc:mklabel(argv)
      default:"bad_argument")
  end
end else parms := parms++sep
parms := parms++")"

Used above.

*

writeMacroFile

<writeMacroFile definition>=
let writeMacroFile = proc(cname : string; cv : *CPamInst; cvcount : int)
begin
  let newfile = create(cname,6*64+6*8+4)
  let macrofile = open("DISK:"++cname,1)
  if macrofile=nilfile do Error("cannot open macros file")
  let macroenv = makeWriteEnv(macrofile)
  use macroenv with writeString : proc(string) in
  begin
    <write macro file header information>
    <write macro file macro calls>
    <write macro file trailer information>
  end
  if close(macrofile)=-1 do Error("cannot close macros file")
end ! writeMacroFile

Used above.

The main information conveyed in the header is the name of the include file containing all the macro definitions.

<write macro file header information>=
writeString("#include '"cpc-codegen-1.h'"'n")
writeString("N4_Return_t Capsule_1()'n{'n")

Used above.

*

<write macro file macro calls>=
for i=1 to cvcount do begin
  let inst = cv(i)
  project inst as X onto
      pam:writeString(":Pam byte "++iformat(X))
      macro:writeString(macroString(X))
      default:writeString("*** cCompile:Illegal variant in PamInst")
  writeString("'n")
end

Used above.

*

<write macro file trailer information>=
writeString("}'n")
writeString("void'n")
writeString("Capsule_1_Follow()'n")
writeString("{'n")
writeString("}'n")
writeString("MAIN_BEGIN'n")
writeString("  SAVE_CAPSULE(1)'n")
writeString("MAIN_END'n")

Used above.

*

doCompile

<doCompile definition>=
let doCCompile = proc(cname,rawname : string -> bool)
begin
  let compileError := false
  let shellfile = open("SHELL:",2)
  let shellWenv = makeWriteEnv(shellfile)
  let shellRenv = makeReadEnv(shellfile)
  let ws = writeString
  use shellWenv with writeString : proc(string) in
    use shellRenv with 
      endOfInput : proc(-> bool);
      readLine : proc(-> string);
      readString : proc(-> string) in

Used above; next definition.

The endmessage allows us to signal the end of the control stream into the subprocess.

<doCompile definition>+=
  begin
    let endmessage = "THE END"
    let emLen = length(endmessage)
    <pattern matching procedure definition>
    writeString("/bin/rm "++rawname++"'n")

Used above; previous and next definitions.

To see what comes back from the C compilation process, we read lines and search for various patterns. The procedure patMatch takes a pattern pat (which is just a string, nothing fancy here), and the subject string target, and returns true if target contains pat starting at the first character.

<pattern matching procedure definition>=
let patMatch = proc(pat,target:string->bool)
begin
  let patlen = length(pat)
  let targlen := length(target)
  (if targlen<patlen then false else pat=target(1|patlen))
end

Used above.

To compile the C code, we use gnumake. This is done by writing the environment variable CPAMMAKE into the socket, which is expanded into the full make and makefile name to be used. This gives a measure of independence of this code from the environment, and allows the C compiler invocation to be changed without having to recompiler the Napier compiler (this compiler).

<doCompile definition>+=
    let makePath := "$CPAMMAKE " 
    writeString(makePath ++ rawname ++ "'n")
    writeString("echo '""++endmessage++"'"'n")
    let theend := false

Used above; previous and next definitions.

Read the lines coming back from the shell subprocess. These are scanned to search for two things: \begin{enumerate}\itemskip=0pt \item If the line contains the string gnumake: *** [pm.raw] Error 1, then an error occurred in the C compilation. \item If the line is equal to the string endmessage, then this is the last line of the script, so we can disconnect the subprocess. \end{enumerate}

<doCompile definition>+=
    while ~(theend or endOfInput()) do begin
      let line = readLine()
      ws(line++"'n")
      if patMatch(line,"gnumake: *** [pm.raw] Error 1")
      do compileError := true ! this is a kludge ************
      theend := patMatch(line,endmessage)
    end
  end

Used above; previous and next definitions.

return whether we were successful in compiling this code

<doCompile definition>+=
  compileError
end

Used above; previous definition.

*

constructCode

<constructCode definition>=
constructCode := proc(state : SpecCPamCaseCGState -> CodeObject)
begin
  !*** One location before start of scalars in cvec.  Arithmetic
  !*** at end ensures word break at start of scalars.
  !***********************************************************************
  !*** I'm not sure that this is appropriate in CPamCase 941112:181603 ajh
  !***********************************************************************
  let scalarStart = pLitStart+state(pntrCount)*stSize+(state(cp)-2) div 4
  
  let frameSize = (state(maxMs) + state(maxPs)) div stSize
  
  !*** Do the scalar backpatching.

Used above; next definition.

*

<constructCode definition>+=
  let cvec = state(cvec)
  let noOfScalars = state(scalarCount)
  let scalarPos := scalarStart 
      !*** The position each scalar WILL be in in the cvec
  let svec = vector 0 to noOfScalars of 0                        
      !*** A vector to hold the scalar values, first is dummy
  let scalarListSpot := state(scalarList)                      
      !*** if no scalars.  A pointer to locations in the list

Used above; previous and next definitions.

*

<constructCode definition>+=
  for i = 1 to noOfScalars do
  begin
    let scalarInfo := scalarListSpot'cons(hd)               
        !*** Get the info from the scalar list
    svec(i) := scalarInfo(scalar)                         
        !*** Record the scalar in the vector for later
    let scalarUse := scalarInfo(codeOffsets)                
        !*** Get the list of offsets in the code vector
    
    while scalarUse isnt tip do
    begin
      cvec(scalarUse'cons(hd)) := CPamInst(pam:scalarStart + i)
      scalarUse := scalarUse'cons(tl)
    end
    
    scalarListSpot := scalarListSpot'cons(tl)
  end

Used above; previous and next definitions.

*

<constructCode definition>+=
  !*** C Compile the code vector
  writeString("*** about to call the C Compilation ***'n")
  let exactCVec = cCompile(state)          
  writeString("*** C Compilation returns ***'n")

Used above; previous and next definitions.

*

<constructCode definition>+=
  !*** Make a pointer vector - first element is a dummy element -
  !*** required for empty pntr vec.
  let pvec = vector 0 to state(pntrCount) of PointerType(Null : nil)
  let pSpot := state(startPList)'cons(tl)

Used above; previous and next definitions.

*

<constructCode definition>+=
  for i = 1 to state(pntrCount) do
  begin
    pvec(i) := pSpot'cons(hd)
    pSpot := pSpot'cons(tl)
  end

Used above; previous and next definitions.

Now construct an instance of NCode that holds the constructed C code vector.

<constructCode definition>+=
  let codeType =10 ! this is a C code code vector
  let thisNCode = NCode(exactCVec,
      SM(getInfo)(state(symbols))(procInfo)'present(envVector),
      svec,
      pvec,
      scalarStart,
      frameSize,
      codeType)

Used above; previous and next definitions.

pass the new instance of thisNCode:codeObject back as the result. This will be used by magic.

<constructCode definition>+=
  magic(thisNCode)
end

Used above; previous definition.

*

readRawCode

<readRawCode definition>=
let readRawCode = proc(rawname : string ->*CPamInst)
begin
  <openCode definition>
  let ri = openCode(rawname)
  let fenv = makeReadEnv(ri)
  use fenv with
      endOfInput : proc(->bool);
      readByte : proc(->int) in
  begin
    let cursize := 4096
    let cv := vector 1 to cursize of 0
    let cvpos := 0
    <scan input and collect code vector>
    <return a vector trimmed down to exact size>
  end
end 

Defines readRawCode (links are to index).

Used above.

* openCode opens the code file as named by the input parameter, and checks that it is okay.

<openCode definition>=
let openCode = proc(filename : string -> file)
begin
  let file_error = proc(s,s1 : string); begin
    writeString("'nCannot " ++ s ++ " file " ++ s1 ++ "'n")
    abort()
  end
  let check_open = proc(F : file; s : string -> file); begin
    if F = nilfile do file_error("open",s)
    F
  end
  check_open(open(filename,0),filename)
end

Defines openCode (links are to index).

Used above.

* Collecting the code from the read environment is straightforward, just read bytes and store them in the code vector. The only complication arises if the code vector is not long enough. In that case, we double the size, copy across the part read so far, and continue.

<scan input and collect code vector>=
while ~ endOfInput() do begin
  cvpos := cvpos+1
  if cvpos > cursize do begin
    cursize := 2*cursize
    cv := vector 1 to cursize using
      proc(n:int->int); if n<cvpos then cv(n) else 0
  end
  cv(cvpos) := readByte()
end

Used above.

* Having read all the bytes, we now want to return a code vector that is exactly long enough, and with the values cast into CPam instructions.

<return a vector trimmed down to exact size>=
vector 1 to cvpos using 
    proc(n:int->CPamInst); CPamInst(pam:cv(n))

Used above.

*

exportAny.N

<exportAny.N>=
! Dependencies : -t boot 
project PS() as root onto env :
use root with Error,Library : env in
  use Library with 
      Arithmetical,IO,String,Vector : env ;
      getImplementation : proc( string -> env ) in
    use Arithmetical with 
        bitwiseAnd,bitwiseOr,shiftLeft,shiftRight : proc( int,int -> int);
        maxint :                                    int;
        epsilon,maxreal,pi :                        real in 
    use IO with PrimitiveIO : env in
      use PrimitiveIO with close :      proc( file -> int ) ;
                     create :     proc( string,int -> file ) ;
                     seek :       proc( file,int,int -> int ) ;
                     setByte :    proc( int,int,int -> int ) ;
                     writeBytes : proc( file,*int,int,int -> int ) in
    use String with asciiToString : proc( int -> string );
                length :        proc( string -> int );
                stringToAscii : proc( string -> int ) in
    use Vector with lwb,upb : proc[t]( *t -> int ) in
    use getImplementation( "wizard" ) with CompilerImplementation : env in
      use CompilerImplementation with Passes : env in
        use Passes with CPamCaseCG : env in
          use CPamCaseCG with Magic : env in
            use Magic with exportAny : proc( string,any ) in

begin
  let exportError = proc( filename : string ; data : any ; s : string )
  use Error with System : env in
    use System with exportAny : proc( string,any,string ) in
      exportAny( filename,data,s )

  <exportAny type checking>
  <exportAny versions>
  <exportAny constants>
  <exportAny Code Planting>
end
default : {}
?

This code is written to a file (or else not used).

<exportAny type checking>=
let VOIDproc =
  begin
    let PROC = splitAny( any( proc() ; {} ) )( tr )
    let eqTypeRep = getEqTypeRep()
    proc( tr : TypeRep -> bool )
      eqTypeRep( PROC,tr )
  end

Used above.

<exportAny versions>=
let magicNo =
  begin
    let p1 = shiftLeft( 15,28 )
    let p2 = shiftLeft( 5,24 )
    let p3 = shiftLeft( 12,20 )
    let p4 = shiftLeft( 1,16 )
    let top = bitwiseOr( p1,p2 + p3 + p4 )
      top + 9 !*** Version 9 for PamCase
  end
  let npcMagic = 6

Used above.

<exportAny constants>=
let lower24 = shiftLeft( 1,24 ) - 1         !*** Bits 0-23.
let headerBits = shiftLeft( 144,24 )        !*** Bin - 10010000 << 24 places.

Used above.

<exportAny Code Planting>=
exportAny := proc( filename : string ; dataToDump : any )
  begin          
    <exportAny Code Planting: Global Vars>
    <exportAny Code Planting: File Handling>
    <exportAny Code Planting: Output Procs>
    <exportAny Code Planting: Remember where objects are>
    <exportAny Code Planting: The generic dump Object>  
    <exportAny Code Planting: Put out objects in root object>
    <exportAny Code Planting: Root Object Planting>
    <exportAny Code Planting: Plant data placing pointers in correct place>
    <exportAny Code Planting: The Main Body>
  end

Used above.

<exportAny Code Planting: Global Vars>=
let nilAddr :=      0
let nullstrAddr :=  0
let nullfileAddr := 0
let codeSize :=     0
let noObjects :=    0
let stdOut :=       nilfile

Used above.

<exportAny Code Planting: File Handling>=
let CreateCode = proc( filename : string  -> file )
  begin
    let F = create( filename,493 )
    if F = nilfile do exportError( filename,dataToDump,"Cannot create file" )
    F
  end

Used above.

<exportAny Code Planting: Output Procs>=
let boutl = 
  begin
    let buff := vector 0 to 1 of 0
    proc( n : int )
      begin
        buff( 0 ) := n
        let res := writeBytes( stdOut,buff,0,4 )
      end
  end
let boutd = proc( r : real )
  begin
    let halfs = fiddleR( r )
    for i = lwb[ int ]( halfs ) to upb[ int ]( halfs ) do boutl( halfs( i ) )
  end
let outputStInfo = proc( rootAddr : int )
  begin
    let s = seek( stdOut,0,0 )
    boutl( magicNo )
    boutl( codeSize )
    boutl( noObjects )
    boutl( rootAddr )
    boutl( npcMagic )
  end
let heapHeader = proc( noPntrs,objLength : int -> int )
  !*** Put out the header for an object, returns address of start of header.
  begin
    noObjects := noObjects + 1
    boutl( 0 ) !*** Fred's prefix word - poms black magic hex.
    let saveAddr = codeSize + 4 !*** This is really the start - honest.
    codeSize := codeSize + ( objLength + 1 ) * 4
      !*** size + object size + poms black magic hex.
    boutl( bitwiseOr( headerBits,noPntrs ) ) !*** noPntrs and mark bits.
    boutl( objLength ) !*** Output object length.
    saveAddr
  end
let Seek = proc( f : file ; index,key : int )
  !*** Seek relative to end of file header.
  { let t = seek( f,index + 20,key ) }
let outputObj = proc ( nopntrs,size : int -> int )
  begin
    let pid = heapHeader(nopntrs,size) !*** Header etc. put out by heapHeader.
    for i = 1 to nopntrs do 
      !*** Some space holding stuff - filled in later.
      boutl( nilAddr )                 !*** nil for the pointers.
    for i = nopntrs + 1 to size - 2 do 
      !*** Some space holding stuff - filled in later.
      boutl( 0 )                       !*** zero for the scalars.
    pid
  end
let WriteIntAt = proc( pid,index,theint : int )
  begin
    let filePosn = codeSize            !*** Save where we are in the file.
    Seek( stdOut,pid + 4 * index,0 )   !*** Seek to the new position.
    boutl( theint )                    !*** Write out the int.
    Seek( stdOut,filePosn,0 )          !*** Back to where we were in the file.
  end
let WriteBoolAt = proc( pid,index : int ; thebool : bool )
  begin
    let filePosn = codeSize            !*** Save where we are in the file.
    Seek( stdOut,pid + 4 * index,0 )   !*** Seek to the new position.
    if thebool then boutl( 1 )         !*** Write out the int.
    else boutl( 0 )
    Seek( stdOut,filePosn,0 )          !*** Back to where we were in the file.
  end

Used above.

<exportAny Code Planting: Remember where objects are>=
rec type list is       
  variant( more : nullToAddr ; tip : null ) &
  nullToAddr is structure( pointer : null ; address : int ; next : list )
let remembered := list( tip : nil )
let checkAlready = proc( pointer : null -> int )
  begin
    let l := remembered
    let addr := -1
    while l is more and addr = -1 do
      begin
        let next = l'more
        if next( pointer ) = pointer do addr := next( address )
        l := next( next )
      end
    addr
  end
let Remember = proc( pointer : null ; address : int )
  remembered := list( more : nullToAddr( pointer,address,remembered ) )

Used above.

<exportAny Code Planting: The generic dump Object>=
rec let dumpObject = proc( pointer : null -> int )
  !*** Dumps the object returns the file address.
  begin
    let checkit = checkAlready( pointer )
    if checkit ~= -1 then checkit 
    else
      begin
        let size = lookupInt( pointer,1 ) !*** Get the size of the object.
        let numPntrs = bitwiseAnd( lookupInt( pointer,0 ),lower24 )
        let addr = outputObj( numPntrs,size )
        Remember( pointer,addr )
        for i = 1 to numPntrs do
          WriteIntAt( addr,i + 1,dumpObject( lookupPntr( pointer,i + 1 ) ) )
        for i = numPntrs + 1 to size - 2 do
          WriteIntAt( addr,i + 1,lookupInt( pointer,i + 1 ) )
        addr
      end
  end

Used above.

<exportAny Code Planting: Put out objects in root object>=
let outputNil = proc() !*** Put out nil.
  begin
    nilAddr := heapHeader( 0,2 )
    Remember( nil,nilAddr )
  end
let outputNullstr = proc() !*** The value nullstring.
  begin
    let struc = splitAny( any( "" ) )
    nullstrAddr := dumpObject( struc( pointer ) )
  end
let outputNullfile = proc() !*** The nilfile value.
  begin
    let struc = splitAny( any( nilfile ) )
    nullfileAddr := dumpObject( struc( pointer ) )
  end
let outputNullImage = proc( -> int ) !*** The nilimage value.
  begin
    let struc = splitAny( any( nilimage ) )
    dumpObject( struc( pointer ) )
  end
let outputCharsVector = proc( -> int )
  begin
    let charVec = vector 0 to 127 of ""
    for i = 0 to 127 do charVec( i ) := asciiToString( i ) 
      !*** Load the single characters.
    let struc = splitAny( any( charVec ) )
    dumpObject( struc( pointer ) ) !*** Plant the string vector.
  end
let outputFileVec = proc( -> int )
  begin
    let ofv = vector 1 to 64 of nilfile
    let struc = splitAny( any( ofv ) )   
    let saveAddr = dumpObject( struc( pointer ) )
    saveAddr
  end

Used above.

<exportAny Code Planting: Root Object Planting>=
!** This needs updating eventually to be consistent with release 2.0 root objects.
!** However, it is ok for the moment.  Quintin 26/10/94
let outputRootObj = proc( -> int )
  begin
    let chVec = outputCharsVector()       !*** The single characters.
    let nullimageAddr = outputNullImage() !*** The value nullimage.
    let fileVec = outputFileVec()         !*** The open file descriptor vector.
    let thisAddress = heapHeader( 22,34 ) !*** Root object header.
    boutl( nilAddr )        !*** The value nil - should be the TYPE !
    boutl( nilAddr )        !*** Startup procedure pointer env.
    boutl( nilAddr )        !*** Startup procedure scalar env.
    boutl( nilAddr )        !*** Persistent root.
    boutl( nullfileAddr )   !*** nullfile.
    boutl( nullstrAddr )    !*** nilstring.
    boutl( chVec )          !*** Characters vector.
    boutl( nullimageAddr )  !*** nullfile.
    boutl( nilAddr )        !*** Code vector for the error procedure.
    boutl( nilAddr )        !*** Static link for the error procedure.
    boutl( nilAddr )        !*** Event handling procedures.
    boutl( nilAddr )        !*** Error handling procedures.
    boutl( fileVec )        !*** Vector of open files.
    boutl( nilAddr )        !*** Code vector for type checking procedure.
    boutl( nilAddr )        !*** Static link for type checking procedure.
    boutl( nilAddr )        !*** Types module.
    boutl( nilAddr )        !*** Variant checking workspace.
    boutl( nilAddr )        !*** Variant checking workspace.
    boutl( nilAddr )        !*** Variant checking workspace.
    boutl( nilAddr )        !*** Variant checking workspace.
    boutl( nilAddr )        !*** Pointer to currently executing thread's throb.
    boutl( nilAddr )        !*** Pointer to list of throbs.
    boutl( 0 )              !*** nextThreadId.
    boutl( 0 )              !*** Process lockword.
    boutl( maxint )         !*** maxint.
    boutd( maxreal )        !*** maxreal.
    boutd( pi )             !*** pi.
    boutd( epsilon )        !*** epsilon.
    boutl( npcMagic )       !*** Magic number for saving the stable store.
    thisAddress
  end

Used above.

<exportAny Code Planting: Plant data placing pointers in correct place>=
let outputData = proc( rootAddr : int )
  begin
    !*** Split up the data into a null, typeRep & 2 ints.
    let struc = splitAny( dataToDump ) 
    if VOIDproc( struc( tr ) ) then !*** Is the data actually a program?
      begin
        let wrapper = struc( pointer ) !*** Dump the code and static link.
        let cvecAddr = dumpObject( lookupPntr( wrapper,2 ) )
        let slinkAddr = dumpObject( lookupPntr( wrapper,3 ) )
        !*** Setup the root object to look like a program.
        WriteIntAt( rootAddr,3,cvecAddr ) 
        WriteIntAt( rootAddr,4,slinkAddr )
      end
    else
      begin
        !*** Make a wrapper to hold the any.
        let wrapper = makeObject( 6,2 ) 
        !*** Insert the any's components into the wrapper.
        assignPntr( wrapper,2,struc( pointer ) ) 
        let trep = splitAny( any( struc( tr ) ) )( pointer )
        assignPntr( wrapper,3,trep )
        assignInt( wrapper,4,struc( branch ) )
        assignInt( wrapper,5,struc( padding ) )
        !*** Put the wrapper in the root object's data field.
        let dataAddr = dumpObject( wrapper )                    
        WriteIntAt( rootAddr,5,dataAddr )
      end
  end

Used above.

<exportAny Code Planting: The Main Body>=
stdOut := CreateCode( filename )
if stdOut ~= nilfile do
  begin
    for i = 1 to 5 do boutl( 0 )     !*** Make space for header.
    codeSize := 0                    !*** Reset codeSize.
    outputNil()                      !*** Put out nil.
    outputNullstr()                  !*** The value nullstring.
    outputNullfile()                 !*** The value nullfile.
    let rootAddr = outputRootObj()   !*** outputRootObject information.
    outputData( rootAddr )           !*** Plant the pointers to the data.
    outputStInfo( rootAddr )         !*** Put out std info.
    let throw := close( stdOut )
  end

Used above.

*

magic.N

<magic.N>=
! Dependencies : -t boot -t cPamCaseCGPass
! Modifications:
!   941030 ajh     write code type flag into code object (requires
!                  NCode to have field `codeType')
project PS() as root onto env :
  use root with Error,Library : env in
    use Library with getImplementation : proc( string -> env ) in
      use getImplementation( "wizard" ) with CompilerImplementation : env in
        use CompilerImplementation with Passes,Errors : env in
          use Errors with Compilation : env in
            use Compilation with Error : proc( string ) in
          use Passes with CPamCaseCG : env in
            use CPamCaseCG with CGConstants, Magic : env in
              use CGConstants with cvecPntrOverhead : int in
              use Magic with magic : proc( NCode -> CodeObject ) in
<magic definition>
default : {}
?

This code is written to a file (or else not used).

magic: Construct the code vector object

<magic definition>=
magic := proc(compilerNCode : NCode -> CodeObject)
  begin
    <magic: Calculate the size of the cv object>
    <magic: Create the new object>
    <magic: Copy in the pointer literals>
    <magic: Copy the ncode code vector into the real code vector>
    !** Pad the final word if required (not in CPamCase)
    <magic: Copy in the scalar literals>
    <magic: Copy in the code flag and frame size>
    !****** Make a 'null' view of the env vector
    let envAsNull = splitAny( any( compilerNCode( envVec ) ) )( pointer )
    !****** Return the null code vector and env template
    CodeObject( cvec,envAsNull )
end

Used above.

<magic: Calculate the size of the cv object>=
let pointers = compilerNCode(pntrVec)
let noOfPntrs = upb[PointerType](pointers)
!** start at zero - which is a dummy element
let scalars = compilerNCode(scalarVec)
let noOfScalars = upb[int](scalars) !** ditto
let cCVec = compilerNCode(codeVec)
let noOfCVecInts = upb[CPamInst](cCVec)
let noOfCVecWords = (noOfCVecInts)  !* used to have byte count expr
let cvSize = 2 +                    !* Header and size
  cvecPntrOverhead   +   !* Alt cvec, source and spare pntr
  noOfPntrs +
  noOfCVecWords +        !* No of cvec words using unsigned
  noOfScalars +          !* ints for instrs and parameters
  2                      !* Code Flag and Frame size

Used below.

<magic: Create the new object>=
let cvec = makeObject( cvSize,noOfPntrs + cvecPntrOverhead )
for i = 2 to 4 do assignPntr( cvec,i,nil )

Used below.

Before the pointer literals are copied, they must first be converted into nulls

<magic: Copy in the pointer literals>=
let codeStart = 2+cvecPntrOverhead+noOfPntrs
for i = 2+cvecPntrOverhead to codeStart-1 do
  project pointers(i-cvecPntrOverhead-1) as thePntr onto
    Null    : assignPntr(cvec,i,thePntr)
    String  : assignString(cvec,i,thePntr)
    TypeRep : assignPntr(cvec,i,splitAny(any(thePntr))(pointer))
    default     : Error( "impossible branch in a PointerType in magic" )

Used below.

<magic: Copy the ncode code vector into the real code vector>=
let nextCVecWord := 0
for i = 1 to noOfCVecInts do
  begin
    nextCVecWord := bitwiseOr(shiftLeft(nextCVecWord,8),cCVec(i)'pam)
    if i rem 4 = 0 do
      begin
        assignInt( cvec,codeStart - 1 + i div 4,nextCVecWord )
        nextCVecWord := 0
      end
  end

Used below.

<magic: Copy in the scalar literals>=
!** CPamCase should have none ...
let scalarBase = codeStart + noOfCVecWords 
for i = scalarBase to scalarBase + noOfScalars - 1 do
  assignInt( cvec,i,scalars( i - scalarBase + 1 ) )

Used below.

<magic: Copy in the code flag and frame size>=
assignInt(cvec, scalarBase+noOfScalars, compilerNCode(codeType))
assignInt(cvec, scalarBase+noOfScalars+1, compilerNCode(frameSize))

Used below.

Index

• <Magic ls>: D1
• <Makefile>: D1
• <cCompile definition>: U1, D2
• <cCompile.N>: D1
• <compute macro label>: U1, D2
• <compute macro name>: U1, D2
• <compute macro parameters>: U1, D2
• <constructCode definition>: U1, D2, D3, D4, D5, D6, D7, D8, D9
• <doCompile definition>: U1, D2, D3, D4, D5, D6
• <exportAny Code Planting>: U1, D2
• <exportAny Code Planting: File Handling>: U1, D2
• <exportAny Code Planting: Global Vars>: U1, D2
• <exportAny Code Planting: Output Procs>: U1, D2
• <exportAny Code Planting: Plant data placing pointers in correct place>: U1, D2
• <exportAny Code Planting: Put out objects in root object>: U1, D2
• <exportAny Code Planting: Remember where objects are>: U1, D2
• <exportAny Code Planting: Root Object Planting>: U1, D2
• <exportAny Code Planting: The Main Body>: U1, D2
• <exportAny Code Planting: The generic dump Object>: U1, D2
• <exportAny constants>: U1, D2
• <exportAny type checking>: U1, D2
• <exportAny versions>: U1, D2
• <exportAny.N>: D1
• <initMagic.N>: D1
• <int2str definition>: U1, D2
• <macroString definition>: U1, D2
• <magic: Calculate the size of the cv object>: U1, D2
• <magic: Copy in the code flag and frame size>: U1, D2
• <magic: Copy in the pointer literals>: U1, D2
• <magic: Copy in the scalar literals>: U1, D2
• <magic: Copy the ncode code vector into the real code vector>: U1, D2
• <magic: Create the new object>: U1, D2
• <magic definition>: U1, D2
• <magic.N>: D1
• <openCode definition>: U1, D2
• <pattern matching procedure definition>: U1, D2
• <readRawCode definition>: U1, D2
• <return a vector trimmed down to exact size>: U1, D2
• <scan input and collect code vector>: U1, D2
• <write macro file header information>: U1, D2
• <write macro file macro calls>: U1, D2
• <write macro file trailer information>: U1, D2
• <writeMacroFile definition>: U1, D2

• macroString: U1, D2, U3
• openCode: U1, U2, U3, D4
• readRawCode: U1, U2, D3