🚀 go-pugleaf

Submitted-by: Albert Chin-A-Young (26285659t@servax.fiu.edu)
Posting-number: Volume 1, Source:73
Archive-name: utility/gs/disassem/coff/part08
Architecture: ONLY_2gs
Version-number: 1.1


=structure.s
- lst off
-
-* UNIX coff utility
-* data structure routines
-*
-* 1990-1992, tao Developer Project
-
- rel
- xc
- xc
- mx %00
-
- put coff.h ;global defines
- put x.data ;external data definitions
- put x.general ;external general definitions
- put x.gsos ;external GS/OS i/o definitions
- put x.output ;external output definitions
-
- put 4/gsos.h ;GS/OS defines
- put 4/memory.h ;memory manager defines
- put 4/resource.h ;resouce manager defines
- put 4/texttool.h ;text tool defines
-
- use coff.mac ;macro definitions
- use 4/datatype.mac ;HLL data types
-
-
-**************************************************
-* add label name and expression evaluation to    *
-* label stack.                                   *
-* ---------------------------------------------- *
-* (input)                                        *
-*  long - handle to replacement label name.      *
-*  long - handle to label expression.            *
-*  word - label type.                            *
-**************************************************
-add_label ent
-]type = $e0 ;type of label
-]name_handle = $e2 ;handle to label name
-]expr_handle = $e6 ;expression label evaluates to
-]node_handle = $ea ;label node
-]node_ptr = $ee
-]label_last_handle = $f2 ;handle to first element in linked list
-]label_last_ptr = $f6
-
- pla ;return address
- plx
- stx ]type
- plx
- ply
- stx ]expr_handle
- sty ]expr_handle+2
- plx
- ply
- stx ]name_handle
- sty ]name_handle+2
- pha ;push return address back on stack
-
- pha ;long - result
- pha
- pea #0 ;long - block size
- pea #18
- lda userID ;word - user ID of block
- pha
- pea #attrNoSpec ;word - block attributes
- pha ;long - start of block
- pha
- _NewHandle
- plx
- ply
- stx ]node_handle
- sty ]node_handle+2
- lda []node_handle]
- sta ]node_ptr
- ldy #2
- lda []node_handle],y
- sta ]node_ptr+2
-
- lda @label+`last
- ora @label+`last+2
- bne :0
- ldx ]node_handle
- ldy ]node_handle+2
- stx @label+`next
- sty @label+`next+2
- ldy #`prev ;make first previous node NULL
- lda #NULL
- sta []node_ptr],y
- ldy #`prev+2
- sta []node_ptr],y
- bra :1
-
-:0 ldx @label+`last
- ldy @label+`last+2
- stx ]label_last_handle
- sty ]label_last_handle+2
- lda []label_last_handle]
- sta ]label_last_ptr
- ldy #2
- lda []label_last_handle],y
- sta ]label_last_ptr+2
- ldy #`next ;make next label after last current node
- lda ]node_handle
- sta []label_last_ptr],y
- ldy #`next+2
- lda ]node_handle+2
- sta []label_last_ptr],y
- ldy #`prev ;make previous node last node
- lda ]label_last_handle
- sta []node_ptr],y
- ldy #`prev+2
- lda ]label_last_handle+2
- sta []node_ptr],y
-
-:1 ldy #`label_name ;store label name
- lda ]name_handle
- sta []node_ptr],y
- ldy #`label_name+2
- lda ]name_handle+2
- sta []node_ptr],y
- ldy #`expr_name ;store expression evaluation string
- lda ]expr_handle
- sta []node_ptr],y
- ldy #`expr_name+2
- lda ]expr_handle+2
- sta []node_ptr],y
- ldy #`type ;store label type
- lda ]type
- sta []node_ptr],y
- ldy #`next ;make next node NULL
- lda #NULL
- sta []node_ptr],y
- ldy #`next+2
- sta []node_ptr],y
-
- ldx ]node_handle ;make new last node
- ldy ]node_handle+2
- stx @label+`last
- sty @label+`last+2
- rts
-
-
-**************************************************
-* delete labels from label array.                *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - delete LOCAL or GLOBAL labels.            *
-**************************************************
-delete_labels ent
-]label_type = $e0 ;type of label to delete
-]label_handle = $e2 ;handle to current label
-]label_ptr = $e6
-]prev_label_handle = $ea ;handle to previous label
-]prev_label_ptr = $ee
-
- sta ]label_type
-
- ldx #^@label ;make first label previous label. first
- ldy #@label ;label structure is header node.
- stx ]prev_label_ptr+2
- sty ]prev_label_ptr
-
- stz @label+`last ;re-initialize last node
- stz @label+`last+2
- ldx @label+`next
- ldy @label+`next+2
- stx ]label_handle
- sty ]label_handle+2
- lda []label_handle]
- sta ]label_ptr
- ldy #2
- lda []label_handle],y
- sta ]label_ptr+2
- lda ]label_handle
- ora ]label_handle+2
- bne :delete_label
- rts
-
-:delete_label ldy #`type
- lda []label_ptr],y
- cmp ]label_type
- bne :0
- ldy #`next
- lda []label_ptr],y
- sta []prev_label_ptr],y
- ldy #`next+2
- lda []label_ptr],y
- sta []prev_label_ptr],y
- pei ]label_handle+2
- pei ]label_handle
- _DisposeHandle
- bra :next_label
-
-:0 ldx ]label_handle
- ldy ]label_handle+2
- stx @label+`last
- sty @label+`last+2
- stx ]prev_label_handle
- sty ]prev_label_handle+2
- lda []prev_label_handle]
- sta ]prev_label_ptr
- ldy #2
- lda []prev_label_handle],y
- sta ]prev_label_ptr+2
-
-:next_label ldy #`next ;prepare to examine next label in
- lda []label_ptr],y ;linked list
- sta ]label_handle
- ldy #`next+2
- lda []label_ptr],y
- sta ]label_handle+2
- lda []label_handle]
- sta ]label_ptr
- ldy #2
- lda []label_handle],y
- sta ]label_ptr+2
- lda ]label_handle ;end if at end of linked list
- ora ]label_handle+2
- bne :delete_label
- rts
-
-
-**************************************************
-* delete @expr_list stack.                       *
-**************************************************
-delete_expr_list ent
-]list_lo_handle = $f0
-]list_hi_handle = $f4
-]list_lo_ptr = $f8
-]list_hi_ptr = $fc
-
- ldx @expr_list+`lo
- ldy @expr_list+`lo+2
- stx ]list_lo_handle
- sty ]list_lo_handle+2
- ldx @expr_list+`hi
- ldy @expr_list+`hi+2
- stx ]list_hi_handle
- sty ]list_hi_handle+2
- lda []list_lo_handle]
- sta ]list_lo_ptr
- ldy #2
- lda []list_lo_handle],y
- sta ]list_lo_ptr+2
- lda []list_hi_handle],y
- sta ]list_hi_ptr
- ldy #2
- lda []list_hi_handle],y
- sta ]list_hi_ptr+2
-
- ldy @expr_list+`size
-:delete_list phy
- lda []list_hi_ptr],y
- pha
- lda []list_lo_ptr],y
- pha
- _DisposeHandle
- ply
- dey
- bne :delete_list
-
- pei ]list_lo_handle+2
- pei ]list_lo_handle
- _DisposeHandle
- pei ]list_hi_handle+2
- pei ]list_hi_handle
- _DisposeHandle
- rts
-
-
-**************************************************
-* match operator value with its string           *
-* representation.                                *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - operator value.                           *
-* (output)                                       *
-*  x - HOW of string representing operator.      *
-*  y - LOW of string representing operator.      *
-**************************************************
-find_operator ent
-
- ldx #0 ;default is NULL string
- ldy #0
-
- cmp #ADD
- bne :sub
- ldx #^:add_str
- ldy #:add_str
- rts
-:sub cmp #SUB
- bne :mul
- ldx #^:sub_str
- ldy #:sub_str
- rts
-:mul cmp #MUL
- bne :div
- ldx #^:mul_str
- ldy #:mul_str
- rts
-:div cmp #DIV
- bne :mod
- ldx #^:div_str
- ldy #:div_str
- rts
-:mod cmp #MOD
- bne :negation
- ldx #^:mod_str
- ldy #:mod_str
- rts
-:negation cmp #NEGATION
- bne :bit_shift
- ldx #^:negation_str
- ldy #:negation_str
- rts
-:bit_shift cmp #BIT_SHIFT
- bne :and
- ldx #^:bit_shift_str
- ldy #:bit_shift_str
- rts
-:and cmp #AND
- bne :or
- ldx #^:and_str
- ldy #:and_str
- rts
-:or cmp #OR
- bne :eor
- ldx #^:or_str
- ldy #:or_str
- rts
-:eor cmp #EOR
- bne :not
- ldx #^:eor_str
- ldy #:eor_str
- rts
-:not cmp #NOT
- bne :less_equal
- ldx #^:not_str
- ldy #:not_str
- rts
-:less_equal cmp #LESS_EQUAL
- bne :greater_equal
- ldx #^:less_equal_str
- ldy #:less_equal_str
- rts
-:greater_equal cmp #GREATER_EQUAL
- bne :not_equal
- ldx #^:greater_equal_str
- ldy #:greater_equal_str
- rts
-:not_equal cmp #NOT_EQUAL
- bne :less
- ldx #^:not_equal_str
- ldy #:not_equal_str
- rts
-:less cmp #LESS
- bne :greater
- ldx #^:less_str
- ldy #:less_str
- rts
-:greater cmp #GREATER
- bne :equal
- ldx #^:greater_str
- ldy #:greater_str
- rts
-:equal cmp #EQUAL
- bne :logical_and
- ldx #^:equal_str
- ldy #:equal_str
- rts
-:logical_and cmp #LOGICAL_AND
- bne :inclusive_or
- ldx #^:logical_and_str
- ldy #:logical_and_str
- rts
-:inclusive_or cmp #INCLUSIVE_OR
- bne :exclusive_or
- ldx #^:inclusive_or_str
- ldy #:inclusive_or_str
- rts
-:exclusive_or cmp #EXCLUSIVE_OR
- bne :complement
- ldx #^:exclusive_or_str
- ldy #:exclusive_or_str
- rts
-:complement cmp #COMPLEMENT
- bne :label_length
- ldx #^:complement_str
- ldy #:complement_str
- rts
-:label_length cmp #LABEL_LENGTH
- bne :end
- ldx #^:label_length_str
- ldy #:label_length_str
-:end rts
-
-:add_str strl '+'
-:sub_str strl '-'
-:mul_str strl '*'
-:div_str strl '/'
-:mod_str strl '%%'
-:negation_str strl '~'
-:bit_shift_str strl '|'
-:and_str strl '&&'
-:or_str strl '||'
-:eor_str strl '.eor.'
-:not_str strl '!'
-:less_equal_str strl '<='
-:greater_equal_str strl '>='
-:not_equal_str strl '<>'
-:less_str strl '<'
-:greater_str strl '>'
-:equal_str strl '='
-:logical_and_str strl '&'
-:inclusive_or_str strl '.ior.'
-:exclusive_or_str strl '.beor.'
-:complement_str strl '.bnot.'
-:label_length_str strl 'length ('
-
-
-**************************************************
-* match label name with expression name.         *
-* ---------------------------------------------- *
-* (input)                                        *
-*  x - LOW of expression name.                   *
-*  y - HOW of expression name.                   *
-* (output)                                       *
-*  x - HOW of label name (NULL if not found).    *
-*  y - LOW of label name (NULL if not found).    *
-**************************************************
-match_label ent
-]expr_ptr = $f0 ;expression name string
-]label_handle = $f4 ;linked list of labels
-]label_ptr = $f8
-]expr_name_handle = $fc ;expression evaluation
-]expr_name_ptr = $fc
-]label_name_handle = $fc ;label name
-
- stx ]expr_ptr
- sty ]expr_ptr+2
-
- lda @label+`next ;fail if no labels in list
- ora @label+`next+2
- beq :fail
- ldx @label+`next
- ldy @label+`next+2
- stx ]label_handle
- sty ]label_handle+2
-:loop lda []expr_ptr]
- sta :expr_len
- lda []label_handle]
- sta ]label_ptr
- ldy #2
- lda []label_handle],y
- sta ]label_ptr+2
- ldy #`expr_name
- lda []label_ptr],y
- sta ]expr_name_handle
- ldy #`expr_name+2
- lda []label_ptr],y
- sta ]expr_name_handle+2
- ldy #2
- lda []expr_name_handle],y
- tay
- lda []expr_name_handle]
- sta ]expr_name_ptr
- sty ]expr_name_ptr+2
-
- lda []expr_name_ptr] ;no comparison if lengths different
- cmp :expr_len
- bne :end_loop
-
- ldy #2 ;compare strings
- shorta
-:0 lda []expr_name_ptr],y
- cmp []expr_ptr],y
- bne :end_loop
- iny
- dec :expr_len
- bne :0
- longa
-
- ldy #`label_name
- lda []label_ptr],y
- sta ]label_name_handle
- ldy #`label_name+2
- lda []label_ptr],y
- sta ]label_name_handle+2
- lda []label_name_handle]
- tax
- ldy #2
- lda []label_name_handle],y
- tay
- rts
-
-:end_loop longa
- ldy #`next
- lda []label_ptr],y
- sta ]label_handle
- ldy #`next+2
- lda []label_ptr],y
- sta ]label_handle+2
- ora ]label_handle
- bne :loop
-
-:fail ldx #NULL
- ldy #NULL
- rts
-
-:expr_len dw 0 ;length of expression string
-
-
-**************************************************
-* push value onto @expr_list stack.              *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - expression value.                         *
-*  x - LOW of expression label.                  *
-*  y - HOW of expression label.                  *
-**************************************************
-push_expr_list ent
-]list_lo_handle = $e0
-]list_hi_handle = $e4
-]list_lo_ptr = $e8
-]list_hi_ptr = $ec
-]expr_value = $f0 ;expression value
-]expr_handle = $f2 ;handle to expression name
-]expr_ptr = $f6
-
- sta ]expr_value
- stx ]expr_handle
- sty ]expr_handle+2
-
- txa ;alloc handle if operator is being
- ora ]expr_handle+2 ;pushed on stack
- bne :0
-
- pha ;long - result
- pha
- pea #0 ;long - block size
- pea #2
- lda userID ;word - user ID of block
- pha
- pea #attrNoCross ;word - block attributes
- pha ;long - start of block
- pha
- _NewHandle
- plx
- ply
- stx ]expr_handle
- sty ]expr_handle+2
-
-:0 lda []expr_handle]
- sta ]expr_ptr
- ldy #2
- lda []expr_handle],y
- sta ]expr_ptr+2
- lda ]expr_value
- sta []expr_ptr]
-
- lda @expr_list+`size
- inc
- asl
- pea #0
- pha
- pea #0
- pha
- ldx @expr_list+`lo
- ldy @expr_list+`lo+2
- phy
- phx
- _SetHandleSize
- ldx @expr_list+`hi
- ldy @expr_list+`hi+2
- phy
- phx
- _SetHandleSize
-
- ldx @expr_list+`lo
- ldy @expr_list+`lo+2
- stx ]list_lo_handle
- sty ]list_lo_handle+2
- ldx @expr_list+`hi
- ldy @expr_list+`hi+2
- stx ]list_hi_handle
- sty ]list_hi_handle+2
- lda []list_lo_handle]
- sta ]list_lo_ptr
- ldy #2
- lda []list_lo_handle],y
- sta ]list_lo_ptr+2
- lda []list_hi_handle]
- sta ]list_hi_ptr
- ldy #2
- lda []list_hi_handle],y
- sta ]list_hi_ptr+2
-
- lda @expr_list+`size
- asl
- tay
- lda ]expr_handle
- sta []list_lo_ptr],y
- lda ]expr_handle+2
- sta []list_hi_ptr],y
- inc @expr_list+`size
- rts
-
-
-**************************************************
- sav structure.l
=general.s
- lst off
-
-* UNIX coff utility
-* general routines
-*
-* 1990-1992, tao Developer Project
-
- rel
- xc
- xc
- mx %00
-
- put coff.h ;global defines
- put x.data ;data externals
- put x.gsos ;GS/OS i/o externals
- put x.tool ;ToolBox, GS/OS, ROM externals
-
- put 4/gsos.h ;GS/OS defines
- put 4/memory.h ;memory manager defines
- put 4/resource.h ;resouce manager defines
- put 4/texttool.h ;text tool defines
- put 4/getopt.h ;getopt command-line option defines
- put 4/env.h ;run-time environment settings
-
- use coff.mac ;macro definitions
- use 4/datatype.mac ;HLL data types
- use 4/env.mac ;run-time environment macros
-
-
-FloatDecimal equ $00 ;input to @dec_form is float
-FixedDecimal equ $01 ;input to @dec_form is fixed
-
-;@dec_form data structure offsets
-`style equ $00 ;output style (FloatDecimal, FixedDecimal)
-`digits equ `style+2 ;number of significant digits
-
-;@decimal data structure offsets
-`sgn equ $00 ;sign of number
-`exp equ `sgn+2 ;exponent value
-`sig equ `exp+2
-
-
-**************************************************
-* store global command-line pointer to local     *
-* dp variables.                                  *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - offset into dp for where to store `lo,    *
-*      `hi pointers.                             *
-**************************************************
-dp_argv ent
-]argv_lo = $00 ;pointer to argv+`lo data
-]argv_hi = $04 ;pointer to argv+`hi data
-
- sta $fe ;offset into dp
- clc
- tdc
- tax ;save dp register
- adc $fe
- tcd
- lda argv+`lo
- sta ]argv_lo
- lda argv+`lo+2
- sta ]argv_lo+2
-
- lda argv+`hi
- sta ]argv_hi
- lda argv+`hi+2
- sta ]argv_hi+2
- txa ;restore dp register
- tcd
- rts
-
-
-**************************************************
-* display error messages.                        *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - error number.                             *
-*  x - possible parameter (depending on error).  *
-*  y - possible parameter (depending on error).  *
-**************************************************
-error ent
-]argv_lo = $f0
-]argv_hi = $f4
-]parm_ptr = $f8 ;pointer to parameter
-
- stx ]parm_ptr
- sty ]parm_ptr+2
- tax
- and #%11111111_00000000 ;get error type
- sta :parm_type
- txa
- and #%00000000_11111111 ;get error number
-
- pea #^error ;offset into ~error_msg for error string
- tax  ;bank address is program bank address
- lda ~error_msg,x ;for error message
- pha
- lda #]argv_lo
- jsr dp_argv
- jsr get_progname
-
- phy ;long - pointer to C-string
- phx
- _WriteCString
- pea #':'
- _WriteChar
- pea #' '
- _WriteChar
- _WriteCString
- lda :parm_type
- cmp #ERROR_STRING ;special case string parameter
- bne :error_value
- lda ]parm_ptr ;output usage information if no
- ora ]parm_ptr+2 ;added parameter
- beq :end
- pei ]parm_ptr+2
- pei ]parm_ptr
- _WriteCString
-:end bra :usage
-
-:error_value cmp #ERROR_LHEX_VALUE
- beq :lhex_value
- ldx ]parm_ptr
- ldy ]parm_ptr+2
- jsr print_long_dec
- bra :usage
-
-:lhex_value ldx ]parm_ptr
- ldy ]parm_ptr+2
- lda #8
- jsr print_fix_long_hex
-
-:usage put_cr
- lda []argv_lo] ;first argument on command-line is
- tax ;program name
- lda []argv_hi]
- tay
- jmp usage
-
-:parm_type UnsignedShort ;parmater type
-
-
-**************************************************
-* return pointer to program name string minus    *
-* path.                                          *
-* ---------------------------------------------- *
-* (output)                                       *
-*  x - LOW of pointer to program name.           *
-*  y - HOW of pointer to program name.           *
-**************************************************
-get_progname ent
-]argv_lo = $f0
-]argv_hi = $f4
-]progname = $fc
-
- lda #]argv_lo
- jsr dp_argv
- lda []argv_lo] ;first argument on command-line is
- sta ]progname ;program name
- lda []argv_hi]
- sta ]progname+2
-
- shorta
-:start_loop ldy #0
-:loop lda []progname],y
- beq :end
- cmp #'/'
- beq :separator
- cmp #':'
- beq :separator
- iny
- bra :loop
-:separator clc
- tya
- inc
- adc ]progname
- sta ]progname
- bcc :start_loop
- inc ]progname+2
- bra :start_loop
-
-:end longa
- ldx ]progname
- ldy ]progname+2
- rts
-
-
-**************************************************
-* check if character is a printing character.    *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - character to test.                        *
-* (output)                                       *
-*  c - set if non-printing character.            *
-**************************************************
-isprint ent
-
- cmp #' ' ;' ' to '~' is a printing character
- blt :non_printing
- cmp #'~'+1
- bge :non_printing
-:printing clc
- rts
-:non_printing sec
- rts
-
-
-**************************************************
-* make alpha characters in hex string lowercase. *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - number of characters in string.           *
-*  x - address of hex string in current bank.    *
-**************************************************
-lowercase_hex ent
-]str = $fe
-
- stx ]str
- dec
- tay
- shorta
-:loop lda (]str),y
- ora #%00100000 ;make lowercase
- sta (]str),y
- dey
- bpl :loop
- longa
- rts
-
-
-**************************************************
-* convert GSOS call number to equivalent name.   *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - call number.                              *
-* (output)                                       *
-*  x - LOW pointer to equivalent name.           *
-*  y - HOW pointer to equivalent name.           *
-*  c - set if call number not found.             *
-**************************************************
-name_GSOS ent
-]callnum = $f0 ;GSOS call number
-]offset = $f2 ;offset into ~gsos for call name
-
- sta ]callnum
- lsr
- lsr
- lsr
- lsr
- lsr
- lsr
- lsr
- lsr
- asl
- tax
- lda ~gsos,x
- beq :end ;call number undefined
- sta ]offset
- tay
-
- lda (]offset) ;get number of name equivalents
- tax
- iny
- iny
- sty ]offset
- ldy #2
-
-:loop lda (]offset)
- cmp ]callnum
- bne :next_name
- ldx ]offset
- inx
- inx
- ldy #^~gsos
- clc
- rts
-
-:next_name lda (]offset),y
- and #$ff ;get length of pStr-defined name
- clc
- adc #3
- adc ]offset
- sta ]offset
- dex
- bne :loop
-
-:end sec
- rts
-
-
-**************************************************
-* convert ROM address to equivalent name.        *
-* ---------------------------------------------- *
-* (input)                                        *
-*  x - LOW of ROM address.                       *
-*  y - HOW of ROM address.                       *
-* (output)                                       *
-*  x - LOW pointer to equivalent name.           *
-*  y - HOW pointer to equivalent name.           *
-*  c - set if call number not found.             *
-**************************************************
-name_ROM ent
-]rom_adr = $f0 ;ROM address
-]offset = $f4 ;offset into ~gsos for call name
-
- stx ]rom_adr
- sty ]rom_adr+2
- tya
- asl
- tay
- lda ~rom,y
- beq :end ;call number undefined
- sta ]offset
- lda ]rom_adr
- lsr
- lsr
- lsr
- lsr
- lsr
- lsr
- lsr
- lsr
- asl
- tay
- lda (]offset),y
- beq :end
- sta ]offset
- tay
-
- lda (]offset) ;get number of name equivalents
- tax
- iny
- iny
- sty ]offset
- ldy #2
-
-:loop lda (]offset)
- cmp ]rom_adr
- bne :next_name
- ldx ]offset
- inx
- inx
- ldy #^~rom
- clc
- rts
-
-:next_name lda (]offset),y
- and #$ff ;get length of pStr-defined name
- clc
- adc #3
- adc ]offset
- sta ]offset
- dex
- bne :loop
-
-:end sec
- rts
-
-
-**************************************************
-* convert ToolBox call number to equivalent      *
-* name.                                          *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - call number.                              *
-* (output)                                       *
-*  x - LOW pointer to equivalent name.           *
-*  y - HOW pointer to equivalent name.           *
-*  c - set if call number not found.             *
-**************************************************
-name_TOOL ent
-]toolnum = $f0 ;Toolbox call number
-]offset = $f2 ;offset into ~gsos for call name
-
- sta ]toolnum
- and #$ff
- asl
- tax
- lda #^~tool
- lda ~tool,x
- beq :end ;call number undefined
- sta ]offset
- tay
-
- lda (]offset) ;get number of name equivalents
- tax
- iny
- iny
- sty ]offset
- ldy #2
-
-:loop lda (]offset)
- cmp ]toolnum
- bne :next_name
- ldx ]offset
- inx
- inx
- ldy #^~tool
- clc
- rts
-
-:next_name lda (]offset),y
- and #$ff ;get length of pStr-defined name
- clc
- adc #3
- adc ]offset
- sta ]offset
- dex
- bne :loop
-
-:end sec
- rts
-
-
-**************************************************
-* output number as char decimal string.          *
-* ---------------------------------------------- *
-* (input)                                        *
-*  x - value to output.                          *
-* (output)                                       *
-*  a - number of characters output.              *
-**************************************************
-print_char_dec ent
-
- phx
- phx ;word - longint to convert
- pea #^char_dec_str ;long - pointer to output string
- pea #char_dec_str
- pea #3 ;word - length of string
- pea #FALSE ;word - unsigned number
- _Int2Dec
- plx
- bne :0
- ldx #2
- bra :2
-:0 ldx #$ffff
-:1 inx
- lda char_dec_str,x
- and #$ff
- cmp #' '
- beq :1
-:2 pea #^char_dec_str ;long - pointer to string
- pea #char_dec_str
- phx ;word - offset into text
- sec ;word - number of characters to print
- lda #3
- sbc 1,s
- sta :strlen
- pha
- _TextWriteBlock
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
-
- lda :strlen
- rts
-
-:strlen ds 2 ;number of characters output
-
-
-**************************************************
-* output number as short decimal string.         *
-* ---------------------------------------------- *
-* (input)                                        *
-*  x - value to output.                          *
-**************************************************
-print_short_dec ent
-
- phx
- phx ;word - longint to convert
- pea #^short_dec_str ;long - pointer to output string
- pea #short_dec_str
- pea #5 ;word - length of string
- pea #FALSE ;word - unsigned number
- _Int2Dec
- plx
- bne :0
- ldx #4
- bra :2
-:0 ldx #$ffff
-:1 inx
- lda short_dec_str,x
- and #$ff
- cmp #' '
- beq :1
-:2 pea #^short_dec_str ;long - pointer to string
- pea #short_dec_str
- phx ;word - offset into text
- sec ;word - number of characters to print
- lda #5
- sbc 1,s
- pha
- _TextWriteBlock
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* output number as long decimal string.          *
-* ---------------------------------------------- *
-* (input)                                        *
-*  x - LOW of value to output.                   *
-*  y - HOW of value to output.                   *
-**************************************************
-print_long_dec ent
-
- phy
- phx
- phy ;long - longint to convert
- phx
- pea #^long_dec_str ;long - pointer to output string
- pea #long_dec_str
- pea #10 ;word - length of string
- pea #FALSE ;word - unsigned number
- _Long2Dec
- pla
- ora 1,s
- plx
- cmp #0
- bne :0
- ldx #9
- bra :2
-:0 ldx #$ffff
-:1 inx
- lda long_dec_str,x
- and #$ff
- cmp #' '
- beq :1
-:2 pea #^long_dec_str ;long - pointer to string
- pea #long_dec_str
- phx ;word - offset into text
- sec ;word - number of characters to print
- lda #10
- sbc 1,s
- pha
- _TextWriteBlock
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* output signed number as char decimal string.   *
-* ---------------------------------------------- *
-* (input)                                        *
-*  x - value to output.                          *
-* (output)                                       *
-*  a - number of characters output.              *
-**************************************************
-print_char_sdec ent
-
- phx
- phx ;word - longint to convert
- pea #^char_dec_str ;long - pointer to output string
- pea #char_dec_str
- pea #4 ;word - length of string
- pea #TRUE ;word - signed number
- _Int2Dec
- plx
- bne :0
- ldx #3
- bra :2
-:0 ldx #$ffff
-:1 inx
- lda char_dec_str,x
- and #$ff
- cmp #' '
- beq :1
-:2 pea #^char_dec_str ;long - pointer to string
- pea #char_dec_str
- phx ;word - offset into text
- sec ;word - number of characters to print
- lda #4
- sbc 1,s
- sta :strlen
- pha
- _TextWriteBlock
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
-
- lda :strlen
- rts
-
-:strlen ds 2 ;number of characters output
-
-
-**************************************************
-* output number as fixed char decimal string.    *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - number of bytes to output.                *
-*  x - value to output.                          *
-**************************************************
-print_fix_char_dec ent
-]num_bytes = $f0 ;number of bytes to output
-
- sta ]num_bytes
-
- phx ;word - char to convert
- pea #^char_dec_str ;long - pointer to output string
- pea #char_dec_str
- pha ;word - length of string
- pea #FALSE ;word - unsigned number
- _Int2Dec
- pea #^char_dec_str ;long - pointer to string
- pea #char_dec_str
- pea #0 ;word - offset into text
- pei ]num_bytes ;word - number of characters to print
- _TextWriteBlock
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* output number as fixed short decimal string.   *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - number of bytes to output.                *
-*  x - value to output.                          *
-**************************************************
-print_fix_short_dec ent
-]num_bytes = $f0 ;number of bytes to output
-
- sta ]num_bytes
-
- phx ;word - short to convert
- pea #^short_dec_str ;long - pointer to output string
- pea #short_dec_str
- pha ;word - length of string
- pea #FALSE ;word - unsigned number
- _Int2Dec
- pea #^short_dec_str ;long - pointer to string
- pea #short_dec_str
- pea #0 ;word - offset into text
- pei ]num_bytes ;word - number of characters to print
- _TextWriteBlock
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* output number as fixed long decimal string.    *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - number of bytes to output.                *
-*  x - LOW of value to output.                   *
-*  y - HOW of value to output.                   *
-**************************************************
-print_fix_long_dec ent
-]num_bytes = $f0 ;number of bytes to output
-
- sta ]num_bytes
-
- phy ;long - longint to convert
- phx
- pea #^long_dec_str ;long - pointer to output string
- pea #long_dec_str
- pha ;word - length of string
- pea #FALSE ;word - unsigned number
- _Long2Dec
- pea #^long_dec_str ;long - pointer to string
- pea #long_dec_str
- pea #0 ;word - offset into text
- pei ]num_bytes ;word - number of characters to print
- _TextWriteBlock
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* output number as long hex string.              *
-* ---------------------------------------------- *
-* (input)                                        *
-*  x - LOW of value to output.                   *
-*  y - HOW of value to output.                   *
-**************************************************
-print_long_hex ent
-
- phy
- phx
- phy ;long - longint to convert
- phx
- pea #^long_hex_str ;long - pointer to output string
- pea #long_hex_str
- pea #8 ;word - length of string
- _Long2Hex
- pla
- ora 1,s
- plx
- cmp #0
- bne :0
- ldx #7
- bra :2
-:0 ldx #long_hex_str ;make hex alpha lowercase
- ldy #^long_hex_str
- lda #8
- jsr lowercase_hex
- ldx #$ffff
-:1 inx
- lda long_dec_str,x
- and #$ff
- cmp #'0'
- beq :1
-:2 pea #^long_hex_str ;long - pointer to string
- pea #long_hex_str
- phx ;word - offset into text
- sec ;word - number of characters to print
- lda #8
- sbc 1,s
- pha
- _TextWriteBlock
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* output number as fixed char hex string.        *
-* ---------------------------------------------- *
-* (input)                                        *
-*  x - value to output.                          *
-**************************************************
-print_fix_char_hex ent
-
- phx ;word - char to convert
- pea #^char_hex_str ;long - pointer to output string
- pea #char_hex_str
- pea #2 ;word - length of string
- _Int2Hex
- ldx #char_hex_str ;make hex alpha lowercase
- ldy #^char_hex_str
- lda #2
- jsr lowercase_hex
- pea #^char_hex_str ;long - pointer to string
- pea #char_hex_str
- pea #0 ;word - offset into text
- pea #2 ;word - number of characters to print
- _TextWriteBlock
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* output number as fixed short hex string.       *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - number of bytes to output.                *
-*  x - value to output.                          *
-**************************************************
-print_fix_short_hex ent
-
- pha
- phx ;word - short to convert
- pea #^short_hex_str ;long - pointer to output string
- pea #short_hex_str
- pha ;word - length of string
- _Int2Hex
- ldx #short_hex_str ;make hex alpha lowercase
- ldy #^short_hex_str
- lda 1,s
- jsr lowercase_hex
- pla
- pea #^short_hex_str ;long - pointer to string
- pea #short_hex_str
- pea #0 ;word - offset into text
- pha ;word - number of characters to print
- _TextWriteBlock
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* output number as fixed long hex string.        *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - number of bytes to output.                *
-*  x - LOW of value to output.                   *
-*  y - HOW of value to output.                   *
-**************************************************
-print_fix_long_hex ent
-
- pha
- phy ;long - longint to convert
- phx
- pea #^long_hex_str ;long - pointer to output string
- pea #long_hex_str
- pha ;word - length of string
- _Long2Hex
- ldx #long_hex_str ;make hex alpha lowercase
- ldy #^long_hex_str
- lda 1,s
- jsr lowercase_hex
- pla
- pea #^long_hex_str ;long - pointer to string
- pea #long_hex_str
- pea #0 ;word - offset into text
- pha ;word - number of characters to print
- _TextWriteBlock
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* format and print @decimal record.              *
-* ---------------------------------------------- *
-* (output)                                       *
-*  a - number of characters output.              *
-**************************************************
-print_@decimal equ *
-]str_len = $f0 ;length of output string
-
- pea #^@dec_form
- pea #@dec_form
- pea #^@decimal
- pea #@decimal
- pea #^:dec_str
- pea #:dec_str
- _Dec2Str
-
- lda :dec_str
- and #$ff
- tax
-:0 lda :dec_str,x
- and #$ff
- cpx #1
- beq :1
- cmp #'0'
- bne :1
- dex
- bra :0
-
-:1 cmp #'.'
- bne :2
- dex
-:2 shorti
- stx :dec_str
- longi
- pea #^:dec_str
- pea #:dec_str
- _WriteString
- lda :dec_str
- and #$ff
- rts
-
-:dec_str ds $50
-
-
-**************************************************
-* output number as double floating-point string. *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - dp address of double float value.         *
-* (output)                                       *
-*  a - number of characters output.              *
-**************************************************
-print_double ent
-
- pea #^@dec_form ;long - address of decform record
- pea #@dec_form
- pea #0 ;long - address of float value
- pha
- clc
- tdc
- adc 1,s
- sta 1,s
- pea #^@decimal ;long - address of decimal record
- pea #@decimal
- lda #FixedDecimal
- sta @dec_form+`style
- lda #5 ;5 digits to right of decimal
- sta @dec_form+`digits
- _Double2Decimal
- jsr print_@decimal
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* output number as extended float string.        *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - dp address of extended value.             *
-* (output)                                       *
-*  a - number of characters output.              *
-**************************************************
-print_extended ent
-
- pea #^@dec_form ;long - address of decform record
- pea #@dec_form
- pea #0 ;long - address of float value
- pha
- clc
- tdc
- adc 1,s
- sta 1,s
- pea #^@decimal ;long - address of decimal record
- pea #@decimal
- lda #FixedDecimal
- sta @dec_form+`style
- lda #10 ;10 digits to right of decimal
- sta @dec_form+`digits
- _Extended2Decimal
- jsr print_@decimal
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* output number as floating-point string.        *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - dp address of float value.                *
-* (output)                                       *
-*  a - number of characters output.              *
-**************************************************
-print_float ent
-
- pea #^@dec_form ;long - address of decform record
- pea #@dec_form
- pea #0 ;long - address of float value
- pha
- clc
- tdc
- adc 1,s
- sta 1,s
- pea #^@decimal ;long - address of decimal record
- pea #@decimal
- lda #FixedDecimal
- sta @dec_form+`style
- lda #5 ;5 digits to right of decimal
- sta @dec_form+`digits
- _Float2Decimal
- jsr print_@decimal
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
- jsr test_key
- fin
- rts
-
-
-**************************************************
-* print displacement, counter offset.            *
-**************************************************
-print_offset ent
-
- lda }nooffset
- bne :end
- lda #6
- ldx @omf+`displacement
- ldy @omf+`displacement+2
- jsr print_fix_long_hex
- pea #' '
- _WriteChar
- lda #6
- ldx @omf+`counter
- ldy @omf+`counter+2
- jsr print_fix_long_hex
- pea #^vert_separator+1
- pea #vert_separator+1
- _WriteCString
-:end rts
-
-
-**************************************************
-* format printed output.                         *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - address of string to parse.               *
-*  x - HOW of argument.                          *
-*  y - LOW of argument.                          *
-* (output)                                       *
-*  x - number of characters output.              *
-**************************************************
-printf ent
-]arg_str = $e0 ;address of string to parse
-]arg = $e2 ;argument
-]print_begin = $e6 ;location of first character to print
-]print_end = $e8 ;location of last character to print
-]count = $ea ;number of characters output
-
- sta ]arg_str
- stx ]arg+2
- sty ]arg
- stz ]count
-
- ldy #0
- sty ]print_begin
- sty ]print_end
-:parse_arg_str lda #0
- shorta
- lda (]arg_str),y
- longa
- beq :end
- cmp #'%'
- beq :parse_format
- iny
- inc ]count
- bra :parse_arg_str
-
-:end sty ]print_end
- cpy ]print_begin ;end if nothing left to print
- beq :rts
- pea #^printf
- pei ]arg_str
- pei ]print_begin
- sec
- lda ]print_end
- sbc ]print_begin
- pha
- _TextWriteBlock
-:rts ldx ]count
- rts
-
-:parse_format phy
- sty ]print_end
- pea #^printf
- pei ]arg_str
- pei ]print_begin
- sec
- lda ]print_end
- sbc ]print_begin
- pha
- _TextWriteBlock
- lda 1,s
- tay
- iny
- lda #0
- shorta
- lda (]arg_str),y
- longa
- cmp #'2'
- bne :hex_4
- lda #2
- ldx ]arg
- jsr print_fix_char_hex
- inc ]count
- inc ]count
- bra :end_parse
-:hex_4 cmp #'4'
- bne :hex_6
- lda #4
- ldx ]arg
- jsr print_fix_short_hex
- inc ]count
- inc ]count
- inc ]count
- inc ]count
- bra :end_parse
-:hex_6 cmp #'6'
- bne :char
- lda #6
- ldx ]arg
- ldy ]arg+2
- jsr print_fix_long_hex
- inc ]count
- inc ]count
- inc ]count
- inc ]count
- inc ]count
- inc ]count
- bra :end_parse
-:char pea #'>'
- lda ~assembler
- cmp #MERLIN
- beq :0
- lda #'|'
- sta 1,s
-:0 _WriteChar
- inc ]count
-:end_parse ply
- iny
- iny
- sty ]print_begin
- sty ]print_end
- brl :parse_arg_str
-
-
-**************************************************
-* find first occurrence of a character in a      *
-* string in current bank.                        *
-* ---------------------------------------------- *
-* (input)                                        *
-*  a - character to find.                        *
-*  x - address of search string in current bank. *
-* (output)                                       *
-*  x - address of where character is located.    *
-*      0 if character not found.                 *
-**************************************************
-strchr ent
-]char = $f0 ;character to find
-]string = $f2 ;string to search
-
- sta ]char
- stx ]string
-
- ldy #0
- shorta
-:loop lda (]string),y
- cmp ]char
- beq :end
- cmp #0
- beq :error
- iny
- bra :loop
-:end longa
- clc
- tya
- adc ]string
- tax
- rts
-:error longa
- ldx #0
- rts
-
-
- do ENV&{MERLIN_ENV.ORCA_ENV}
-**************************************************
-* test for special keypresses:                   *
-*  ctrl-s: pause output                          *
-*  ctrl-c: terminate program                     *
-**************************************************
-test_key ent
-
- lda #0
- shorta
- ldal KBD
- longa
- bpl :print
- cmp #CTRL_C.$80
- beq :exit
-
- shorta
- stal KBDSTRB
-:pause ldal KBD
- bpl :pause
- bra :clear_kbd
-
-:exit pla
- bne :exit
- do ENV&MERLIN_ENV
- put_cr
- fin
-:clear_kbd shorta
- stal KBDSTRB
- longa
-:print rts
- fin
-
-
-**************************************************
-* get length of C-string.                        *
-* ---------------------------------------------- *
-* (input)                                        *
-*  x - LOW of pointer to C-string.               *
-*  y - HOW of pointer to C-string.               *
-* (output)                                       *
-*  y - length of C-string.                       *
-**************************************************
-strlen ent
-]cstr = $f0
-
- stx ]cstr
- sty ]cstr+2
-
- ldy #0
- shorta
-:0 lda []cstr],y
- beq :end
- iny
- bra :0
-
-:end longa
- rts
-
-
-**************************************************
-* display options strings of all coff options    *
-* and exit coff.                                 *
-* ---------------------------------------------- *
-* (input)                                        *
-*  x - LOW of program name.                      *
-*  y - HOW of program name.                      *
-**************************************************
-usage ent
-]usage_handle = $f0 ;handle to verbose usage string
-]usage_ptr = $f4
-]progname = $f8 ;name of program
-
- stx ]progname
- sty ]progname+2
-
- pha ;long - result
- pha
- pea #rText ;word - type of resource
- pea #^USAGE ;long - ID Of resource
- pea #USAGE
- _LoadResource
- plx
- ply
- stx ]usage_handle
- sty ]usage_handle+2
- pea #^usage_str
- pea #usage_str
- _WriteCString
- pei ]progname+2
- pei ]progname
- _WriteCString
- ldy #2
- lda []usage_handle],y
- pha
- lda []usage_handle]
- pha
- _WriteCString
-:0 pla
- bne :0
- rts
-
-
-**************************************************
-* display options strings and descriptions of    *
-* all coff options and exit coff.                *
-* ---------------------------------------------- *
-* (input)                                        *
-*  x - LOW of program name.                      *
-*  y - HOW of program name.                      *
-**************************************************
-usage_verbose ent
-]usage_handle = $f0 ;handle to verbose usage string
-]usage_ptr = $f4
-]progname = $f8 ;name of program
-
- stx ]progname
- sty ]progname+2
-
- pha ;long - result
- pha
- pea #rText ;word - type of resource
- pea #^USAGE_VERBOSE ;long - ID Of resource
- pea #USAGE_VERBOSE
- _LoadResource
- plx
- ply
- stx ]usage_handle
- sty ]usage_handle+2
- pei ]progname+2
- pei ]progname
- _WriteCString
- ldy #2
- lda []usage_handle],y
- pha
- lda []usage_handle]
- pha
- _WriteCString
-:0 pla
- bne :0
- rts
-
-
-**************************************************
-usage_str cStr 'usage: '
-
-@dec_form equ * ;SANE Decform record
-:style UnsignedShort ;output style (FloatDecimal, FixedDecimal)
-:digits UnsignedShort ;number of significant digits
-
-@decimal equ * ;SANE Decimal record
-:sgn UnsignedShort ;sign of number
-:exp UnsignedShort ;exponent value
-:sig ds 20
-
-**************************************************
- sav general.l
+ END OF ARCHIVE