--- \ dil functions load screen 10/10/85 60 load \ get string functions next_screen 19 loads --- \ all_req hpib_req errcheck : all_req ( n _ 'a'<<8|n ) \ convert n to 'all' ioctl request 97 ( a ) << << << << << << << << or ; : hpib_req ( n _ 'h'<<8|n ) \ convert n to hpib ioctl request 104 ( h ) << << << << << << << << or ; : gpio_req ( n _ 'g'<<8|n ) \ convert n to gpio ioctl request 103 ( g ) << << << << << << << << or ; : errcheck ( n _ ) \ generate error message if n == -1 $stack_empty? \ error if function name not on stack -1 = if cr ." error in " \ if n == -1 then output error message $. cr (abort) \ and function name from stack, abort else ($drop) \ else drop the function name endif ; --- \ dopen dclose byte_array : dopen ( _ ) \ open top string on string stack 2 0 open \ attempt to open driver dup . \ display fd returned " open" errcheck ; \ dil functions load screen 12/23/86 " forth.data" 60 fload \ get string functions 10 19 loads \ error messages 11/25/86 empty stack dictionary full wrong addressing mode isn't unique out of range disc range ? full stack disc error ! string stack empty string stack overflow can't redirect input string too small wrong operand size Hewlett Packard Integral Personal Computer forth \ error messages compilation only, use in definition execution only conditionals not paired definition not finished in protected dictionary use only when loading off current editing screen declare vocabulary \ all_req hpib_req errcheck : all_req ( n _ 'a'<<8|n ) \ convert n to 'all' ioctl request 97 ( a ) << << << << << << << << or ; : hpib_req ( n _ 'h'<<8|n ) \ convert n to hpib ioctl request 104 ( h ) << << << << << << << << or ; : gpio_req ( n _ 'g'<<8|n ) \ convert n to gpio ioctl request 103 ( g ) << << << << << << << << or ; : errcheck ( n _ ) \ generate error message if n == -1 $stack_empty? \ error if function name not on stack -1 = if cr ." error in " \ if n == -1 then output error message $. cr (abort) \ and function name from stack, abort else ($drop) \ else drop the function name endif ; \ dopen dclose byte_array : dopen ( _ ) \ open top string on string stack 2 0 open \ attempt to open driver dup . \ display fd returned " open" errcheck ; \ if open failed : dclose ( fd _ ) \ close hpib driver " close" errcheck ; \ if close failed, error : byte_array \ compiling: size _ \ interpreting: _ addr of first byte of array ; \ cmd_str hpib_send_command 5/31/85 8 byte_array cmd_str : hpib_send_command ( fd _ ) \ send string with ATN set $stack_empty? \ error if no string $sp@ strlen \ get addr and len of string cmd_str 4+ ! \ store length in cmd_str structure cmd_str ! \ store addr in cmd_str structure 38 hpib_req \ get ioctl request code cmd_str \ get address of cmd_str structure ioctl \ do ioctl " hpib_send_command" errcheck \ check for error ($drop) ; \ drop string from stack \ talk listen 5/31/85 : talk ( fd talk_addr _ ) \ send talk address 0 max 30 min \ bounds check address 64 or chr$ \ convert talk address to string hpib_send_command ; \ send talk command : listen ( fd listen_addr _ ) \ send listen address 0 max 30 min \ bounds check address 32 or chr$ \ convert listen address to string hpib_send_command ; \ send listen command \ untalk unlisten 5/31/85 : untalk ( fd _ ) \ send untalk command " _" hpib_send_command ; : unlisten ( fd _ ) \ send unlisten command " ?" hpib_send_command ; \ $out crout : $out ( fd _ ) \ output the top string on the stack $stack_empty? \ error if no string $sp@ strlen \ get addr and length of string write \ write string out " $out" errcheck \ check for errors ($drop) ; \ drop string : crout ( fd _ ) \ output a NL 10 chr$ $out ; \ $in 10/10/85 : $in ( fd count _ ) \ read string from hpib pad \ address to read data into swap \ number of bytes to read (max) read dup \ do the read and dup the result " read" errcheck \ check for errors pad + 0 swap c! \ put a null at end of string read pad $@ ; \ fetch string to stack \ reset timeout : reset ( fd _ ) \ reset the hpib card 0 all_req \ get ioctl request code 0 \ arg is ignored for this ioctl ioctl \ do the ioctl " reset" errcheck ; : timeout ( fd timeout _ ) \ set timeout (in microseconds) pad ! \ save timeout value at pad 7 all_req \ get ioctl request code pad \ arg is address of timeout value ioctl \ do the ioctl " timeout" errcheck ; \ term_reason hpib_eoi_ctl 5/31/85 : term_reason ( fd _ term_reason ) \ get reason for last read 250 all_req \ get ioctl request value pad \ arg is addr of term_reason ioctl \ do the ioctl " term_reason" errcheck pad @ ; \ fetch term_reason to stack : hpib_eoi_ctl ( fd flag _ ) \ if flag<>0, set EOI 32 hpib_req \ get ioctl request value swap ioctl \ arg is flag, do ioctl " hpib_eoi_ctl" errcheck ; \ io_eol_ctl hpib_ren_ctl : io_eol_ctl ( fd flag match _ ) \ set EOL termination char pad 4 + ! \ store match char at pad+4 pad ! \ store flag at pad 249 all_req \ get ioctl request value pad \ arg is address of eol structure ioctl \ do the ioctl " io_eol_ctl" errcheck ; : hpib_ren_ctl ( fd flag _ ) \ control REN line state 36 hpib_req \ get ioctl request value swap ioctl \ arg is flag, do ioctl " hpib_ren_ctl" errcheck ; \ hpib_ppoll hpib_spoll : hpib_ppoll ( fd _ response ) \ do a parallel poll 0 hpib_req \ get ioctl request value pad ioctl \ arg is addr of response byte " hpib_ppoll" errcheck pad @ ; \ fetch response byte to stack : hpib_spoll ( fd bus_address _ response ) \ do a serial poll pad ! \ save bus address at pad 12 hpib_req \ get ioctl request value pad ioctl \ arg is addr of spoll data structure " hpib_spoll" errcheck pad 4+ c@ ; \ fetch response byte to stack \ hpib_rqst_srvce hpib_abort : hpib_rqst_srvce ( fd resp_byte _ ) \ set spoll response byte 37 hpib_req \ get ioctl request value swap ioctl \ arg is spoll response byte " hpib_rqst_srvce" errcheck ; : hpib_abort ( fd _ ) \ abort all bus activity 8 hpib_req \ get ioctl request value 0 ioctl \ arg is ignored " hpib_abort" errcheck ; \ hpib_pass_ctl hpib_bus_status 10/3/85 : hpib_pass_ctl ( fd bus_addr _ ) \ pass control 33 hpib_req \ get ioctl request value swap ioctl \ arg is bus addr of new controller " hpib_pass_ctl" errcheck ; : hpib_bus_status ( fd status_number _ ) \ return status info pad ! \ save status number at pad 31 hpib_req \ get ioctl request value pad ioctl \ arg is addr of bus status structure " hpib_bus_status" errcheck pad 4+ @ ; \ fetch current status to stack \ hpib_ppoll_resp_ctl hpib_card_ppoll_resp : hpib_ppoll_resp_ctl ( fd flag _ ) \ enable/disable ppoll 41 hpib_req \ get ioctl request value swap ioctl \ arg is ppoll enable/disable flag " hpib_ppoll_resp_ctl" errcheck ; : hpib_card_ppoll_resp ( fd flag _ ) \ set up ppoll 35 hpib_req \ get ioctl request value swap ioctl \ arg is ppoll response flag " hpib_card_ppoll_resp" errcheck ; \ hpib_wait_on_ppoll hpib_status_wait 10/3/85 : hpib_wait_on_ppoll ( fd mask sense _ result ) \ wait for ppoll pad 4+ ! \ save sense at pad+4 pad ! \ save mask at pad 39 hpib_req \ get ioctl request value pad ioctl \ arg is addr of structure at pad " hpib_wait_on_ppoll" errcheck pad 8 + @ ; \ get ppoll result : hpib_status_wait ( fd status _ ) \ wait until status true 40 hpib_req \ get ioctl request value swap ioctl \ arg is desired status byte " hpib_status_wait" errcheck ; \ io_width_ctl io_speed_ctl 10/11/85 : io_width_ctl ( fd width _ ) \ select width of transfers 244 all_req \ get ioctl request value swap ioctl \ arg is width " io_width_ctl" errcheck ; : io_speed_ctl ( fd speed _ ) \ select speed of transfers 243 all_req \ get ioctl request value swap ioctl \ arg is speed " io_speed_ctl" errcheck ; \ gpio_get_status gpio_set_ctl : gpio_get_status ( fd _ status ) \ get status of gpio 2 gpio_req \ get ioctl request value pad ioctl \ arg is addr to put status " gpio_get_status" errcheck pad @ ; \ get status to stack : gpio_set_ctl ( fd value _ ) \ set gpio ctl lines 3 gpio_req \ get ioctl request value swap ioctl \ arg is value " gpio_set_ctl" errcheck ; \ gpio_delay_time_ctl gpio_handshake_ctl 10/10/85 : gpio_delay_time_ctl ( fd time _ ) \ set gpio delay time 4 gpio_req \ get ioctl request value swap ioctl \ arg is time to delay " gpio_delay_time_ctl" errcheck ; : gpio_handshake_ctl ( fd value _ ) \ set gpio handshake type 5 gpio_req \ get ioctl request value swap ioctl \ arg is handshake type " gpio_handshake_ctl" errcheck ; \ gpio_normalize_ctl read_reg 10/8/85 : gpio_normalize_ctl ( fd value _ ) \ set gpio normalization 6 gpio_req \ get ioctl request value swap ioctl \ arg is normalization value " gpio_normalize_ctl" errcheck ; : read_reg ( fd port reg _ ) \ read a register in a gpio port pad 4 + ! \ store register number at pad+4 pad ! \ store port number at pad pad 12 + pad 8 + ! \ store pointer to result in pad+8 0 gpio_req \ set up ioctl parameters pad ioctl " read_reg" errcheck pad 12 + @ ; \ get regval