Piper's Pit BBS/FTP: ibm 0040 - 0049/ibm0040-0049/ibm0040.tar/ibm0040/DBRIEF.ZIP/SOURCE/DBASE.M

Text File | 1991-03-21 | 12.5 KB | 367 lines

;dBRIEF Dialect (dBASE IV Support) - v3.10
;Copyright (c) 1991 - Global Technologies Corporation
;ALL RIGHTS RESERVED
#include "dbrief.h"
#include "common.h"
(macro _dialect_table
    (
        (returns "DO W ENDD BEGI END SCAN ENDS IF ELSE ENDI FUNC PROC RETU DO CASE OTHE ENDC TEXT ")
    )
)
(macro _indenting_conditionals
    (
        (return "BEGI IF   SCAN  DO C  DO W ")
    )
)
(macro _reseting_conditionals
    (
        (return "ELSE ")
    )
)
(macro _outdenting_conditionals
    (
        (return "END ENDS ENDD ENDC ENDI")
    )
)
(macro _backdenting_conditionals
    (
        (returns "ENDD END ENDS ELSE ENDI CASE OTHE ENDC ")
    )
)
(macro _matching_conditional
    (
        (string            _match_token
        )
        (get_parm 0 _match_token)
        (switch _match_token
            "IF "
                (return "ENDIF")
            "PROC"
                (return "RETURN")
            "FUNC"
                (return dbr_udf_return)
            "BEGI"
                (return "END TRANSACTION")
            "DO W"
                (return "ENDDO")
            "DO C"
                (return "ENDCASE")
            "SCAN"
                (return "ENDSCAN")
            NULL
                (return "")
        )
    )
)
(macro _complete_cond_table
    (
        (return "IF~PR~FU~BE~DO~SC~")
    )
)
(macro _adjust_indent_level
    (
        (int                adj_indent_column
                            adj_previous_line
        )
        (string            eval_string
        )
        (get_parm 0 eval_string)
        (get_parm 1 adj_indent_column)
        (switch (substr eval_string 1 4)
            "BEGI"    NULL
            "SCAN"    NULL
            "DO W"
                (+= adj_indent_column dbr_indent_level)
            "RETU"
                (
                    (-= adj_indent_column dbr_indent_level)
                    (= adj_previous_line (* dbr_indent_level -1))
                )
            "DO C"
                (+= adj_indent_column (* dbr_indent_level dbr_indent_case))
            "OTHE"
                (= adj_previous_line (* dbr_indent_level -1))
            "ENDC"
                (
                    (-= adj_indent_column (* dbr_indent_level dbr_indent_case))
                    (= adj_previous_line (* dbr_indent_level (* dbr_indent_case -1)))
                )
        )
        (move_abs 0 adj_indent_column)
        (return adj_previous_line)
    )
)
;dBASE IV Reindenting Macros
(macro _indent_shift
    (
        (string            token
                            orig_line
        )
        (int                dbr_insert_col
        )
        (get_parm 0 token)
        (get_parm 1 orig_line)
        (get_parm 2 dbr_insert_col)
        (switch token
            "DO"
                (
                    (if (search_string "DO[ \t]+WHIL" orig_line NULL 1 0)
                        (+= curr_indent_col dbr_indent_level)
                    )
                    (if (search_string "DO[ \t]+CASE" orig_line NULL 1 0)
                        (+= curr_indent_col (* dbr_indent_level dbr_indent_case))
                    )
                )
            "FUNC" NULL
            "PROC"
                (if dbr_proc_indent
                    (
                        (= dbr_return_flag 1)
                        (+= curr_indent_col dbr_indent_level)
                    )
                ;else
                    (= dbr_return_flag 0)
                )
            "BEGI"    NULL
            "SCAN"    NULL
            "IF"
                (+= curr_indent_col dbr_indent_level)
            "ENDC"
                (= dbr_insert_col (-= curr_indent_col (* dbr_indent_level dbr_indent_case)))
            "END"        NULL
            "ENDI"    NULL
            "ENDS"    NULL
            "ENDD"
                (= dbr_insert_col (-= curr_indent_col dbr_indent_level))
            "RETU"
                (if (&& (== dbr_return_flag 1)(== (substr (upper orig_line) 1 6) "RETURN"))
                    (
                        (= dbr_return_flag 0)
                        (= dbr_insert_col (-= curr_indent_col dbr_indent_level))
                    )
                )
            "CASE" NULL
            "ELSE" NULL
            "OTHE"
                (-= dbr_insert_col dbr_indent_level)
            "TEXT"
                (if (== (inq_called) "rein")
                    (_find_matching_endtext)
                )
        )
        (returns dbr_insert_col)
    )
)
;dBASE IV Template Abbreviations
(macro _command_table
    (
        (int                table_number
        )
        (get_parm 0 table_number)
        (switch table_number
            1
                (return "~ACM ACTIVATE MENU ~ACP ACTIVATE POPUP ~ACS ACTIVATE SCREEN ~ACW ACTIVATE WINDOW ~AFA APPEND FROM ARRAY ~APF APPEND FROM ~APM APPEND MEMO ~APB APPEND BLANK ~")
            2
                (return "~CAL CALCULATE ~CLA CLEAR ALL ~CLF CLEAR FIELDS ~CLG CLEAR GETS ~CLM CLEAR MEMORY ~CLP CLEAR PROGRAM ~CLT CLEAR TYPEAHEAD ~CLW CLEAR WINDOWS ~CLD CLOSE DATABASE ~")
            3
                (return "~CLI CLOSE INDEX ~COF COPY FILE ~COM COPY MEMO ~COS COPY STRUCTURE ~COT COPY TO ~CTA COPY TO ARRAY ~CRL CREATE LABEL ~CRR CREATE REPORT ~CRV CREATE VIEW ~")
            4
                (return "~DAM DEACTIVATE MENU ~DEP DEACTIVATE POPUP ~DEW DEACTIVATE WINDOW ~DEB DEFINE BAR ~DEL DELETE ~DEM DEFINE MENU ~DBX DEFINE BOX FROM ^ux,^uy TO ^lx,^ly~")
            5
                (return "~DEF DELETE FILE ~DIR DIRECTORY ~DIF DISPLAY FILES ~DIM DISPLAY MEMORY ~DIS DISPLAY STATUS TO ~DOC DO CASE~DOW DO WHILE .T.~ENC ENDCASE~EJP EJECT PAGE ~")
            6
                (return "~GAT GATHER FROM MEMVER ~HIM HIDE MENU ~HIP HIDE POPUP ~HIW HIDE WINDOW ~LBL LABEL FORM ~LIF LIST FILES ~LIM LIST MEMORY ~LIS LIST STATUS ~LOF LOCATE FOR ~")
            7
                (return "~MOC MODIFY COMMAND ~MOL MODIFY LABEL ~MOM MODIFY MEMO ~MOR MODIFY REPORT ~MVW MOVE WINDOW ~ONE ON ERROR ~ONS ON ESCAPE ~ONR ON READERROR ~OTH OTHERWISE~")
            8
                (return "~OPA ON SELECTION PAD ~OPO ON SELECTION POPUP ~PAR PARAMETERS ~PRA PRIVATE ALL ~REC RECALL ~REL RELEASE ~SCA SCATTER ~SHM SHOW MENU ~SHP SHOW POPUP ~SHW SHOW WINDOW ~")
            9
                (return "~RET RETURN ~REP REPLACE ~RFM REPORT FORM ~RIN REINDEX ~RFR RESTORE FROM ~RSM RESTORE MACROS FROM ~RSC RESTORE SCREEN ~RWI RESTORE WINDOW ~SVM SAVE MACROS TO ~")
            10
                (return "~SSC SAVE SCREEN ~SVT SAVE TO ~SVW SAVE WINDOW ~SUS SUSPEND ~TTL TOTAL TO ~UPD UPDATE ON ~BEG BEGIN TRANSACTION~")
            NULL
                (return 10)
        )
    )
)
(macro _function_table
    (
        (int                table_number
        )
        (get_parm 0 table_number)
        (switch table_number
            1
                (return "~ABS ABS(expN)~ACO ACOS(expN)~ALI ALIAS(expN)~ALT ALLTRIM(expC)~ASC ASC(expC)~ASI ASIN(expN)~ATA ATAN(expN)~ATC ATC(expC1,expC2,expN)~ACL ATCLINE(expC1,expC2)~")
            2
                (return "~ATL ATLINE(expC1,expC2)~ATN ATN2(expN1,expN2)~BAR BAR()~BET BETWEEN(expr1,expr2,expr3)~BOF BOF(alias)~CAP CAPSLOCK(expL)~CDO CDOW(expD)~CEI CEILING(expN)~")
            3
                (return "~CHR CHR(expN)~CHS CHRSAW(expN)~CHT CHRTRAN(expC1,expC2,expC3)~CMO CMONTH(expD)~COL COL()~COS COS(expN)~CTO CTOD(expC)~CUR CURDIR(expC)~DAT DATE()~")
            4
                (return "~DAY DAY(expD)~DBF DBF(alias)~DEL DELETED(alias)~DIF DIFFERENCE(expC1,expC2)~DIS DISKSPACE()~DMY DMY(expD)~DOW DOW(expD)~DTC DTOC(expD)~DTR DTOR(expN)~")
            5
                (return "~DTS DTOS(expD)~EMP EMPTY(expr)~FCL FCLOSE(expN)~FCO FCOUNT(alias)~FCR FCREATE(expC,expN)~FEO FOEF(expN)~FER FERROR()~FFL FFLUSH(expN)~FGE FGETS(expN1,expN2)~")
            6
                (return "~COS COS(expN)~CTO CTOD(expC)~CUR CURDIR(expC)~DAT DATE()~FLT FILTER(alias)~FKL FKLABEL(expN)~FLO FLOOR(expN)~FOP FOPEN(expC,expN)~FOU FOUND(alias)~")
            7
                (return "~FPU FPUTS(expN1,expC,expN2)~FRE FREAD(expN1,expN2)~FSE FSEEK(expN1,expN2,expN3)~FSI FSIZE(fields,alias)~FUL FULLPATH(file,1)~FWR FWRITE(expN1,expC,expN2)~")
            8
                (return "~GEN GETENV(expC)~GEF GETFILE(expC1,expC2)~GOM GOMONTH(expD,expN)~HEA HEADER(alias)~IIF IIF(expL,expr1,expr2)~INK INKEY(expN,expC)~INL INLIST(expr1,expr2,expr3)~")
            9
                (return "~INS INSMODE(expL)~INT INT(expN)~ISA ISALPHA(expC)~ISC ISCOLOR()~ISD ISDIGIT(expC)~ISL ISLOWER(expC)~ISU ISUPPER(expC)~KEY KEY(expN,alias)~LAS LASTKEY()~")
            10
                (return "~LEF LEFT(expC,expN)~LEN LEN(expC)~LIK LIKE(expC1,expC2)~LIN LINENO()~LOG LOG(expN)~LOW LOWER(expC)~LTR LTRIM(expC)~LUP LUPDATE(alias)~MAX MAX(expr1,expr2,expr3)~")
            11
                (return "~MCO MCOL(expC)~MDO MDOWN()~MDY MDY(expD)~MML MEMLINES(memofields)~MEM MEMORY()~MEN MENU()~MES MESSAGE(1)~MIN MIN(expr1,expr2,expr3)~MLI MLINE(memoield,expN)~")
            12
                (return "~MOD MOD(expN1,expN2)~MON MONTH(expD)~MRO MROW(expC)~NDX NDX(expN,alias)~NUM NUMLOCK(expL)~OCC OCCURS(expC1,expC2)~ORD ORDER(alias)~PAD PAD()~PDC PADC(expr,expN,expC)~")
            13
                (return "~PDL PADL(expr,expN,expC)~PDR PADR(expr,expN,expC)~PRM PARAMETERS()~PAY PAYMENT(expN1,expN2,expN3)~PCO PCOL()~POP POPUP()~PRI PRINTSTATUS()~PRG PROGRAM(expN)~")
            14
                (return "~PRM PROMPT()~PRP PROPER(expC)~PRW PROW()~PUT PUTFILE(expC1,expC2,expC3)~RAN RAND(expN)~RAT RAT(expC1,expC2,expN)~RTL RATLINE(expC1,expC2)~REA READKEY()~")
            15
                (return "~RCO RECOUNT(alias)~RNO RECNO(alias)~RSI RECSIZE(alias)~REL RELATION(expN,alias)~REP REPLICATE(expC,expN)~RIG RIGHT(expC,expN)~ROU ROUND(expN1,expN2)~ROW ROW()~")
            16
                (return "~RTO RTOD(expN)~RTR RTRIM(expC)~SCH SCHEME(expN1,expN2)~SCO SCOLS()~SEC SECONDS()~SEE SEEK(expr,alias)~SEL SELECT()~STT SET(expC,1)~SIG SIGN(expN)~SIN SIN(expN)~")
            17
                (return "~SOU SOUNDEX(expC)~SPA SPACE(expN)~SQR SQRT(expN)~SRO SROWS()~STR STR(expN1,expN2,expN3)~STT STRTRAN(expC1,expC2,expC3,expN1,expN2)~STU STUFF(expC1,expN1,expN2,expC2)~")
            18
                (return "~SUB SUBSTR(expC,expN1,expN2)~TAN TAN(expN)~TAR TARGET(expN,expr)~TIM TIME(expN)~TRA TRANSFORM(expr,expC)~TRI TRIM(expC)~TYP TYPE(expC)~UPD UPDATED()~UPP UPPER(expC)~")
            19
                (return "~USD USED(alias)~VAL VAL(expC)~VAR VARREAD()~VER VERSION()~WCO WCOLS(expC)~WEX WEXIST(expC)~WLC WLCOL(expC)~WLR WLROW(expC)~WON WONTOP(expC)~WOU WOUTPUT(expC)~")
            20
                (return "~WRO WROWS(expC)~WVI WVISIBLE(expC)~YEA YEAR(expD)~")
            NULL
                (return 20)
        )
    )
)
(macro _set_table
    (
        (int                table_number
        )
        (get_parm 0 table_number)
        (switch table_number
            1
                (return "~SALT SET ALTERNATE ~SBEL SET BELL ~SBLO SET BLOCKSIZE ~SBOR SET BORDER TO ~SCAR SET CARRY TO ~SCAT SET CATALOG TO ~SCEN SET CENTURY ~SCOL SET COLOR TO ~")
            2
                (return "~SCUR SET CURRENCY TO ~SCON SET CONSOLE ~SDEB SET DEBUG ~SDEC SET DECIMALS TO ~SDEF SET DEFAULT TO ~SDEL SET DELETED ~SDEV SET DEVICE TO ~SDIS SET DISPLAY TO ~")
            3
                (return "~SENC SET ENCRYPTION ~SESC SET ESCAPE ~SEXC SET EXCLUSIVE ~SFIE SET FIELDS TO ~SFIL SET FILTER TO ~SFOR SET FORMAT TO ~SFUL SET FULLPATH ~SFUN SET FUNCTION ~")
            4
                (return "~SHEA SET HEADING ~SHIS SET HISTORY ~SHOU SET HOURS TO ~SIND SET INDEX TO ~SINT SET INTENSITY ~SLOC SET LOCK ON ~SMAR SET MARGIN TO ~SMEM SET MEMOWIDTH TO ~")
            5
                (return "~SMES SET MESSAGE TO ~SNEA SET NEAR ~SODO SET ODOMETER TO ~SORD SET ORDER TO ~SPAT SET PATH TO ~SPRI SET PRINTER ~SPRN SET PRINTER TO ~SPRO SET PROCEDURE TO ~")
            6
                (return "~SREL SET RELATION TO ~SSAF SET SAFETY ~SSCO SET SCOREBOARD ~SSPA SET SPACE ~SSTA SET STATUS ~STYP SET TYPEAHEAD TO ~SUNI SET UNIQUE ~SVIE SET VIEW TO ~")
            7
                (return "~SWIN SET WINDOW OF MEMO TO ~")
            NULL
                (return 7)
        )
    )
)
;dBASE IV Commenting Macros
(macro _uncomment_conditionals
    (
        (int                display_messages
        )
        (get_parm 0 display_messages)
        (if display_messages
            (message "Uncommenting conditional statements...")
        )
        (save_position)
        (translate "&& if*>" "" 1 1 0)
        (translate "&& do w*>" "" 1 1 0)
        (translate "&& do c*>" "" 1 1 0)
        (translate "&& begi*>" "" 1 1 0)
        (translate "&& scan*>" "" 1 1 0)
        (restore_position)
        (if display_messages
            (_display_popup_message "Uncommenting complete." "" 0)
        )
    )
)
;dBASE IV Conditional Graphics Macros
(macro _insert_graphics
    (
        (int            dbr_insert_col
                        kk
        )
        (string        orig_line
                        token
                        sql_extension
                        _numbers
                        _graphics
        )
        (get_parm 0 _numbers)
        (get_parm 1 orig_line)
        (get_parm 2 _graphics)
        (= token (substr (upper orig_line) 1 4))
        (if (= dbr_insert_col (search_string "[ \\t]" token NULL 1))
            (= token (substr token 1 (-- dbr_insert_col)))
        )
        (= dbr_insert_col curr_indent_col)
        (if (&& (strlen token) (index (_dialect_table) (+ token " ")))
            (= dbr_insert_col (_indent_shift token orig_line dbr_insert_col))
        )
        (delete_to_eol)
        (beginning_of_line)
        (insert _numbers)
        (move_abs 0 (+ (strlen _numbers) dbr_insert_col))
        (insert orig_line)
        (if (== (upper _graphics) "Y")
            (
                (if (> (strlen token) 0)
                    (
                        (if (index "PROC~FUNC~IF~CASE~OTHE~BEGI~SCAN~" token)
                            (
                                (move_abs 0 (+ (strlen _numbers) dbr_insert_col))
                                (insert "┌")
                            )
                        )
                        (if (index "DO" token)
                            (
                                (if (|| (search_string "DO[ \t]+WHIL" orig_line NULL 1 0)(search_string "DO[ \t]+CASE" orig_line NULL 1 0))
                                    (
                                        (move_abs 0 (+ (strlen _numbers) dbr_insert_col))
                                        (insert "┌")
                                    )
                                )
                            )
                        )
                        (if (index "ELSE" token)
                            (
                                (move_abs 0 (+ (strlen _numbers) dbr_insert_col))
                                (insert "├")
                            )
                        )
                        (if (index "ENDI~ENDD~ENDC~ENDS~END" token)
                            (
                                (move_abs 0 (+ (strlen _numbers) dbr_insert_col))
                                (insert "└")
                            )
                        )
                        (if (== (substr (upper orig_line) 1 6) "RETURN")
                            (
                                (move_abs 0 (+ (strlen _numbers) dbr_insert_col))
                                (insert "└")
                            )
                        )
                    )
                )
                (move_abs 0 (+ (strlen _numbers) dbr_insert_col))
                (= kk (+ (strlen _numbers) dbr_insert_col))
                (while (> kk (+ (strlen _numbers) dbr_indent_level))
                    (
                        (-= kk dbr_indent_level)
                        (move_abs 0 kk)
                        (insert "│")
                    )
                )
            )
        )
        (move_rel 1 0)
        (beginning_of_line)
    )
)