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

Text File | 1991-03-21 | 11.1 KB | 420 lines

;dBRIEF Generate  - v3.10
;Copyright (c) 1991 - Global Technologies Corporation
;ALL RIGHTS RESERVED
#include "dbrief.h"
(macro stor
    (
        (if (_get_dialect_info dbr_dialect 6)
            (
                (string            scatter_file
                )
                (if (get_parm 0 scatter_file "Database file to store to memars: ")
                    (_generate_fields scatter_file "S")
                )
            )
        ;else
            (
                (_display_popup_message "STORE not supported in %s!" (_get_dialect_info dbr_dialect 1) 1)
                (return 0)
            )
        )
    )
)
(macro scat
    (
        (if (_get_dialect_info dbr_dialect 6)
            (
                (string            scatter_file
                )
                (if (get_parm 0 scatter_file "Database file to scatter: ")
                    (_generate_fields scatter_file "=")
                )
            )
        ;else
            (
                (_display_popup_message "SCATTER not supported in %s!" (_get_dialect_info dbr_dialect 1) 1)
                (return 0)
            )
        )
    )
)
(macro gath
    (
        (if (_get_dialect_info dbr_dialect 6)
            (
                (string            gather_file
                )
                (if (get_parm 0 gather_file "Database file to gather: ")
                    (_generate_fields gather_file "R")
                )
            )
        ;else
            (
                (_display_popup_message "GATHER not supported in %s!" (_get_dialect_info dbr_dialect 1) 1)
                (return 0)
            )
        )
    )
)
(macro init
    (
        (if (_get_dialect_info dbr_dialect 6)
            (
                (string        _dbf_file
                )
                (if (get_parm 0 _dbf_file "Database file name: ")
                    (_generate_fields _dbf_file "I")
                )
            )
        ;else
            (
                (_display_popup_message "INITIALIZE not supported in %s!" (_get_dialect_info dbr_dialect 1) 1)
                (return 0)
            )
        )
    )
)
(macro _create_routine_from_block
    (
        (int                function_column
                            routine_line
                            routine_col
                            routine_start_line
                            routine_start_col
                            routine_end_line
                            routine_end_col
                            routine_orig_buffer
                            routine_dest_buffer
        )
        (string            routine_name
                            routine_prompt
                            routine_return
                            routine_mask
                            routine_exec
                            routine_comment
                            header_file
                            routine_temp_str
                            routine_destination
                            routine_suffix
        )
        (get_parm 0 routine_prompt)
        (get_parm 1 routine_return)
        (get_parm 2 header_file)
        (get_parm 3 routine_mask)
        (get_parm 4 routine_exec)
        (inq_names NULL NULL temp_str)
        (if (get_parm 5 routine_name (+ routine_prompt " name: "))
            (
                (if (! (get_parm 6 routine_comment "Comment: "))
                    (return)
                )
                (if (! (get_parm 7 routine_destination "Destination file: " NULL temp_str))
                    (return)
                )
                (inq_marked routine_start_line routine_start_col routine_end_line routine_end_col)
                (raise_anchor)
                (if (|| (== (upper temp_str) (upper (+ routine_name (+ "." (_get_dialect_info dbr_dialect 3))))) (search_fwd (+ (+ (+ "<" routine_mask) "*{ @}|{\\t@}") routine_name) 1 0))
                    (
                        (_display_popup_message (+ routine_prompt " %s already exists as a file or function!") (upper routine_name) 1)
                        (move_abs routine_start_line routine_start_col)
                        (mark 4)
                        (move_abs (+ routine_end_line 1) 1)
                    )
                ;else
                    (
                        (move_abs routine_start_line routine_start_col)
                        (drop_anchor)
                        (move_abs routine_end_line routine_end_col)
                        (cut)
                        (save_position)
                        (up)
                        (end_of_line)
                        (insert "\n")
                        (inq_position routine_start_line routine_start_col)
                        (if (== routine_prompt "Procedure")
                            (_case_insert (+ (+ (_execute_command) (+ routine_exec " ")) routine_name) 0 0)
                        ;else
                            (_case_insert (+ routine_name "()") 0 0)
                        )
                        (if (!= (upper routine_destination) (upper temp_str))
                            (
                                (= routine_orig_buffer (inq_buffer))
                                (edit_file routine_destination)
                                (= routine_dest_buffer (inq_buffer))
                            )
                        )
                        (end_of_buffer)
                        (insert "\n\n")
                        (save_position)
                        (inq_position routine_line NULL)
                        (if (& (inq_kbd_flags) 0x40)
                            (_procedure_header (upper routine_prompt) routine_return header_file)
                        ;else
                            (_procedure_header (lower routine_prompt) routine_return header_file)
                        )
                        (if (== dbr_dialect 9)
                            (_case_insert (+ " " (+ routine_name "()\n")) 0 0)
                        ;else
                            (_case_insert (+ " " (+ routine_name "\n")) 0 0)
                        )
                        (paste)
                        (delete_line)
                        (delete_line)
                        (if (strlen ProcSuffix)
                            (
                                (end_of_line)
                                (sprintf routine_suffix ProcSuffix routine_name routine_name)
                                (insert routine_suffix)
                                (up)
                                (up)
                            )
                        )
                        (up)
                        (beginning_of_line)
                        (search_fwd "<*\\c[~ \\t\\n]")
                        (inq_position NULL function_column)
                        (search_back (+ "<" routine_mask) 1 0)
                        (beginning_of_line)
                        (drop_anchor)
                        (search_fwd (+ "<" routine_return) 1 0)
                        (down)
                        (rein 0)
                        (restore_position)
                        (if (!= (upper routine_destination) (upper temp_str))
                            (
                                (write_buffer)
                                (set_buffer routine_orig_buffer)
                                (attach_buffer routine_orig_buffer)
                                (if (!= routine_orig_buffer routine_dest_buffer)
                                    (delete_buffer routine_dest_buffer)
                                )
                            )
                        ;else
                            (if (== dbr_dialect 9)
                                (
                                    (drop_anchor 3)
                                    (end_of_buffer)
                                    (cut)
                                )
                            )
                        )
                        (restore_position)
                        (= routine_temp_str (read))
                        (beginning_of_line)
                        (delete_to_eol)
                        (move_abs 0 function_column)
                        (insert routine_temp_str)
                        (delete_line)
                        (up)
                        (end_of_line)
                        (if (== routine_prompt "Procedure")
                            (move_rel 0 1)
                        ;else
                            (move_rel 0 -1)
                        )
                        (if (strlen routine_comment)
                            (_write_comment routine_comment)
                        )
                          (move_abs routine_start_line routine_col)
                        (if (&& (== dbr_dialect 9)(== (upper routine_destination) (upper temp_str)))
                            (
                                (top_of_buffer)
                                (paste)
                                (move_rel (- routine_start_line 1) 0)
                                (= routine_line 1)
                            )
                        )
                        (sprintf routine_temp_str "%s %s created at line %d in %s." routine_prompt (upper routine_name) routine_line routine_destination)
                        (_display_popup_message routine_temp_str "" 0)
                    )
                )
            )
        )
    )
)
(macro _write_comment
    (
        (string            comment_string
                            comment_read
        )
        (get_parm 0 comment_string)
        (save_position)
        (beginning_of_line)
        (= comment_read (read))
        (if (|| (== comment_read " ")(== comment_read "\n"))
            (
                (delete_to_eol)
                (insert (+ (_comment_character 2) (+ " " comment_string)))
            )
        ;else
            (
                (if (|| (== dbr_comment_tab 0)(> (strlen comment_read) dbr_comment_tab))
                    (
                        (end_of_line)
                        (right)
                        (right)
                    )
                ;else
                    (move_abs 0 dbr_comment_tab)
                )
                (delete_to_eol)
                (insert (+ (+ (_comment_character 1) " ") comment_string))
            )
        )
        (restore_position)
    )
)
(macro _substitute_window_coordinates
    (
        (int                beg_line
                            beg_col
                            end_line
                            end_col
                            top_line
                            current_line
                            current_column
        )
        (string            coordinate_string
        )
        (if (== (inq_marked) 2)
            (
                (drop_bookmark 5 "y")
                (top_of_window)
                (inq_position top_line NULL)
                (goto_bookmark 5)
                (inq_marked beg_line beg_col end_line end_col)
                (-= beg_line top_line)
                (-= end_line top_line)
                (-- beg_col)
                (-- end_col)
                (raise_anchor)
                (top_of_buffer)
                (if (search_fwd "^UX,^UY*^LX,^LY" 1 0)
                    (
                        (inq_position current_line current_column)
                        (sprintf coordinate_string "%02d" beg_line)
                        (translate "^ux" coordinate_string 1 0 0)
                        (sprintf coordinate_string "%02d" beg_col)
                        (translate "^uy" coordinate_string 1 0 0)
                        (sprintf coordinate_string "%02d" end_line)
                        (translate "^lx" coordinate_string 1 0 0)
                        (sprintf coordinate_string "%02d" end_col)
                        (translate "^ly" coordinate_string 1 0 0)
                        (move_abs current_line current_column)
                    )
                ;else
                    (_display_popup_message "Window coordinates not found!" "" 1)
                )
            )
        ;else
            (_display_popup_message "No column mark present!" "" 1)
        )
    )
)
(macro _reverse_window_coordinates
    (
        (int              top_line
                            current_line
                            current_column
                            beg_line
                            beg_col
                            end_line
                            end_col
                            coord_position
        )
        (string            coordinate_string
        )
        (save_position)
        (beginning_of_line)
        (= coordinate_string (read))
        (restore_position)
        (if (search_string "{ CLEA TO }|{ CLEAR TO }|{ FILL TO }|{ TO }|{[0-9][0-9],[0-9][0-9],[0-9][0-9],[0-9][0-9]}" (upper coordinate_string) NULL 1)
            (
                (beginning_of_line)
                (drop_anchor)
                (end_of_line)
                (if (index (upper coordinate_string) " CLEAR TO ")
                    (
                        (= coordinate_string (ltrim (trim (substr coordinate_string (- (index (upper coordinate_string) " CLEAR TO ") 5) 20))))
                        (translate coordinate_string "^ux,^uy clear to ^lx,^ly" 0 0 0 1)
                        (= coord_position 16)
                    )
                ;else
                    (if (index (upper coordinate_string) " CLEA TO ")
                        (
                            (= coordinate_string (ltrim (trim (substr coordinate_string (- (index (upper coordinate_string) " CLEA TO ") 5) 19))))
                            (translate coordinate_string "^ux,^uy clea to ^lx,^ly" 0 0 0 1)
                            (= coord_position 15)
                        )
                    ;else
                        (if (index (upper coordinate_string) " FILL TO ")
                            (
                                (= coordinate_string (ltrim (trim (substr coordinate_string (- (index (upper coordinate_string) " FILL TO ") 5) 19))))
                                (translate coordinate_string "^ux,^uy fill to ^lx,^ly" 0 0 0 1)
                                (= coord_position 15)
                            )
                        ;else
                            (if (index (upper coordinate_string) " TO ")
                                (
                                    (= coordinate_string (ltrim (trim (substr coordinate_string (- (index (upper coordinate_string) " TO ") 5) 14))))
                                    (translate coordinate_string "^ux,^uy to ^lx,^ly" 0 0 0 1)
                                    (= coord_position 10)
                                )
                            ;else
                                (if (search_string "{[0-9][0-9],[0-9][0-9],[0-9][0-9],[0-9][0-9]}" coordinate_string NULL 1)
                                    (
                                        (= coord_position (search_string "{[0-9][0-9],[0-9][0-9],[0-9][0-9],[0-9][0-9]}" coordinate_string NULL 1))
                                        (= coordinate_string (ltrim (trim (substr coordinate_string coord_position 11))))
                                        (translate coordinate_string "^ux,^uy,^lx,^ly" 0 0 0 1)
                                        (= coord_position 7)
                                    )
                                )
                            )
                        )
                    )
                )
                (raise_anchor)
                (= beg_line (atoi (substr coordinate_string 1 2) 1))
                (= beg_col (atoi (substr coordinate_string 4 2) 1))
                (= end_line (atoi (substr coordinate_string coord_position 2) 1))
                (= end_col (atoi (substr coordinate_string (+ coord_position 3) 2) 1))
                (drop_bookmark 5 "y")
                (top_of_window)
                (inq_position top_line NULL)
                (goto_bookmark 5)
                (+= beg_line top_line)
                (+= end_line top_line)
                (++ beg_col)
                (++ end_col)
                (move_abs beg_line beg_col)
                (drop_anchor 2)
                (move_abs end_line end_col)
                (return 1)
            )
        ;else
            (return 0)
        )
    )
)
(macro coor
    (
        (switch dbr_dialect
            1  NULL
            2  NULL
            6  NULL
            7  NULL
            11 NULL
            13 NULL
            12
                (_case_insert "^UX,^UY,^LX,^LY" 0 0)
            3  NULL
            4  NULL
            5  NULL
            8  NULL
            9  NULL
            10
                (_case_insert "^UX,^UY TO ^LX,^LY" 0 0)
        )
    )
)