I've got tons of homegrown database code from the 1980's - from an old VAX/VMS minicomputer. We actually "implemented" a SIGMA function to loop through data manipulations! I've posted some snippets and attached two of the whole code files.
Any value posting the whole set of code here? I've seen people discuss developing parsers and there own language - this is one as an example.
Some of the upper level NON-MATH functions
Code:
New EQ Functions 01-Sep-1993
------------------
OPEN(open_opt%,dt_cnct_prefix$,open_acc%,open_all%,open_span%
,open_filesize%,open_extend%,open_file$,open_dcr$)
FIELD(dt_prefix$,field_opt%,field%,element%,format_opt%)
CONVERT(dt_prefix$,cnv_opt%,cnv_what?)
CNF(cnf_chnl%,cnf_file$)
DATE(in_type%,out_type%,in_date$)
NUMBER(out_len%,in_num$,out_format%)
INFO(info_what%)
MAIL(who$,subj$,text$)
RANDOM
DAY(date_typ%,date$)
IDENT(identifier$)
SIGMA$(loop_vbl,loop_start%,loop_end%,loop_step%,loop_expression$)
SET(set_opt%,set_extra%,set_text$)
ERROR(err_opt%,text$)
PUT(row%,col%,put_opt%,text$)
TYPE(typ_key$,typ_desc$,typ_master$,typ_primary$,typ_key%,typ_first$
,typ_last$,typ_read_crit$,typ_write_crit$
{{,typ_anc_file$,typ_key_field$,typ_key%}...})
PARAM(param_slot%,param_string$)
ABORT
END
EQLOADRTL.BAS - loads the runtime library!
Code:
1 FUNCTION LONG EQ_LOAD_RTL( LONG A_CHAN) &
&
! &
! Product : Equation Functions &
! Program : EQLOADRTL.BAS &
! Author : Stephen Zlamany &
! Date : May 1, 1989 &
! &
! ANTARES Computing Systems, Inc. &
! 19 Ripton Road, Huntington, CT &
! &
10 %INCLUDE "ACS$INC:ACSDEFS.INC"
%INCLUDE "ACS$INC:EQDEFS.INC"
100 EXTERNAL LONG FUNCTION LIB$GET_VM
EXTERNAL LONG CONSTANT SS$_NORMAL
DECLARE LONG E_CHAN &
,E_OPC_CHAN
900 WHEN ERROR USE ERROR_HANDLER
1000 ! Start of Main Code
BEGIN:
CALL PEEK_L(A_CHAN,ACS$A_CHAN,A.CHAN%)
IF A_CHAN <> A.CHAN% THEN
! Error condition
END IF
CALL PEEK_L(A_CHAN,ACS$E_CHAN,E_CHAN)
CALL PEEK_W(E_CHAN,EQP$OPC_FLAG,E.FLAG%)
IF E.FLAG% <> -1% THEN
! Error condition
END IF
CALL PEEK_L(E_CHAN,EQP$OPC_ADDR,E_OPC_CHAN)
GOSUB LOAD_OPC
GOSUB SORT_OPC
OPR_INIT = -1%
GOTO RTN_CALLER
1100 ! Load opcodes
LOAD_OPC:
OPC.CNT% = 1%
CALL POKE_S(E_OPC_CHAN,EQP$OPC_OP_NAME+OPC.CNT%*10%,10%,"* ")
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_NUM+OPC.CNT%,OPC.CNT%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_NAMLNK+OPC.CNT%,OPC.CNT%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_ARGCNT+OPC.CNT%,2%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_FLAG+OPC.CNT%,EQT$OPR_INFIX &
OR EQT$OPR_NUMERIC)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_PRIO+OPC.CNT%,3%)
OPC.CNT% = OPC.CNT% + 1%
CALL POKE_S(E_OPC_CHAN,EQP$OPC_OP_NAME+OPC.CNT%*10%,10%,"+ ")
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_NUM+OPC.CNT%,OPC.CNT%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_NAMLNK+OPC.CNT%,OPC.CNT%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_ARGCNT+OPC.CNT%,2%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_FLAG+OPC.CNT%,EQT$OPR_INFIX &
OR EQT$OPR_NUMERIC)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_PRIO+OPC.CNT%,4%)
OPC.CNT% = OPC.CNT% + 1%
CALL POKE_S(E_OPC_CHAN,EQP$OPC_OP_NAME+OPC.CNT%*10%,10%,"+ ")
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_NUM+OPC.CNT%,OPC.CNT%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_NAMLNK+OPC.CNT%,OPC.CNT%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_ARGCNT+OPC.CNT%,1%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_FLAG+OPC.CNT%,EQT$OPR_UNARY &
OR EQT$OPR_NUMERIC)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_PRIO+OPC.CNT%,2%)
CALL POKE_W(E_OPC_CHAN,EQP$OPC_UNARY_PLUS,OPC.CNT%)
OPC.CNT% = OPC.CNT% + 1%
CALL POKE_S(E_OPC_CHAN,EQP$OPC_OP_NAME+OPC.CNT%*10%,10%,"- ")
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_NUM+OPC.CNT%,OPC.CNT%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_NAMLNK+OPC.CNT%,OPC.CNT%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_ARGCNT+OPC.CNT%,2%)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_FLAG+OPC.CNT%,EQT$OPR_INFIX &
OR EQT$OPR_NUMERIC)
CALL POKE_B(E_OPC_CHAN,EQP$OPC_OP_PRIO+OPC.CNT%,4%)
OPC.CNT% = OPC.CNT% + 1%
and EQEXECUTE.MAR (written in machine code!).
Code:
.title EQ_EXECUTE
.sbttl Program Heading
.ident /V1.0/
;
;
; Product : Equation Functions
; Program : EQEXECUTE.MAR
; Date : March 22, 1989
;
; ANTARES Computing Systems, Inc.
; 19 Ripton Road, Huntington, CT
;
;
.page
.sbttl MACRO definitions
;
; RPN Opcode block macros
;
.macro opstart sel,base,limit
caseb sel,base,limit
op_start = .
op_ptr = .
limit_l = %length(limit)-1
.blkw %extract(1,limit_l,limit)
.endm
.macro opcd num
.if nb num
num.1 = num
.iff
num.1 = 1
.endc
.rept num.1
op_save = .
. = op_ptr
.word op_save - op_start
op_ptr = .
. = op_save
.endr
.endm
.macro opend
op_ptr = 0
op_end = 0
.endm
;
; RPN word type case macro (literal, variable or operator)
;
.macro rinit sel,limit
caseb sel,#0,limit
rtype_start= .
limit_l = %length(limit)-1
.word <%extract(2,limit_l,limit)*2>+2
tmp_limit = .
.blkw %extract(2,limit_l,limit)
rtype_limit = <.-tmp_limit>/2
.endm
.macro rtype bits
rtype_save = .
. = rtype_start
tmp = 0
.rept <rtype_limit+1>
.if ne <bits & tmp>
.word rtype_save - rtype_start
.iff
. = . + 2
.endc
tmp = <tmp + 1>
.endr
. = rtype_save
.endm
.page
.sbttl Data Area (protected)
.psect eq_data,nowrt,noexe,shr,pic,con,long
;
; Definitions
;
arg_achan = 1 * 4 ; A_CHAN
arg_option = 2 * 4 ; options
arg_object = 3 * 4 ; object string
arg_prec = 4 * 4 ; precision
arg_string = 5 * 4 ; result string
arg_value = 6 * 4 ; result value
arg_result = 7 * 4 ; result type
;
; DT offsets and constants
;
d_chan = 8 ; D_CHAN within A_CHAN
dc_flag = 0 ; D_CHAN flag
dc_workmap = 2 ; D_CHAN work map flag
dc_workaddr = 4 ; D_CHAN work map address
dc_recurse = 8 ; D_CHAN recursion count
dc_count = 10 ; D_CHAN slot count
dc_slots = 12 ; D_CHAN slot pool
dp_flag = 0 ; DS_CHAN flag
dp_prefix = 8 ; DS_CHAN prefix
;
dts$normal = 0
dts$stk_ovr = 36
dts$sub_ovr = 55
dts$udef_sym = 75
dts$not_yet_imp = 250
dts$bad_addr = -21
dts$ext_noopn = -121
dts$inv_ste = -131
dts$inv_obj = -132
;
; EQ offsets and constants
;
obj_hdr_loff = 12
obj_hdr_coff = 14
obj_hdr_doff = 16
obj_hdr_ver = 20
;
eq_ver = 5
;
rpn_oper = 256
rpn_lit = 512
rpn_var = 1024
;
lit_byte = 256
lit_word = 512
lit_long = 1024
;
stb_start = 26
stb_len = 26
stb_namptr = 0
stb_namlen = 2
stb_flg = 4
stb_fld = 6
stb_slot = 8
stb_addr = 12
stb_bd0 = 20
stb_bd1 = 22
stb_bd2 = 24
;
ste_sub = 3
ste_sub1 = 1
ste_sub2 = 2
ste_byte = 4
ste_word = 8
ste_long = 16
ste_scalar = 32
ste_def = 64
ste_zhh = 128
ste_icnt = 256
ste_dcr = 512
;
; Miscellaneous options and values
;
blank_dsc: .word 0 ; no length
.byte dsc$k_dtype_t ; text string
.byte dsc$k_class_d ; dynamic string
blank_str: .word 0 ; no length
.byte dsc$k_dtype_t ; text string
.byte dsc$k_class_d ; dynamic string
.long 0 ; no address
null_str: .ascid // ; Null string
zero_str: .ascid /0/ ; Zero value string
.align long ; get on a longword boundary
inf$username: .long 1 ; GET_INFO option
inf$uic: .long 2 ; GET_INFO option
frm$sto: .long 1 ; Format STO
frm$inp: .long 2 ; Format INP
frm$srt: .long 3 ; Format SRT
frm$dsp: .long 4 ; Format DSP
val$0: .long 0 ; general option value
val$1: .long 1 ; general option value
val$2: .long 2 ; general option value
val$3: .long 3 ; general option value
val$4: .long 4 ; general option value
val$5: .long 5 ; general option value
val$6: .long 6 ; general option value
dto$field: .long <1@0>+<1@11>
dto$name: .long <1@1>+<1@11>
dto$fld_noerr: .long <1@0>+<1@11>+<1@15>
dto$name_noerr: .long <1@1>+<1@11>+<1@15>
dto$get: .long <1@2>+<1@11>
dto$table: .long <1@4>+<1@11>
dto$tb_init: .long <1@4>+<1@7>+<1@11>
dto$tb_fnd_get: .long <1@4>+<1@2>+<1@8>+<1@11>
dto$init: .long <1@7>+<1@11>
dto$find: .long <1@8>+<1@11>
dto$no_wrk_map: .long <1@11>
dto$no_error: .long <1@15>
eqo$value: .long <1@22>
eqo$string: .long <1@23>
eqo$either: .long <1@22>+<1@23>
;
; Stack Work Space
;
op_max = 6 ; Maximum number of operands
op_size = 9 ; Size of each operand block
ib_max = 4 ; Max number of iterative blocks
ib_size = 9 ; size of each iterative block
stack_size = <op_max*op_size>+<ib_max*ib_size>+16
obo_start = 16+<ib_max*ib_size>
obo_type = 0 ; Offset to type byte
obo_str = 1 ; Offset to Descriptor
obo_long = 1 ; Offset to longword value
obo_arg1 = obo_start ; Arguments
obo_arg2 = obo_arg1+op_size
obo_arg3 = obo_arg2+op_size
obo_arg4 = obo_arg3+op_size
obo_arg5 = obo_arg4+op_size
obo_arg6 = obo_arg5+op_size
obo_int1 = obo_arg1+obo_long
obo_int2 = obo_arg2+obo_long
obo_int3 = obo_arg3+obo_long
obo_int4 = obo_arg4+obo_long
obo_int5 = obo_arg5+obo_long
obo_int6 = obo_arg6+obo_long
obo_str1 = obo_arg1+obo_str
obo_str2 = obo_arg2+obo_str
obo_str3 = obo_arg3+obo_str
obo_str4 = obo_arg4+obo_str
obo_str5 = obo_arg5+obo_str
obo_str6 = obo_arg6+obo_str
obo_tmp1 = obo_start+1 ; STE address, subscript value
obo_tmp2 = obo_tmp1+4 ; Subscript value, index
obo_tmp3 = obo_tmp2+5 ; Index offset
obo_tmp4 = obo_tmp3+4 ; Array bound
;
; Operand Types
;
opt_long = 1 ; long
opt_str = 2 ; string
opt_either = 3 ; either type
opt_dyn = 4 ; dynamic bit
opt_strdyn = 6 ; dynamic string
opt_valerr = 8 ; value error
;
; Temporaries for op_get
;
opg_get = 8 ; operands to get
opg_got = 12 ; operands gotten
;
; Iteration Work Space
;
ibo_start = 16 ; Start
ibo_type = 0 ; Type offset
ibo_long = 1 ; Long offset
ibo_float = 1 ; D-Float offset
;
ibt_long = 1 ; Iteration index - long
ibt_float = 2 ; Iteration index - D-float
;
ifo_blk = 0 ; Number
ifo_bpc = 4 ; PC
ifo_spc = 8 ; Saved PC
ifo_sum = 12 ; Sum
ifo_end = 20 ; End value - D-float
ifo_step = 28 ; Step value - D-float
.page
.sbttl EQ_EXECUTE code - setup registers
.psect eq_execute,nowrt,exe,shr,pic,con
.entry eq_execute,^m<r2,r3,r4,r5,r6,r7,r8,r9,r10,r11>
;
; Register Use
;
; r2 - temporary
; r3 - temporary, used for A_CHAN
; r4 - RPN code PC
; r5 - Address of literal pool
; r6 - Address of literal blocks
; r7 - temporary
; r8 - Address of object
; r9 - pointer to Stack Work space
;
cmpw @arg_object(ap),#26 ; is object size of header
blss 10$ ; no - branch
movaq @arg_string(ap),r0 ; address of return string
movaq null_str,r1 ; address of null string
jsb g^str$copy_dx_r8 ; copy string
clrl @arg_value(ap) ; clear return value
clrl @arg_result(ap) ; clear result type
movaq @arg_object(ap),r8 ; address of object
movab @4(r8),r8 ; address of object data
cmpw obj_hdr_ver(r8),#eq_ver ; compare version
beql 20$ ; same - branch
10$: movl #dts$inv_obj,r0 ; otherwise, bad object
ret ; return
20$: moval err_handler,(fp) ; frame up the err_handler
subl2 #stack_size,sp ; push size of work space
movq blank_str,-(sp) ; push a blank string
movl sp,r9 ; pointer to temporary storage
movzwl obj_hdr_coff(r8),r4 ; offset to rpn pool
movzwl obj_hdr_doff(r8),r5 ; offset to literal pool
movzwl obj_hdr_loff(r8),r6 ; offset to lte's
addl2 r8,r4 ; add address to rpn
addl2 r8,r5 ; add address to literal
addl2 r8,r6 ; add address to lte's
decl r5 ; adjust literal
subl2 #4,r6 ; adjust lte's
.page
.sbttl Execute a word of RPN
;
; Here we loop through RPN words - executing each
;
rpnexe: cmpl r4,r5 ; still more rpn code
bgtru 30$ ; no - branch
movzwl (r4)+,r7 ; get RPN word
extzv #8,#3,r7,r1 ; get flags
rinit r1,#07 ; rpn init macro based on RPN word type
movl #dts$not_yet_imp,r0 ; give error
ret ; return
;
; We are now done - lets write out our results
;
30$: clrl r0 ; Get one operand
mcoml l^eqo$either,r1 ; Create a mask of both bits
bicl3 r1,@arg_option(ap),r1 ; Pass options through mask
divl2 l^eqo$value,r1 ; Shift down to bits 0 and 1
movab obo_start(r9),r7 ; Placing at start
jsb op_get ; Get operand(s)
bitb #opt_str,(r7) ; Is it string
beql 50$ ; No - branch
pushaq obo_str(r7) ; Get address of operand
pushaq @arg_string(ap) ; Get address of return string
calls #2,g^str$copy_dx ; Call STRING Copy
movl #opt_str,@arg_result(ap); Pass back result type
mull2 l^eqo$value,@arg_result(ap)
; Shift up to actual bits
bitb #opt_dyn,(r7) ; Is it dynamic string
beql 40$ ; No - branch
moval obo_str(r7),r0 ; Get address of operand
jsb g^str$free1_dx_r4 ; Call STRING Free
40$: clrl r0 ; Set status to success
ret ; Return
50$: movl obo_long(r7),@arg_value(ap)
; Copy into return value
movl #opt_long,@arg_result(ap)
; Pass back result type
mull2 l^eqo$value,@arg_result(ap)
; Shift up to actual bits
clrl r0 ; Set status to success
ret ; Return
.page
.sbttl Execute Literals
;
; RPN literals
;
rtype rpn_lit/256 ; Handle literals
bicw2 #rpn_lit,r7 ; Clear flag
movl (r6)[r7],r1 ; Address of LTE
movzwl r1,r0 ; Offset to data
addl2 r5,r0 ; Address of data
extzv #16,#12,r1,r1 ; Length of data
bitw #lit_byte,r1 ; Is it a byte
beql 60$ ; No - branch
cvtbl (r0),-(sp) ; Put it on the stack
movb #opt_long,-(sp) ; Push long type
The DO_SIGMA block of machine code!
Code:
do_sigma:
opcd ; Op-code 24, "SIGMA"
movzbl (sp)+,(r9) ; Get type off stack
movl (sp)+,(r9) ; Get address off stack
movl #3,r0 ; Get three operands
movl #opt_either,r1 ; Get either
movab obo_arg3(r9),r7 ; Placing at argument 3
jsb op_get ; Get operand(s)
movzbl (sp)+,r0 ; Get iterative count type
bitb #opt_long,r0 ; Is it long
bneq 440$ ; Yes - branch
pushr #^m<r0,r1,r4> ; Save some registers
moval 12(sp),r0 ; Address of string
jsb g^str$free1_dx_r4 ; Free up string
popr #^m<r0,r1,r4> ; Restore some registers
clrl (sp)+ ; Clear first part of string
440$: clrl (sp)+ ; Clear second part or long value
subl2 #36,sp ; Put iterative work space on stack
ashl #-4,r0,r0 ; Get iterative counter
mull2 #ib_size,r0 ; Make it an offset
moval ibo_start(r9),r7 ; Get address
addl2 r0,r7 ; Get iterative address
movl r7,(sp) ; Put it on the stack
movl (r9),ifo_bpc(sp) ; Set iterative PC
movl r4,ifo_spc(sp) ; Save current RPN PC
bitb #opt_long,r1 ; Is it long
beql 510$ ; No - branch
clrl ifo_sum(sp) ; Clear sum
movl obo_int1(r9),ibo_long(r7)
; Set start value
movl obo_int2(r9),ifo_end(sp); Set end value
movb #ibt_long,(r7) ; Set type
movl obo_int3(r9),ifo_step(sp)
; Set step - is it negative
bleq 450$ ; Yes - branch
cmpl ibo_long(r7),ifo_end(sp); Are we done already
brb 460$ ; Jump to check
450$: cmpl ifo_end(sp),ibo_long(r7); Are we done already
460$: bgtr 500$ ; Yes - branch
470$: movl ifo_bpc(sp),r4 ; Get iterative PC
jsb rpnexe ; Execute it
clrl r0 ; Get one operand
movl #opt_long,r1 ; Get long
movab obo_arg1(r9),r7 ; Placing at argument 1
jsb op_get ; Get operand(s)
addl2 obo_int1(r9),ifo_sum(sp); Sum the result
movl (sp),r7 ; Get iterative address
addl2 ifo_step(sp),ibo_long(r7)
; Increment counter
tstl ifo_step(sp) ; Are we a negative step
bleq 480$ ; Yes - branch
cmpl ibo_long(r7),ifo_end(sp); Are we done already
brb 490$ ; Jump to check
480$: cmpl ifo_end(sp),ibo_long(r7); Are we done already
490$: bleq 470$ ; No - branch
500$: movl ifo_spc(sp),r4 ; Restore RPN PC
movl ifo_sum(sp),r0 ; Save sum'd value
addl2 #36,sp ; Remove iterative work space
pushl r0 ; Push sum'd value
movb #opt_long,-(sp) ; Push long type
brw rpnexe ; Next RPN
510$: ; Handle float iteration
clrd ifo_sum(sp) ; Clear sum
pushal obo_str1(r9) ; Push operand 1
calls #1,g^bas$val_d ; Call VAL()
movd r0,ibo_long(r7) ; Set start value
pushal obo_str2(r9) ; Push operand 2
calls #1,g^bas$val_d ; Call VAL()
movd r0,ifo_end(sp) ; Set end value
movb #ibt_float,(r7) ; Set type
pushal obo_str3(r9) ; Push operand 3
calls #1,g^bas$val_d ; Call VAL()
movd r0,ifo_step(sp) ; Set step
pushr #^m<r7> ; Save r7
movl #3,r7 ; 3 possible operands
jsb op_free ; Free operands
popr #^m<r7> ; Restore r7
tstd ifo_step(sp) ; Is step negative
bleq 520$ ; Yes - branch
cmpd ibo_long(r7),ifo_end(sp); Are we done already
brb 530$ ; Jump to check
520$: cmpd ifo_end(sp),ibo_long(r7); Are we done already
530$: bgtr 570$ ; Yes - branch
540$: movl ifo_bpc(sp),r4 ; Get iterative PC
jsb rpnexe ; Execure it
clrl r0 ; Get one operand
movl #opt_str,r1 ; Get string
movab obo_arg1(r9),r7 ; Placing at argument 1
jsb op_get ; Get operand(s)
pushal obo_str1(r9) ; Push operand 1
calls #1,g^bas$val_d ; Call VAL()
addd2 r0,ifo_sum(sp) ; Sum the result
movl #1,r7 ; 1 possible operand
jsb op_free ; Free operands
movl (sp),r7 ; Get iterative address
addd2 ifo_step(sp),ibo_long(r7)
; Increment counter
tstd ifo_step(sp) ; Are we a negative step
bleq 550$ ; Yes - branch
cmpd ibo_long(r7),ifo_end(sp); Are we done already
brb 560$ ; Jump to check
550$: cmpd ifo_end(sp),ibo_long(r7); Are we done already
560$: bleq 540$ ; No - branch
570$: movl ifo_spc(sp),r4 ; Restore RPN PC
movd ifo_sum(sp),r0 ; Save sum'd value
addl2 #36,sp ; Remove iterative work space
movq blank_str,-(sp) ; Push a blank string
movd r0,-(sp) ; Push sum'd value
pushal 8(sp) ; Push result address
calls #3,g^bas$num1_d ; Call NUM1()
movb #opt_strdyn,-(sp) ; Push temporary string type
brw rpnexe ; Next RPN
do_xor:
opcd ; Op-code 25, "XOR"
*** Read the sticky in the DB forum about how to get your question answered quickly!! ***
Please remember to rate posts! Rate any post you find helpful - even in old threads! Use the link to the left - "Rate this Post".
Reply With Quote