\ CRC: $6C5F3DAB #romversion &146 checkrom #version &132 checkversion forget-application Vocabulary Application &14032006 Constant #date $21 constant #cis_fun $15 constant #cis_ver $1b constant #cis_ce $ff constant #cis_eol : skip_cis 2 + ; : read_cis dup 2 + swap word@ ; : next_tup 2* + ; : cis_check BEGIN read_cis #cis_eol = IF drop false exit THEN read_cis next_tup dup #sector_buf $200 + < 0= UNTIL drop true ; here &1000 , &1200 , &1300 , &1500 , &2000 , &2500 , &3000 , &3500 , &4000 , &4500 , &5000 , &5500 , &6000 , &7000 , &8000 , &9000 , constant mantisse_tab here &10000000 , &1000000 , &100000 , &10000 , &00001000 , &0000100 , &000010 , &00001 , constant exponent_tab $01 constant #cis_ce_conf_16r $3F constant #cis_ce_conf_idx $40 constant #cis_ce_conf_def $80 constant #cis_ce_conf_itf $01 constant #cis_ce_powerinf $80 constant #cis_ce_ext $78 constant #cis_ce_mantisse $07 constant #cis_ce_exponent $40 constant #cis_ce_pdown_i $20 constant #cis_ce_peak_i $10 constant #cis_ce_avg_i $08 constant #cis_ce_static_i $04 constant #cis_ce_max_u $02 constant #cis_ce_min_u $01 constant #cis_ce_nom_u : cis_curr read_cis >r r@ #cis_ce_mantisse and -3 shift mantisse_tab + @ r@ #cis_ce_ext and IF swap read_cis &10 * rot + THEN r> #cis_ce_exponent and exponent_tab + @ / ; : cis_volt read_cis >r r@ #cis_ce_mantisse and -3 shift mantisse_tab + @ r@ #cis_ce_ext and IF swap read_cis &10 * rot + THEN &100 * r> #cis_ce_exponent and exponent_tab + @ / ; variable def_voltage variable min_voltage variable mode_invalid : eval_ce_16r #cis_ce_conf_itf and IF skip_cis THEN read_cis #cis_ce_powerinf and IF read_cis >r r@ #cis_ce_nom_u and IF cis_volt def_voltage ! THEN r@ #cis_ce_min_u and IF cis_volt drop THEN r@ #cis_ce_max_u and IF cis_volt drop THEN r@ #cis_ce_static_i and IF cis_curr drop THEN r@ #cis_ce_avg_i and IF cis_curr drop THEN r@ #cis_ce_peak_i and IF cis_curr drop THEN r> #cis_ce_pdown_i and IF cis_curr drop THEN THEN ; : eval_ce_def #cis_ce_conf_itf and IF skip_cis THEN read_cis #cis_ce_powerinf and IF read_cis #cis_ce_nom_u and IF cis_volt def_voltage ! THEN THEN ; : cis_ce &5000 min_voltage ! mode_invalid on BEGIN read_cis dup #cis_eol <> WHILE #cis_ce = IF dup >r skip_cis read_cis >r r@ #cis_ce_conf_idx and #cis_ce_conf_16r = r@ #cis_ce_conf_def and or IF r@ #cis_ce_conf_idx and #cis_ce_conf_16r = 0= IF r> eval_ce_def ELSE r> eval_ce_16r min_voltage @ def_voltage @ min min_voltage ! mode_invalid off THEN ELSE rdrop THEN drop r> THEN read_cis next_tup REPEAT 2drop mode_invalid @ ; : cis_string BEGIN read_cis ?dup WHILE #cis_eol xor dup 0=exit #cis_eol xor emit REPEAT true ; : cis_vend BEGIN read_cis dup #cis_eol <> WHILE #cis_ver = IF ." [" skip_cis read_cis $30 + emit ." ." read_cis $30 + emit ." ]" BEGIN ." " cis_string 0= UNTIL drop false exit THEN read_cis next_tup REPEAT 2drop true ; $04 constant #cis_fun_disk : cis_fun BEGIN read_cis dup #cis_eol <> WHILE #cis_fun = IF skip_cis read_cis #cis_fun_disk = IF ." Disk:" ELSE ." Card:" THEN drop false exit THEN read_cis next_tup REPEAT 2drop true ; : eval_cis_3v3 #sector_buf dup readcis dup cis_check IF drop true ELSE cis_ce THEN ; : eval_cis_disk? #sector_buf dup readcis dup cis_check IF drop true ELSE cis_fun THEN ; : eval_cis_name #sector_buf dup readcis dup cis_check IF drop true ELSE cis_vend THEN ; NV Variable _cis_enable : SET_ADAPTER DUP #SLOTS-1 U> IF 2 DISKERROR THEN DUP CURR_ADAPTER @ <> IF CURR_ADAPTER @ 1+ IF FALL_ASLEEP THEN DUP CARD_PRESENT? 0= IF 4 DISKERROR THEN DUP CARD_SELECT CURR_ADAPTER ! SOFT_RESET_PCM _CIS_ENABLE @ IF &5000 def_voltage ! eval_cis_3v3 IF ." (?) " THEN min_voltage @ &3300 = IF pcm_3v soft_reset_pcm THEN FALL_ASLEEP THEN ELSE DROP THEN ; ' 2* Alias >baddr Code bc@ 1 # AR2 TSTB, NZ IFD, -1 # AR2 LSH, AR2 *) AR2 LDI, NOP, -8 # AR2 LSH, THEN, NEXTD, $FF # AR2 AND, NOP, NOP, end-code Code bw@ 1 # AR2 TSTB, NZ IFD, -1 # AR2 LSH, AR2 *++) AR1 LDI, AR2 *) AR2 LDI, NEXTD, $FF00 # AR1 AND, $FF # AR2 AND, AR1 AR2 OR, THEN, AR1 AR2 LDI, 8 # AR1 LSH, $FF00 # AR1 AND, NEXTD, -8 # AR2 LSH, $FF # AR2 AND, AR1 AR2 OR, end-code : b@ dup bw@ $10 shift swap 2+ bw@ or ; : cdump base push hex bounds ?DO CR I 6 U.R ." :" I 2* 8 bounds DO I bc@ space 0 <# # # #> type LOOP space I 4 + 2* 8 bounds DO I bc@ space 0 <# # # #> type LOOP space I 2* $10 bounds DO I bc@ emit LOOP stop? abort" aborted" 8 +LOOP space ; : btype bounds DO I bc@ emit LOOP ; : modcr ; variable sequ_state LABEL everlasting UARTSTAT #) R1 LDI, #DTRUART # R1 AND, NZ IF, T0PERIOD #) R0 LDI, #T0PERIOD # R0 CMPI, AR0 BHS, 0 # RPTS, $2000 # ST ANDN, NOP, NOP, #CPU_FAST # R0 LDI, R0 DEV_CTRL #) STI, T0Ctrl #) R0 ldi, $C0 # R0 andn, R0 T0Ctrl #) sti, T0PERIOD #) R0 LDI, 4 # R0 LSH, R0 T0PERIOD #) STI, T0CTR #) R0 LDI, 4 # R0 LSH, R0 T0CTR #) STI, T0Ctrl #) R0 ldi, $80 # R0 or, R0 T0Ctrl #) sti, $2000 # ST OR, AR0 BU, ELSE, T0PERIOD #) R0 LDI, #T0PERIOD # R0 CMPI, HS IF, 0 # RPTS, $2000 # ST ANDN, NOP, NOP, T0Ctrl #) R0 ldi, $C0 # R0 andn, R0 T0Ctrl #) sti, T0PERIOD #) R0 LDI, -4 # R0 LSH, R0 T0PERIOD #) STI, T0CTR #) R0 LDI, -4 # R0 LSH, R0 T0CTR #) STI, T0Ctrl #) R0 ldi, $80 # R0 or, R0 T0Ctrl #) sti, #CPU_SLOW # R0 LDI, R0 DEV_CTRL #) STI, $2000 # ST OR, THEN, SEQU_STATE AR1#LDI, AR1 *) R1 LDI, 1 # R1 SUBI, AR0 BNZ, $FFFF # RPTS, NOP, AR0 BU, THEN, END-CODE : idle_server everlasting poll quit ; LABEL my_(watchdog 0 # RPTS, $2000 # ST ANDN, ticks AR0#LDI, R0 WDFLAG1 #) STI, R0 WDFLAG2 #) STI, $2000 # ST OR, AR0 *) R0 LDI, AR0 3 # +*) R0 SUBI, RETSEQ, R0 ROLC, RETSC, BEGIN, AGAIN, END-CODE LABEL my_tickerint ST PUSH, $2000 # ST OR, AR1 PUSH, R0 PUSH, TICKS AR1#LDI, AR1 0 # +*) R0 LDI, 1 # R0 ADDI, R0 AR1 0 # +*) STI, AR1 1 # +*) R0 LDI, NZ IF, 1 # R0 SUBI, R0 AR1 1 # +*) STI, Z IF, AR1 2 # +*) R0 LDI, R0 AR1 1 # +*) STI, AR1 5 # +*) R0 LDI, Z IF, T1CTRL #) R0 LDI, 4 # R0 XOR, ELSE, AR1 4 # +*) R0 LDI, Z IF, AR1 5 # +*) R0 LDI, R0 AR1 4 # +*) STI, THEN, 1 # R0 TSTB, Z IFD, -1 # R0 LSH, NOP, R0 AR1 4 # +*) STI, T1CTRL #) R0 LDI, 4 # R0 OR, ELSE, T1CTRL #) R0 LDI, 4 # R0 ANDN, THEN, THEN, R0 T1CTRL #) STI, THEN, THEN, AR1 6 # +*) R0 LDI, NZ IF, T1CTRL #) R0 LDI, 2 # R0 ANDN, R0 T1CTRL #) STI, ELSE, T1CTRL #) R0 LDI, 2 # R0 OR, R0 T1CTRL #) STI, THEN, AR1 7 # +*) R0 LDI, Z IF, SEQU_STATE AR1#LDI, AR1 *) AR1 LDI, 1 # AR1 SUBI, UARTSTAT #) R0 LDI, #DTRUART # R0 AND, AR1 R0 OR, NZ IF, #adm_slow # R0 LDI, R0 dev_ctrl #) STI, #peri_on # R0 LDI, R0 dev_ctrl #) STI, ELSE, #adm_slow # R0 LDI, R0 dev_ctrl #) STI, #peri_off # R0 LDI, R0 dev_ctrl #) STI, THEN, ELSE, 1 # R0 CMPI, EQ IF, #adm_slow # R0 LDI, R0 dev_ctrl #) STI, #peri_on # R0 LDI, R0 dev_ctrl #) STI, ELSE, #adm_fast # R0 LDI, R0 dev_ctrl #) STI, #peri_on # R0 LDI, R0 dev_ctrl #) STI, THEN, THEN, R0 POP, AR1 POP, ST POP, RETIU, END-CODE NV Variable _boot_delay : link_watchdog $62000000 or priority ! ; : feed_watchdog ticks @ + ticks 3 + ! ; : send_morse ticks 4 + off ticks 5 + ! ; : err_boot _boot_delay @ 2* 1 max _boot_delay ! flush-erom flush-errors #100ms sleep boot ; : print-errors flush-erom errors ; &1000 ms Constant #1sec $20000 Constant #preview_q RAM_top #preview_q - Constant RAM_preview BAT Variable *preview_ptr 0 $30 $30 Task adc_task 0 $30 $30 Task disk_task 0 $30 $30 Task sequ_task 0 $20 $20 Task wdog_task 0 $20 $20 Task halt_task $1E7900 constant #morse_w $004900 constant #morse_s $13C900 constant #morse_f $F3CF00 constant #morse_o 2 sec Constant #2sec &40 sec constant #max_boot &10 sec constant #max_access &200 sec constant #max_command &900 sec constant #max_key 3 constant #typ_access &1200 constant #level_for &10800 constant #level_off 4 constant #dead_blocks &86400 constant #once_a_day 6 Constant #blk_shift $40 Constant #blk_size 3 Constant #int_shift $08 Constant #int_size $7FFFFFFF Constant #max_int $FFFFFFFF Constant #max_uns Variable led_display Variable led_hidden Variable led_message Variable escape_all Variable curr_drive Variable disk_entry Variable burst_value Variable get_disk_dir Variable halted Variable reboot_done Variable last_command : user_y/n ." (y/n)? " dup IF ." y" ELSE ." n" THEN backspace BEGIN key dup #CR = IF drop exit THEN dup [char] y = over [char] n = or 0= WHILE drop REPEAT nip [char] n = IF ." n" FALSE ELSE ." y" TRUE THEN ; : boot_y/n #max_int feed_watchdog user_y/n #max_boot sec feed_watchdog ; : uncount swap 1- dup -rot ! ; NV definitions Method : >move bounds ?DO count I NV ! pause LOOP drop ; Method : move> >r dup r@ BL fill swap NV addr count >r swap 2r> min cmove pause ; Method : place swap 2dup NV ! 1+ swap bounds ?DO dup @ I NV ! 1+ pause LOOP drop ; Method : .string NV addr count type ; Method : passcalstring 2>r count r> umin r> swap NV place ; Forth definitions NV Variable _channels NV Variable _sample_period NV Variable _bits NV Variable _sec/mark NV Variable _gain NV Variable _band NV Variable _level_off NV Variable _level_ref NV Variable _level_for NV Variable _level_every NV Variable _for NV Variable _every NV Variable _start NV Variable _stop NV Variable _trigger NV Variable _program NV Variable _SystemTicks NV Variable _SystemTime NV Variable _SystemSkew NV Variable _SkewState NV Variable _disk_full NV Variable _circular NV Variable _main_size NV Variable _disk_entry NV Variable _start_disk NV Variable _rec_enable NV Variable _rec_resume NV Variable _last_block NV Variable _release NV Variable _preview_src $080 CONSTANT #BUSY $008 CONSTANT #DRQ $001 CONSTANT #ERR $0 CONSTANT SEL $1 CONSTANT CIS $2 CONSTANT AMC $3 CONSTANT I/O $001 CONSTANT #IOMAPPED $008 CONSTANT #LOWPWR $040 CONSTANT #LEVELINT $000 CONSTANT #DRV0 $002 CONSTANT #DISINT $004 CONSTANT #SOFTRESET $080 CONSTANT #HARDRESET #IOMAPPED #LEVELINT OR CONSTANT #COR_INIT $00000 CONSTANT #DCR_INIT : PCMCIA_LOCK PCMCIA LOCK TICKS @ LAST_ACCESS ! ; : PCMCIA_UNLOCK PCMCIA UNLOCK LAST_ACCESS OFF ; : PCM_ON_new DISK_VOLTAGE @ ?EXIT BEGIN #PCM_5V DEV_CTRL ! #100ms sleep PCM_IO_STAT @ DROP PCM_IO_STAT @ #BUSY AND WHILE #PCM_OFF DEV_CTRL ! &3000 ms SLEEP REPEAT 5 DISK_VOLTAGE ! ; Variable pcm_cmd pcm_cmd off : RESET_PCM $100 pcm_cmd ! PCMCIA_LOCK BEGIN #PCM_5V DEV_CTRL ! #500ms sleep 5 DISK_VOLTAGE ! AMC MODE_SEL ! #COR_INIT PCM_AM_COR ! I/O MODE_SEL ! #SOFTRESET PCM_IO_DCR ! 2 SLEEP AMC MODE_SEL ! #COR_INIT PCM_AM_COR ! #DRV0 PCM_AM_SOCP ! I/O MODE_SEL ! #DCR_INIT PCM_IO_DCR ! #500MS SLEEP PCM_IO_STAT @ DROP PCM_IO_STAT @ #BUSY AND 0= UNTIL PCMCIA_UNLOCK DISK_SLEEPS OFF $101 pcm_cmd ! ; : standby_immediate drive ; : directory_next offset @ curr_adapter @ 1+ >drive ; : write_log dup dos_block? IF offset push dos_blocks directory_now 2dup u> IF _rec_resume on THEN over = get_disk_dir @ and directory_next swap IF _last_block ! disk_entry @ _disk_entry ! flush-erom drop exit THEN 1- over u> IF dup _last_block ! THEN THEN drop ; CODE SETPCMCIA AR3 AR1 LDI, $0FF # AR1 AND, AR1 PCM_IO_SNR #) STI, -8 # AR3 LSH, AR3 AR1 LDI, $0FF # AR1 AND, AR1 PCM_IO_CYLL #) STI, -8 # AR3 LSH, AR3 AR1 LDI, $0FF # AR1 AND, AR1 PCM_IO_CYLH #) STI, -8 # AR3 LSH, $0F # AR3 AND, $0E0 # AR3 OR, AR3 PCM_IO_DHR #) STI, AR3 POP, AR2 AR1 LDI, NOP, AR3 PCM_IO_SCR #) STI, pcm_cmd AR2#LDI, AR1 AR2 *) STI, NEXTD, AR2 POP, AR3 POP, AR1 PCM_IO_CMD #) STI, END-CODE : _new $0E0 PCM_IO_DHR ! dup pcm_cmd ! PCM_IO_CMD ! BEGIN PCM_IO_STAT @ #BUSY AND WHILE pause REPEAT PCMCIA_UNLOCK ; SYS : std_r/w retries @ ?FOR 3dup >r PHYSICAL set_adapter r> IF ticks @ last_access ! swap $ff and swap readmultiple last_access off 0= IF 2DROP DROP RDROP FALSE EXIT THEN message" (74) repairing bad sector" reset_adapter 3DUP >R PHYSICAL set_adapter rdrop ticks @ last_access ! swap $ff and swap writemultiple last_access off drop ELSE ticks @ last_access ! swap $ff and swap writemultiple last_access off 0= IF over write_log 2DROP DROP RDROP FALSE EXIT THEN THEN reset_adapter NEXT 2DROP DROP TRUE ; : std_diskerror reset_adapter fall_asleep pcm_off #100MS SLEEP ?dup 0 = IF message" (70) card write error" EXIT THEN dup 1 = IF message" (71) card read error, rebooting" THEN dup 2 = IF message" (81) card out of range, rebooting" THEN dup 3 = IF message" (82) no more buffers, rebooting" THEN dup 4 = IF message" (72) can't access card, rebooting" THEN dup 5 = IF message" (83) illegal geometry, rebooting" THEN dup 6 = IF message" (73) directory corrupted, rebooting" THEN 7 u> ?EXIT err_boot ; NV Create "exp_number &2 1+ NV allot NV Create "exp_name &24 1+ NV allot NV Create "exp_comment &40 1+ NV allot NV Create "stat_number &4 1+ NV allot NV Create "stat_name &24 1+ NV allot NV Create "stat_comment &40 1+ NV allot NV Create "chan_name_1 &10 1+ NV allot NV Create "chan_name_2 &10 1+ NV allot NV Create "chan_name_3 &10 1+ NV allot NV Create "chan_name_4 &10 1+ NV allot NV Create "chan_sensor_1 &12 1+ NV allot NV Create "chan_sensor_2 &12 1+ NV allot NV Create "chan_sensor_3 &12 1+ NV allot NV Create "chan_sensor_4 &12 1+ NV allot NV Create "chan_sensor_nr_1 &12 1+ NV allot NV Create "chan_sensor_nr_2 &12 1+ NV allot NV Create "chan_sensor_nr_3 &12 1+ NV allot NV Create "chan_sensor_nr_4 &12 1+ NV allot NV Create "chan_comment_1 &40 1+ NV allot NV Create "chan_comment_2 &40 1+ NV allot NV Create "chan_comment_3 &40 1+ NV allot NV Create "chan_comment_4 &40 1+ NV allot NV Create "message &160 1+ NV allot : word" [char] " word ; : skip_bl count ?for dup @ bl <> if r> 1+ uncount exit then 1+ next 0 uncount ; : fill_bl count 2dup &40 + uncount -rot + &40 ?for bl over ! 1+ next drop ; word" 00" count "exp_number swap place word" experiment_name" count "exp_name swap place word" experiment_comment" count "exp_comment swap place word" 0000" count "stat_number swap place word" station_name" count "stat_name swap place word" station_comment" count "stat_comment swap place word" chan1_name" count "chan_name_1 swap place word" chan2_name" count "chan_name_2 swap place word" chan3_name" count "chan_name_3 swap place word" chan4_name" count "chan_name_4 swap place word" sensor1_name" count "chan_sensor_1 swap place word" sensor2_name" count "chan_sensor_2 swap place word" sensor3_name" count "chan_sensor_3 swap place word" sensor4_name" count "chan_sensor_4 swap place word" sensor1_num." count "chan_sensor_nr_1 swap place word" sensor2_num." count "chan_sensor_nr_2 swap place word" sensor3_num." count "chan_sensor_nr_3 swap place word" sensor4_num." count "chan_sensor_nr_4 swap place word" chan1_comment" count "chan_comment_1 swap place word" chan2_comment" count "chan_comment_2 swap place word" chan3_comment" count "chan_comment_3 swap place word" chan4_comment" count "chan_comment_4 swap place word" sample_queue overflow" count "message swap place Forth &21 constant #message_len Semaphor kick_server : alloc_block pause buffer lock-buffer ; : write_block pause buffer drop unlock-buffer update-buffer kick_server signal pause ; : read_block pause block lock-buffer ; : free_block pause buffer drop unlock-buffer ; 6 Constant #new_data 7 Constant #old_data $0008 Constant #dir_skip $2000 Constant #dir_size #dir_skip 2* field [dir_skip] 0 field [disk_number] 1 field [sequ_number] 2 field [block_count] 4 field [status_bits] 5 field [skew_offset] 8 field [Skew_32b] $a field [SkewTime] $c field [SyncTime] $e field [SerialNr] Create tmp_buffer $200 allot Variable sec/blk Variable last_index Variable data_index Variable dir_offset Variable entry_nr Variable last_entry Variable Dir_ptr Create Samples 0 , 0 , 0 , 0 , here 0 , here 0 , here 0 , here 0 , here 0 , Constant Buf_cnt Constant Buf_adc Constant Buf_end Constant Buf_ptr Constant Buf_state $80000000 Constant #invalid $0FFFFFFF Constant #str_sec_value $E0000000 Constant #str_sec_short $F0000020 Constant #std_type_cmd $F0000000 Constant #std_mesg_cmd $F00001AE Constant #passcal_sc_cmd $F0000000 Constant #passcal_ds_cmd $F0000000 Constant #passcal_fd_cmd $00000001 Constant #std_type_tag $00000002 Constant #std_mesg_tag $00000003 Constant #passcal_sc_tag $00000004 Constant #passcal_ds_tag $00000005 Constant #passcal_fd_tag $F8000001 Constant #str_event_short $F8000002 Constant #str_end_short $F8000003 Constant #str_reset_short $F880C004 Constant #str_sync_short : >dat_buffer dup Buf_ptr ! sec/blk @ 8 shift + Buf_end ! ; Variable 'disk_full ' abort 'disk_full ! Variable 'settings ' abort 'settings ! Variable lowbat_timeout &10 Constant #lowbat_timeout : lowbat_timeout? lowbat? IF lowbat_timeout @ 0= IF now #lowbat_timeout + lowbat_timeout ! ELSE lowbat_timeout @ now u< exit THEN ELSE lowbat_timeout off THEN false ; : (log" ("LIT TIMESTAMP TASK_ID E_ADDR FLUSH-ERRORS ; : log" COMPILE (log" "PACKED, ; IMMEDIATE Variable block_alert Variable block_range : disk_present? *file [] >dos_cnt + @ 1 u> ; : drv_count 0 BEGIN *file [] >dos_cnt over + @ WHILE 1+ dup #slots = ?EXIT REPEAT ; : lock_device dup drive pause dup drv_count 1- = swap *file [] >dos_cnt + @ block_range ! IF block_range @ 1- block_alert ! ELSE #max_int block_alert ! THEN pause 1 _main_size ! ; : samples/sec [ #FREQUENCY 4 / ] Literal _sample_period @ &128 * / ; : access_buffer samples/sec _channels @ 1+ * #typ_access * 3 * sec/blk @ 8 shift 2 * / 1+ ; : put_next_disk entry_nr @ 1+ disk_entry ! curr_drive ++@ lock_device 1 data_index ! #dir_skip dir_offset ! ; : get_next_disk entry_nr @ dup disk_entry ! _disk_entry ! curr_drive ++@ lock_device #dir_skip 1- dir_offset ! ; : get_reset_disk curr_adapter @ 1+ IF fall_asleep curr_adapter on THEN 1 last_entry ! _disk_entry @ dup disk_entry ! entry_nr ! curr_drive @ lock_device #dir_skip 1- dir_offset ! ; -1 Constant #next_disk : get_dir_entry dos_blocks dir_offset @ 1+ #dir_size = ABORT" (80) directory overflow" dup dir_offset ++@ 2* + pause dword@ dup 0= last_entry @ #next_disk = and IF 0 free_block pause get_next_disk nip 0 read_block swap THEN dup last_entry ! sec/blk @ / ; : put_dir_entry dos_blocks dir_offset @ 1+ #dir_size = ABORT" (80) directory overflow" BEGIN pause dir_ptr @ ?dup UNTIL swap dup #next_disk <> IF sec/blk @ * THEN pause over dir_offset @++ 2* + dword! 0 over dir_offset @++ 2* + dword! _disk_entry @ over [sequ_number] ! #new_data swap [status_bits] ! 0 write_block dir_ptr off ; : put_data_block dos_blocks *buf_cnt @ #dead_blocks - access_buffer - 0 max burst_value ! data_index dup @ dup 1+ rot ! curr_drive @ drive write_block data_index @ dup block_alert @ = _circular @ IF IF drop 2 dup data_index ! THEN ELSE IF 'disk_full @ execute THEN THEN pause block_range @ = _disk_full @ 0= and IF curr_drive @ 1+ get_disk_dir ! burst_value off #next_disk put_dir_entry pause put_next_disk THEN data_index @ alloc_block >dat_buffer ; Code buf8! Samples AR1#LDI, $ff # AR2 AND, AR1 Buf_state Samples - # +*) R0 LDI, NN IFD, 0 # R2 LDI, $8000 # R1 LDI, $10 # R1 LSH, R1 AR2 OR, NEXTD, AR2 AR1 Buf_state Samples - # +*) STI, AR3 AR2 LDI, AR3 POP, THEN, R2 AR1 Buf_state Samples - # +*) STI, 8 # AR2 LSH, R0 AR2 OR, AR1 Buf_ptr Samples - # +*) AR0 LDI, AR2 AR0 *++) STI, AR1 Buf_end Samples - # +*) AR0 CMPI, Z IFD, AR0 AR1 Buf_ptr Samples - # +*) STI, AR3 AR2 LDI, AR3 POP, FORTH: put_data_block ;ASM THEN, NEXT, end-code Code buf! AR2 AR0 LDI, -8 # AR2 LSH, $FF # AR2 AND, 8 # AR0 LSH, AR0 AR2 OR, Samples AR1#LDI, AR1 Buf_ptr Samples - # +*) AR0 LDI, AR2 AR0 *++) STI, AR1 Buf_end Samples - # +*) AR0 CMPI, Z IFD, AR0 AR1 Buf_ptr Samples - # +*) STI, AR3 AR2 LDI, AR3 POP, FORTH: put_data_block ;ASM THEN, NEXT, end-code Code put_bytes AR2 R0 LDI, Z IF, ' buf8! # BRD, AR3 AR2 LDI, AR3 POP, $FF # AR2 AND, THEN, 1 # R0 SUBI, Z IFD, AR3 AR2 LDI, $FF # AR3 AND, -8 # AR2 LSH, FORTH: buf8! buf8! ;ASM THEN, 1 # R0 SUBI, Z IFD, AR3 PUSH, AR2 AR3 LDI, $FF # AR3 AND, -8 # AR2 LSH, FORTH: buf8! buf8! buf8! ;ASM THEN, -8 # AR2 LSH, AR3 PUSH, AR2 AR3 LDI, $FF # AR3 AND, -8 # AR2 LSH, FORTH: buf8! buf8! buf8! buf8! ;ASM end-code : put_meta_info dup 3 put_bytes dup $F8000000 and $F0000000 = IF swap 1 put_bytes $07FFFFFF and dup tmp_buffer + 1- swap ?FOR dup r@ - @ buf8! NEXT THEN drop pause ; : fill_data_block 0 buf8! Buf_end @ sec/blk @ 8 shift - Buf_ptr @ = 0= IF put_data_block THEN Samples 4 #invalid fill Buf_state off data_index @ free_block ; &3600 Constant #next_flush_ahead Variable next_flush next_flush off : server dos_blocks updated_bufs off BEGIN kick_server wait updated_bufs ++@ burst_value @ > now next_flush @ > or IF save-buffers now #next_flush_ahead + next_flush ! kick_server cell+ off _boot_delay off get_disk_dir @ ?dup IF get_disk_dir off drive 0 read_block dir_ptr ! THEN burst_value @ IF fall_asleep pcm_off THEN THEN REPEAT ; Only Forth also definitions w/buf 2* Constant b/buf : .req rs232_sema lock #esc ctx ; : .dec base push decimal u. ; : ?wait cr empty-keys key #esc - rs232_sema unlock 0=EXIT abort ; : 1 @+ >r over bc@ = IF b@ r> 1 @+ @ rot and = EXIT THEN rdrop 0= ; $FFFFFFFF #str_sync_short Find_mark: sync_mark? : search_sec_mark BEGIN dup WHILE over sync_mark? IF 4 /string over bc@ [ #str_sec_short -$18 shift ] Literal = ?EXIT THEN 1 /string pause REPEAT ; : second@ b@ $FFFFFFF and ; : ?bad_time abort" (62) data not available" ; : BLOCK-AVAIL? OFFSET @ or >r *BUF-LINK @ BEGIN dup >B.BLOCK RAM@ r@ = IF rdrop >B.ADDR RAM@ EXIT THEN RAM@ dup 0= UNTIL rdrop ; : datablock dos_blocks dup >r [ *file >dos_fileid >cnt [] ] Literal BEGIN tuck @ dup 0= ?bad_time - dup 0< not WHILE 1+ r> 1+ >r swap 1+ REPEAT 2drop r@ BLOCK-AVAIL? ?dup IF rdrop ELSE r> block THEN ; : blk>sec datablock 2* b/buf search_sec_mark IF second@ EXIT THEN 0= ; : (seconds/blk dup blk>sec swap 1+ blk>sec ?dup IF swap ?dup IF - EXIT THEN THEN drop 0 ; : addup ?dup IF swap ?dup IF + EXIT THEN THEN ; : seconds/blk 6 2 DO I (seconds/blk LOOP addup addup addup 2+ 2/ 2/ ; : estimated_blk 1 blk>sec - seconds/blk tuck / 1+ ; : last_block _main_size @ data_index @ max ; : find_near_blk dup >r estimated_blk dup 0= ?bad_time 3 ?FOR last_block min 1 max swap over 0< ?bad_time over blk>sec dup 0= ?bad_time r> r@ swap >r swap - over / dup 0= IF 2drop rdrop rdrop exit THEN rot + pause NEXT nip rdrop last_block min 1 max ; : blk+correction BEGIN over 1+ blk>sec over > IF drop exit THEN swap 1+ swap pause REPEAT ; : blk-correction BEGIN swap 1- swap over blk>sec over > 0= IF drop exit THEN pause REPEAT ; : find_blk dup find_near_blk swap over blk>sec over = IF drop exit THEN over blk>sec over > IF blk-correction ELSE blk+correction THEN ; : find_offset swap >r dup datablock 2* b/buf BEGIN 2dup search_sec_mark over second@ r@ swap < not WHILE 2swap 2drop REPEAT 2drop nip rdrop b/buf swap - 4 - swap ; : locate_second dup find_blk find_offset ; : locate_next_second >r 8 + b/buf min r> BEGIN dup >r datablock 2* over + swap b/buf swap - search_sec_mark IF r@ datablock 2* - 4 - r> exit THEN drop 0 r> 1+ dup data_index @ < 0= IF rdrop exit THEN REPEAT ; : ?bad_format abort" (51) no card found" ; $FFFFFFFF #str_event_short Find_mark: event_mark? : search_event_mark BEGIN dup 0= ?bad_format over event_mark? IF drop EXIT THEN 1 /string pause REPEAT ; : get_info 1 block >baddr dup b/buf search_event_mark over - ; : quantity >r rot - r> rot - b/buf * + dup 0< ?bad_time ; : Mark: Create , Does> @ tx ; #str_event_short Mark: eventmark #str_end_short Mark: endmark : transfer dos_blocks 0 drive save-buffers swap _synctime @ - dup rot + >r ." searching" locate_second r> locate_second 2over 2swap quantity dup >r 9 backspaces ." transferring " 1 block lock-buffer drop get_info dup r> + &12 + r tuck datablock lock-buffer >baddr over + b/buf rot - r@ min r> over - >r bput dup datablock unlock-buffer drop r> ?dup WHILE 0 rot 1+ rot REPEAT drop eventmark endmark fall_asleep pcm_off ; &10 Constant #filters Variable P_ptr P_ptr off : preview EXIT EXIT EXIT EXIT EXIT EXIT EXIT EXIT EXIT EXIT ; : empty-preview P_ptr off [ ' preview >body ] Literal #filters ['] EXIT fill ; : Dataplexer Create , Does> P_ptr @ #filters 2- > ABORT" (84) Filter bank full" [ ' preview >body ] Literal P_ptr @ + ! 1 P_ptr +! ; : power2 dup >r 1 swap BEGIN ?dup WHILE 2/ swap 2* swap REPEAT dup 2/ r> = 0=EXIT 2/ ; : Filter Dataplexer 2 pick , swap , swap power2 , dup , , drop , ; 0 Constant F_#taps 1 Constant F_z-buffer 2 Constant F_z-offset 3 Constant F_dec.ctr 4 Constant F_dec.factor 5 Constant F_coeff LABEL 16bit_Filter AR5 F_#taps # +*) BK LDI, AR5 F_z-buffer # +*) AR0 LDI, AR5 F_dec.ctr # +*) R1 LDI, 1 # R1 SUBI, NZ IFD, AR2 AR0 *++)% STI, AR0 AR5 F_z-buffer # +*) STI, AR0 *--)% R3 LDI, R1 AR5 F_dec.ctr # +*) STI, AR7 *--) AR4 LDI, NEXTD, AR3 AR2 LDI, AR3 POP, NOP, THEN, AR5 F_dec.factor # +*) R1 LDI, R1 AR5 F_dec.ctr # +*) STI, AR5 F_coeff # +*) AR1 LDI, AR5 F_#taps # +*) AR2 LDI, 1 # AR2 SUBI, 0 # R0 LDI, 0 # R2 LDI, DO, AR0 *--)% AR1 *++) R0 MPYI3 R0 R2 R2 ||ADDI3, AR2 LOOP, NEXTD, R0 R2 AR2 ADDI3, -$0F # AR2 ASH, NOP, end-code : Coefficients Create , here 0 , 0 Does> count swap count rot ; : end-coefficients 0 ?pairs here over - 1- swap ! ; 2variable Scalor sys : ref Scalor 2! ; sys : norm Scalor 2@ */ ; sys : z-buffer over power2 tuck * hallot 1- heap and hallot heap ; &24 Coefficients 16/2taps $7fff $8060 ref $00000010 norm , $00000056 norm , $00000074 norm , $FFFFFF7B norm , $FFFFFE58 norm , $0000004F norm , $00000418 norm , $00000134 norm , $FFFFF74E norm , $FFFFF972 norm , $00001585 norm , $000035AB norm , $000035AB norm , $00001585 norm , $FFFFF972 norm , $FFFFF74E norm , $00000134 norm , $00000418 norm , $0000004F norm , $FFFFFE58 norm , $FFFFFF7B norm , $00000074 norm , $00000056 norm , $00000010 norm , end-coefficients &36 Coefficients 16/5taps $110228 $100000 ref $00000002 norm , $00000003 norm , $FFFFFFFF norm , $FFFFFFEA norm , $FFFFFFB3 norm , $FFFFFF4F norm , $FFFFFEBA norm , $FFFFFE0A norm , $FFFFFD70 norm , $FFFFFD3B norm , $FFFFFDC8 norm , $FFFFFF66 norm , $00000235 norm , $00000613 norm , $00000A8E norm , $00000EF3 norm , $00001278 norm , $0000146E norm , $0000146E norm , $00001278 norm , $00000EF3 norm , $00000A8E norm , $00000613 norm , $00000235 norm , $FFFFFF66 norm , $FFFFFDC8 norm , $FFFFFD3B norm , $FFFFFD70 norm , $FFFFFE0A norm , $FFFFFEBA norm , $FFFFFF4F norm , $FFFFFFB3 norm , $FFFFFFEA norm , $FFFFFFFF norm , $00000003 norm , $00000002 norm , end-coefficients &24 Coefficients sharp16/2taps $0F5FC55C $10000000 ref $FFFFFFF2 norm , $FFFFFFD4 norm , $00000000 norm , $0000010C norm , $000002AF norm , $000002C7 norm , $FFFFFF1D norm , $FFFFF98C norm , $FFFFF957 norm , $00000528 norm , $00001A27 norm , $00002B0A norm , $00002B0A norm , $00001A27 norm , $00000528 norm , $FFFFF957 norm , $FFFFF98C norm , $FFFFFF1D norm , $000002C7 norm , $000002AF norm , $0000010C norm , $00000000 norm , $FFFFFFD4 norm , $FFFFFFF2 norm , end-coefficients &69 Coefficients sharp16/5taps $FFFFFFFF , $FFFFFFFB , $FFFFFFF5 , $FFFFFFED , $FFFFFFE3 , $FFFFFFD8 , $FFFFFFD1 , $FFFFFFD3 , $FFFFFFE3 , $00000005 , $0000003E , $0000008E , $000000EF , $00000157 , $000001B7 , $000001FC , $00000211 , $000001E6 , $00000173 , $000000BA , $FFFFFFCD , $FFFFFEC9 , $FFFFFDDA , $FFFFFD31 , $FFFFFCFE , $FFFFFD6A , $FFFFFE8B , $00000060 , $000002D0 , $000005A7 , $0000089D , $00000B61 , $00000DA2 , $00000F1A , $00000F9E , $00000F1A , $00000DA2 , $00000B61 , $0000089D , $000005A7 , $000002D0 , $00000060 , $FFFFFE8B , $FFFFFD6A , $FFFFFCFE , $FFFFFD31 , $FFFFFDDA , $FFFFFEC9 , $FFFFFFCD , $000000BA , $00000173 , $000001E6 , $00000211 , $000001FC , $000001B7 , $00000157 , $000000EF , $0000008E , $0000003E , $00000005 , $FFFFFFE3 , $FFFFFFD3 , $FFFFFFD1 , $FFFFFFD8 , $FFFFFFE3 , $FFFFFFED , $FFFFFFF5 , $FFFFFFFB , $FFFFFFFF , end-coefficients 16/2taps 1 z-buffer 2 16bit_filter Filter 16/2smooth 16/2taps 1 z-buffer 2 16bit_filter Filter 16/2smooth2 16/5taps 1 z-buffer 5 16bit_filter Filter 16/5smooth 16/5taps 1 z-buffer 5 16bit_filter Filter 16/5smooth2 sharp16/2taps 1 z-buffer 2 16bit_filter Filter 16/2sharp sharp16/5taps 1 z-buffer 5 16bit_filter Filter 16/5sharp : preview_filters dup &200 / IF 16/5smooth 16/5smooth2 16/2smooth 16/2smooth2 16/2sharp &12 EXIT THEN dup &100 / IF 16/5smooth 16/5smooth2 16/2smooth 16/2sharp &11 EXIT THEN dup &50 / IF 16/5smooth 16/5smooth2 16/2sharp 9 EXIT THEN dup &20 / IF 16/5smooth 16/2smooth 16/2sharp &11 EXIT THEN dup &10 / IF 16/5smooth 16/2sharp 9 EXIT THEN dup 5 / IF 16/5sharp 7 EXIT THEN dup 2 / IF 16/2sharp 6 EXIT THEN 0 ; Label (extract _preview_src addr Assembler AR0#ldi, AR0 *) AR1 ldi, AR1 R0 ldi, Z IFD, AR1 *) R0 ldi, -&15 # R1 ldi, AR0 _preview_src _bits - Assembler # -*) R1 subi, AR7 *--) AR4 LDI, NEXT, THEN, R1 R0 ash, NEXTD, AR3 push, AR2 AR3 ldi, R0 AR2 ldi, end-code (extract Dataplexer extract #preview_q 1- Constant #preview_mask Label (p_queue *preview_ptr addr Assembler AR0#ldi, AR0 *) AR1 ldi, $10 # AR1 lsh, AR0 1 # +*) AR5 ldi, $FFFF # AR5 and, AR1 AR5 or, AR2 AR5 *++) sti, $FFFF # AR5 tstb, Z IFD, AR5 AR0 1 # +*) sti, -$10 # AR5 lsh, 7 # AR5 tstb, Z IFD, AR5 AR0 *) sti, RAM_preview $10000 / $8000 or # AR5 ldi, nop, AR5 AR0 *) sti, THEN, THEN, NEXTD, AR3 AR2 ldi, AR3 pop, nop, end-code (p_queue Dataplexer p_queue Variable Preview_delay Preview_delay off : set_preview_filter empty-preview extract [ #Frequency $200 / ] Literal _sample_period @ / preview_filters nip Preview_delay ! p_queue ; : preview_ram_blocks _preview_src @ IF RAM_preview ELSE ram_top THEN *BUF_CNT @ W/BUF * - ; : set_preview_src _preview_src @ Samples _channels @ 2 min + _preview_src ! ?EXIT *buf_cnt @ flush 0 buffers drop buffers drop ; Variable Old_sample $80000000 Old_sample ! CODE p_encode Old_sample AR0#ldi, $FFFF # AR2 and, AR2 R0 ldi, AR0 *) R0 subi, AR2 AR0 *) sti, R0 R1 ldi, N IFD, $FFFFFFC0 AR0#ldi, R1 R1 not, THEN, R1 R2 ldi, AR0 R2 and, Z IFD, $FFFFF000 AR0#LDI, $7F # R0 and, R0 AR2 ldi, FORTH: ctx ;ASM THEN, AR0 R1 and, Z IFD, $003FFFFF AR0#LDI, AR3 push, R0 AR3 ldi, $FF # AR3 and, R0 AR2 ldi, -8 # AR2 lsh, $1F # AR2 and, $C0 # AR2 or, FORTH: ctx ctx ;ASM THEN, $8000 # AR2 tstb, NZ IFD, $FFFF0000 AR1#ldi, AR1 AR2 or, THEN, AR0 AR2 AND, AR3 push, AR2 AR3 ldi, $FF # AR3 and, AR3 push, -8 # AR2 lsh, AR2 AR3 ldi, $FF # AR3 and, -8 # AR2 lsh, $80 # AR2 or, FORTH: ctx ctx ctx ;ASM end-code Code preview_ptr++? 1 # AR2 addi, $FFFF # AR2 tstb, Z IFD, *preview_ptr addr Assembler AR0#ldi, AR2 AR1 ldi, -$10 # AR1 lsh, 7 # AR1 tstb, Z IFD, RAM_preview AR5#ldi, AR5 AR2 ldi, THEN, THEN, AR0 1 # +*) R0 ldi, AR2 R0 subi, $FFFF # R0 and, Z IFD, AR3 push, AR2 AR3 ldi, 0 # AR2 ldi, AR3 R0 ldi, -$10 # R0 lsh, AR0 *) R0 subi, 7 # R0 tstb, Z IF, -1 # AR2 ldi, THEN, THEN, NEXT, end-code #str_sync_short Mark: syncmark : secondmark $FFFFFFF and #str_sec_short or tx ; : patch_type_info 6 + 0 over ! 1+ &16 over ! 2 + &7800 swap ! ; : preview_transfer dos_blocks 0 drive save-buffers 1 block lock-buffer patch_type_info fall_asleep pcm_off -1 BYTE EMIT NEXT ; : ERR_DECODE BASE PUSH DECIMAL COUNT DUP #time AND IF CR $7FFFFFFF AND .TIME&DATE EXIT THEN DUP >ADDR SWAP $FF000000 AND #error CASE? IF .MESSAGE EXIT THEN #task CASE? IF 1- >NAME COUNT TYPE EXIT THEN #triple CASE? IF .TRIPLET EXIT THEN #ds CASE? IF CR ." DS: " ?FOR COUNT U. NEXT EXIT THEN #rs CASE? IF CR ." RS: " ?FOR COUNT U. NEXT EXIT THEN #value = IF DROP COUNT . EXIT THEN DROP; ; : new.ERRORS CHECK_ERR_PTR ERR0 BEGIN DUP ERR_PTR @ U< WHILE ERR_DECODE REPEAT DROP; ; : NEWERRORS? CHECK_ERR_PTR 0 ERR_PTR @ ERR0 ?DO I @ $FF000000 AND #time = - LOOP ; : NEW_STD_ERROR RS232_SEMA LOCK OUT @ IF CR THEN DUP UP@ TERMINAL = IF TOKEN COUNT TYPE space .MESSAGE ELSE UP@ 1- >NAME COUNT TYPE space .MESSAGE CR THEN RS232_SEMA UNLOCK _rec_enable @ 0= IF drop exit THEN TIMESTAMP TASK_ID E_ADDR ; Code re_sync_clk MEM_SEC AR0#ldi, $8040 # R0 ldi, BEGIN, $1000 # AR1 ldi, DO, #XF1IN # IOF tstb, Z IF, R0 DEV_CTRL #) sti, 6 # rpts, $40 # R1 ldi, R1 DEV_CTRL #) sti, AR0 #1MS_CTR # +*) R0 ldi, NEXTD, AR3 push, AR2 AR3 ldi, R0 AR2 ldi, THEN, AR1 LOOP, (watchdog # call, AGAIN, end-code #FREQUENCY &10 4 */ #T1PERIOD / CONSTANT #MS_TICKS/10SEC Variable last_send_command last_send_command off : .mls_state _SkewState @ IF ." cards closed" EXIT THEN _disk_full @ IF ." cards full" EXIT THEN _rec_enable @ 0= IF ." not active" EXIT THEN lowbat_timeout? IF ." battery low" EXIT THEN sequ_state @ 0= IF ." locked" EXIT THEN sequ_state @ 1 = IF ." (waiting)" EXIT THEN sequ_state @ 2 = IF ." startup rec" EXIT THEN sequ_state @ 3 = IF ." shutdown rec" EXIT THEN halted @ IF ." halted" EXIT THEN sequ_state @ 4 = IF ." recording" EXIT THEN ." firmware error" ; 0 &20 &20 TASK pressure_task &2000 &12 * Constant Adcq_depth heap Constant Adcq_end sys Adcq_depth 5 + hallot heap Constant AdcQ Create adc_base here 0 , here 0 , 0 , 0 , here 0 , CALL-WAKE , here 0 , here 0 , AdcQ , DMA0_GCR , pressure_task , here 0 , 0 , 0 , 0 , 0 , Constant Spill Constant Active_Channels Constant data_processed Constant start_messure_time Constant pause_cnt Constant adc_sec : resync dcf77_init re_sync_clk Etint1 disable NO_SUB 'secserver ! &10 * #MS_TICKS/10SEC mod &10 / dup &501 < ?EXIT &1000 - Seconds @ 1+ dup not over Seconds 1 !+ ! adc_base @ IF adc_base ! EXIT THEN drop ; $7D43 Constant #@DMA0 sys $40 Constant #getadc sys Semaphor kick_dac : ?ADRDY BEGIN pause AD_STAT @ AD_RDY and UNTIL ; : ?RXFULL BEGIN pause AD_STAT @ RX_FULL and UNTIL ; : ?TXEMPTY BEGIN pause AD_STAT @ TX_EMPTY and UNTIL ; : ADC! ?TXEMPTY AD_OUT ! ?TXEMPTY AD_OUT ! ; : SYNC 1 AD_CTRL ! pause 0 AD_CTRL ! ; : SET_ADC_FILTER DUP -8 SHIFT $F and $C0 OR $24 ADC! $FF AND $34 ADC! ; : SET_ADC_MODE $20 $14 ADC! ; : init_seconds #2sec ahead BEGIN timeout? IF message" (85) init adc-seconds failed" err_boot THEN seconds @ adc_sec ! 2 sleep seconds @ adc_sec @ over = and UNTIL drop ; LABEL cpu_fast #CPU_FAST # R0 LDI, R0 DEV_CTRL #) STI, T0Ctrl #) R0 ldi, $C0 # R0 andn, R0 T0Ctrl #) sti, T0PERIOD #) R0 LDI, 4 # R0 LSH, R0 T0PERIOD #) STI, T0CTR #) R0 LDI, 4 # R0 LSH, R0 T0CTR #) STI, T0Ctrl #) R0 ldi, $80 # R0 or, R0 T0Ctrl #) sti, RETSU, END-CODE NO_INT INT_ADC INT! LABEL ADC_INT ST PUSH, AR0 PUSH, R0 PUSH, AR1 PUSH, AR2 PUSH, R1 PUSH, R2 PUSH, T0PERIOD #) R0 LDI, #T0PERIOD # R0 CMPI, LO IFD, adc_base AR1#LDI, cpu_fast # CALL, THEN, AR1 7 # +*) R0 LDI, 1 # R0 ADDI, AR1 8 # +*) AR2 LDI, 5 # AR2 ADDI, AR2 PUSH, AR2 3 # -*) R0 ADDI, AR2 1 # -*) R0 CMPI, Z IF, AR2 R0 LDI, THEN, AR2 2 # -*) R0 CMPI, NZ IFD, SECFLAG #) R2 LDI, #SECFLAG # R2 AND, NOP, NZ IFD, $FFFF # R2 LDI, $18 # R2 LSH, AR2 4 # -*) AR0 LDI, AR0 *) AR0 LDI, 8 # AR0 LSH, -8 # AR0 LSH, AR1 0 # +*) R2 LDI, NZ IF, 1 # R2 ADDI, R2 AR1 0 # +*) STI, THEN, $19 # R2 LSH, -1 # R2 LSH, AR0 R2 OR, AR2 4 # -*) AR0 LDI, ELSE, AR0 *) R2 OR, THEN, R2 AR0 *) STI, AR2 3 # -*) AR0 LDI, AR0 AR2 4 # -*) STI, R0 AR2 3 # -*) STI, AR0 AR2 LDI, ELSE, AR1 &11 # +*) AR0 LDI, 1 # AR0 ADDI, AR0 AR1 &11 # +*) STI, AR1 AR2 LDI, &12 # AR2 ADDI, THEN, AR1 7 # +*) AR0 LDI, 2 # AR0 CMPI, NZ IFD, AD_BASE AR1#LDI, AR1 0 # +*) R1 LDI, $3FFF # R1 AND, $10 # R1 LSH, AR1 1 # +*) R2 LDI, $FFFF # R2 AND, R2 R1 OR, -6 # R1 LSH, R1 R1 NOT, R1 AR2 *++) STI, THEN, 0 # AR0 CMPI, NZ IF, AR1 6 # +*) R1 LDI, $3FFF # R1 AND, $10 # R1 LSH, AR1 7 # +*) R2 LDI, $FFFF # R2 AND, R2 R1 OR, -6 # R1 LSH, R1 R1 NOT, R1 AR2 *++) STI, AR1 2 # +*) R1 LDI, $3FFF # R1 AND, $10 # R1 LSH, AR1 3 # +*) R2 LDI, $FFFF # R2 AND, R2 R1 OR, -6 # R1 LSH, R1 R1 NOT, R1 AR2 *++) STI, AR1 4 # +*) R1 LDI, $3FFF # R1 AND, $10 # R1 LSH, AR1 5 # +*) R2 LDI, $FFFF # R2 AND, R2 R1 OR, -6 # R1 LSH, R1 R1 NOT, R1 AR2 *++) STI, THEN, R2 AD_FREE #) STI, Buf_cnt AR2#LDI, AR2 *) R1 LDI, 1 # R1 ADDI, R1 AR2 *) STI, AR2 POP, AR2 5 # -*) R1 LDI, NZ IFD, CALL-WAKE AR0#LDI, 0 # R0 LDI, R0 AR2 5 # -*) STI, R1 AR2 LDI, AR0 AR2 *) STI, THEN, R2 POP, R1 POP, AR2 POP, AR1 POP, R0 POP, AR0 POP, ST POP, RETIU, END-CODE : adcq_empty Adcq_end [ AdcQ 5 + ] Literal dup Active_Channels @ 1+ + dup 0 AdcQ 1 !+ 1 !+ 1 !+ 1 !+ ! ; CODE getsamples Active_channels AR0#LDI, AR0 1 # +*) AR5 LDI, 5 # AR5 ADDI, AR5 2 # -*) AR1 LDI, AR0 *) AR1 ADDI, 1 # AR1 ADDI, AR5 1 # -*) AR1 CMPI, Z IFD, AR5 4 # -*) AR1 CMPI, AR3 PUSH, AR2 PUSH, AR5 AR1 LDI, AR5 4 # -*) AR1 CMPI, THEN, Z IF, -1 # R0 LDI, R0 AR0 1 # -*) STI, PRIORITY 1+ # BRD, AR6 AR5 5 # -*) STI, 2 # SP SUBI, 1 # AR4 SUBI, THEN, AR1 AR5 2 # -*) STI, AR0 *) AR2 LDI, AR1 AR3 LDI, AR0 active_channels pause_cnt - # -*) R0 LDI, 1 # R0 ADDI, $1F # R0 TSTB, Z IFD, NOP, NOP, R0 AR0 active_channels pause_cnt - # -*) STI, ' pause @ # BR, THEN, NEXT, END-CODE variable sec/mark_cnt variable sec/mark_val CODE mark-time AR3 *) R0 LDI, AR2 AR0 LDI, AR3 AR1 LDI, $80000000 R1#LDI, DO, AR1 *) R2 LDI, 8 # R2 LSH, R1 R2 XOR, -2 # R2 ASH, R2 AR1 *++) STI, AR0 LOOP, 0 # R0 CMPI, N IFD, sec/mark_cnt AR0#LDI, NEXT, THEN, AR0 *) R1 LDI, 1 # R1 SUBI, R1 AR0 *) STI, NZ IFD, sec/mark_val AR1#LDI, NEXT, THEN, AR1 *) R1 LDI, R1 AR0 *) STI, AR3 PUSH, AR2 PUSH, Samples AR1#LDI, #invalid R1#LDI, R1 AR1 *) STI, R1 AR1 1 # +*) STI, R1 AR1 2 # +*) STI, R1 AR1 3 # +*) STI, adc_sec AR0#LDI, -$18 # R0 LSH, AR0 *) R2 LDI, R0 R2 SUBI, -$07 # R2 LSH, $07 # R2 LSH, R0 R2 ADDI, 4 # R2 LSH, -4 # R2 LSH, AR1 Buf_adc Samples - # +*) R0 LDI, Z IFD, NOP, NOP, AR1 Buf_state Samples - # +*) R0 LDI, NEXTD, AR2 POP, AR3 POP, NOP, THEN, N IF, R2 AR2 LDI, $FF # AR2 AND, AR2 PUSH, -8 # R2 LSH, R2 PUSH, -$10 # R2 LSH, #str_sec_short -$18 shift #str_sync_short 8 shift or # R2 OR, R2 PUSH, #str_sync_short -8 shift # AR3 LDI, #str_sync_short -$18 shift # AR2 LDI, FORTH: buf8! buf! buf! buf! buf8! ;ASM THEN, R2 PUSH, -$10 # R2 LSH, #str_sec_short -$10 shift # R2 OR, R2 PUSH, #str_sync_short # AR3 LDI, #str_sync_short -$10 shift # AR2 LDI, FORTH: buf! buf! buf! buf! ;ASM end-code sys : flush-adc pause adcq @ wake data_processed off BEGIN pause data_processed @ INT_ADC INT@ NO_INT = and UNTIL Buf_adc off ; : bits &30 - _bits ! ; : bits/sample &30 _bits @ + ; &1600 Constant #pixels_max variable pixels variable buf_show variable buf_in variable buf_out variable buf_len Create buf_base #pixels_max 1+ allot CODE clip AR2 AR0 LDI, AR3 AR1 LDI, _bits addr Assembler AR5#LDI, AR5 *) R3 LDI, buf_base AR5#LDI, AR5 buf_base buf_show - # -*) R2 LDI, DO, AR1 *) R0 LDI, R0 R1 LDI, 2 # R1 ASH, V IFD, NOP, NOP, R0 R0 LDI, N IFD, $1FFFFFFF R0#LDI, R0 R0 NOT, THEN, THEN, R2 AR0 CMPI, EQ IFD, R3 R0 ASH, R0 AR1 *++) STI, NOP, AR5 buf_base buf_in - # -*) IR0 LDI, R0 AR5 IR0 +*) STI, 1 # IR0 ADDI, AR5 buf_base buf_len - # -*) IR0 CMPI, EQ IF, 0 # IR0 LDI, THEN, AR5 buf_base buf_out - # -*) IR0 CMPI, NE IF, IR0 AR5 buf_base buf_in - # -*) STI, THEN, THEN, AR0 LOOP, next, end-code sys CODE encode Samples AR1#LDI, AR2 IR0 LDI, AR3 *++) R0 LDI, R0 R1 LDI, IR0 R2 LDI, NZ IFD, AR1 IR0 +*) R1 SUBI, R0 AR1 IR0 +*) STI, 1 # IR0 SUBI, 1 # AR4 SUBI, AR3 PUSH, IR0 PUSH, THEN, R1 R2 LDI, N IFD, $FFFFFFC0 AR0#LDI, R1 R2 NOT, THEN, AR1 Buf_adc Samples - # +*) R3 LDI, Z IFD, AR1 Buf_end Samples - # +*) R3 LDI, 4 # R3 SUBI, AR1 Buf_ptr Samples - # +*) R3 CMPI, NEXTD, AR2 POP, AR3 POP, NOP, THEN, HI IFD, R2 R3 LDI, AR0 R3 AND, NOP, Z IFD, $FFFFF000 AR0#LDI, AR1 Buf_state Samples - # +*) R3 LDI, N IFD, $7F # R1 AND, 0 # AR2 LDI, NOP, AR2 AR1 Buf_state Samples - # +*) STI, 8 # R1 LSH, R3 R1 OR, AR1 Buf_ptr Samples - # +*) AR2 LDI, R1 AR2 *++) STI, AR2 AR1 Buf_ptr Samples - # +*) STI, nextd, AR2 POP, AR3 POP, NOP, THEN, R1 ROL, 1 # R1 OR, R1 ROR, R1 AR1 Buf_state Samples - # +*) STI, nextd, AR2 POP, AR3 POP, NOP, THEN, R2 R3 LDI, AR0 R3 AND, Z IFD, $003FFFFF AR0#LDI, AR1 Buf_state Samples - # +*) R3 LDI, N IFD, $1FFF # R1 AND, $C000 # R1 OR, R1 R0 LDI, $00FF # R1 AND, R1 ROL, 1 # R1 OR, R1 ROR, R1 AR1 Buf_state Samples - # +*) STI, $00FF # R3 AND, $FF00 # R0 AND, R3 R0 OR, AR1 Buf_ptr Samples - # +*) AR2 LDI, R0 AR2 *++) STI, AR2 AR1 Buf_ptr Samples - # +*) STI, nextd, AR2 POP, AR3 POP, NOP, THEN, -8 # R0 LSH, $FF # R0 AND, 8 # R1 LSH, R0 R1 OR, AR1 Buf_ptr Samples - # +*) AR2 LDI, R1 AR2 *++) STI, AR2 AR1 Buf_ptr Samples - # +*) STI, nextd, AR2 POP, AR3 POP, NOP, THEN, $800000 AR2#LDI, AR1 Buf_state Samples - # +*) R3 LDI, N IFD, AR0 R0 AND, AR2 R0 OR, R0 R1 LDI, 0 # AR2 LDI, AR2 AR1 Buf_state Samples - # +*) STI, -8 # R0 LSH, $FF00 # R0 AND, R3 R0 OR, AR1 Buf_ptr Samples - # +*) AR2 LDI, R0 AR2 *++) STI, R1 AR3 LDI, -8 # AR3 LSH, $FF # AR3 AND, 8 # R1 LSH, AR3 R1 OR, R1 AR2 *++) STI, AR2 AR1 Buf_ptr Samples - # +*) STI, nextd, AR2 POP, AR3 POP, NOP, THEN, $00FF # R0 AND, R0 ROL, 1 # R0 OR, R0 ROR, R0 AR1 Buf_state Samples - # +*) STI, R1 AR3 LDI, -$10 # AR3 LSH, $FF # AR3 AND, $ff00 # R1 AND, AR3 R1 OR, AR1 Buf_ptr Samples - # +*) AR2 LDI, R1 AR2 *++) STI, AR2 AR1 Buf_ptr Samples - # +*) STI, nextd, AR2 POP, AR3 POP, NOP, ELSE, Z IFD, $FFFFF000 AR0#LDI, ' buf8! @ # BRD, $7F # R1 AND, R1 AR2 LDI, AR3 POP, THEN, R2 R3 LDI, AR0 R3 AND, Z IFD, $003FFFFF AR0#LDI, AR1 Buf_state Samples - # +*) R0 LDI, N IFD, $1FFF # R1 AND, $C000 # R1 OR, NOP, R1 AR3 LDI, $FF # AR3 AND, R1 AR2 LDI, -8 # AR2 LSH, FORTH: buf8! buf8! ;ASM THEN, ' buf! @ # BRD, R1 AR2 LDI, AR3 POP, NOP, THEN, AR0 R0 AND, AR1 Buf_state Samples - # +*) R1 LDI, N IFD, $800000 AR0#LDI, AR0 R0 OR, R0 AR3 LDI, R0 AR2 LDI, -$10 # AR2 LSH, FORTH: buf8! buf! ;ASM THEN, AR0 R0 OR, R0 AR3 LDI, $FF # AR3 AND, R0 AR2 LDI, -8 # AR2 LSH, FORTH: buf! buf8! ;ASM THEN, end-code Forth definitions : 32filter Create 2 pick , swap , swap power2 , dup , , + 1- , ;Code AR3 R7 LDI, AR2 R6 LDI, AR5 *++) BK LDI, AR5 *) AR0 LDI, AR0 AR1 LDI, AR0 1 # *--)% AR0 TSTB, AR0 AR5 *++) STI, AR5 *++) IR1 LDI, DO, AR3 *++) R0 LDI, R0 AR1 IR1 *++) STI, AR2 LOOP, AR5 *++) R0 LDI, 1 # R0 SUBI, NZ IFD, R7 AR3 LDI, R6 AR2 LDI, R0 AR5 1 # -*) STI, AR7 *--) AR4 LDI, NEXTD, AR2 POP, AR3 POP, NOP, THEN, AR5 *++) R0 LDI, R0 AR5 2 # -*) STI, AR5 *) AR5 LDI, AR0 AR1 LDI, DO, BK IR0 LDI, 0 # R3 LDI, BEGIN, 1 # IR0 SUBI, IR0 R0 LDI, NN WHILED, AR0 IR0 *--)% R0 LDI, -1 # IR0 LSH, AR5 IR0 -*) R1 LDI, 1 # IR0 LSH, AR0 IR0 *++)% R0 ADDI, R0 R1 R2 XOR3, N IFD, R1 R1 ABSI, R1 R2 LDI, -$10 # R1 LSH, $FFFF # R2 AND, R0 R0 ABSI, R0 R4 LDI, -$10 # R0 LSH, $FFFF # R4 AND, R1 R4 MPYI, R0 R2 MPYI, R4 R2 ADDI, -$10 # R2 LSH, R2 R3 SUBI, R0 R1 MPYI, R1 R3 SUBI, ELSE, $FFFF # R2 AND, R0 R0 ABSI, R0 R4 LDI, -$10 # R0 LSH, $FFFF # R4 AND, R1 R4 MPYI, R0 R2 MPYI, R4 R2 ADDI, -$10 # R2 LSH, R2 R3 ADDI, R0 R1 MPYI, R1 R3 ADDI, THEN, REPEAT, R3 AR3 *++) STI, IR1 AR1 ADDI, AR1 AR0 LDI, AR2 LOOP, NEXTD, R7 AR3 LDI, R6 AR2 LDI, NOP, end-code &44 Coefficients Sharp_140dB $1FFFC000 $1EFCABC4 ref $FFFF4ABA norm 2* , $FFF9F520 norm 2* , $FFE690DF norm 2* , $FFBBDD14 norm 2* , $FF841F41 norm 2* , $FF6ED057 norm 2* , $FFBACF03 norm 2* , $00697C80 norm 2* , $00FBD609 norm 2* , $00B0C53E norm 2* , $FF5C01FE norm 2* , $FE10DBC4 norm 2* , $FE84E316 norm 2* , $01278CE6 norm 2* , $03C4A278 norm 2* , $02E1D6FB norm 2* , $FD91CD60 norm 2* , $F8263701 norm 2* , $F9FAD11B norm 2* , $06F33D66 norm 2* , $1A5BAF45 norm 2* , $28D8C5F9 norm 2* , end-coefficients Sharp_140dB 4 z-buffer 2 32filter FIR-Filter : decimate mark-time FIR-Filter clip encode preview ; : sampling dos_blocks BEGIN getsamples decimate REPEAT ; VARIABLE SYS_POS SYS_POS OFF VARIABLE SYS_BUF SYS_BUF OFF : SYS_EMIT 1 OUT +! >BYTE SYS_BUF @ PAUSE SYS_POS @ $7FFF MIN DUP 1+ SYS_POS ! BYTE>WORD! ; : SYS_CR OUT OFF #CR SYS_EMIT #LF SYS_EMIT ; : SYS_BACKSPACE -1 OUT +! SYS_POS DECREMENT ; CREATE SYS_IO ] SYS_EMIT SYS_CR SYS_BACKSPACE [ CODE RAM_ASC_LEN 1 # AR2 CMPI, 1 # AR2 SUBI, HS IF, DO, AR3 AR0 LDI, AR2 AR0 ADDI, 1 # AR0 TSTB, NZ IFD, -1 # AR0 LSH, AR0 *) AR0 LDI, NOP, -8 # AR0 LSH, THEN, $FF # AR0 AND, $20 # AR0 CMPI, HI IF, 1 # AR2 ADDI, NEXT, THEN, AR2 LOOP, THEN, 0 # AR2 LDI, NEXT, END-CODE : SYSIO RS232_SEMA LOCK SYS_BLOCKS 0 BLOCK LOCK-BUFFER DUP 2* #BUFFER_SIZE 2* RAM_ASC_LEN NIP SYS_POS ! SYS_BUF ! SYS_IO IO ! ; : STD_EMIT 1 OUT +! >BYTE DUP BL < IF RS232_SEMA LOCK #ESC CTX CTX RS232_SEMA UNLOCK EXIT THEN CTX ; : STD_CR RS232_SEMA LOCK #CR CTX #LF CTX RS232_SEMA UNLOCK OUT OFF ; : STD_BACKSPACE #BS CTX -1 OUT +! ; : STDIO STD_IO IO ! SYS_BLOCKS 0 BLOCK DROP UPDATE-BUFFER UNLOCK-BUFFER RS232_SEMA UNLOCK ; &365 4 * 1+ &86400 * constant #sec_of_4_years : day_of_year dup #sec_of_4_years + swap sec>date 4 + >r 2drop 1 1 r> date>sec - &86400 / 1+ ; : bcd_read -4 * shift dup $0F and swap $F0 and -4 shift &10 * + ; : int>char &36 mod $30 + dup $3A u< ?exit 7 + ; : int>packed >r 0 r@ ?FOR -8 shift over &10 mod $30 + &24 shift or swap &10 / swap NEXT nip 4 r> - -8 * shift ; : build_file_name >r 1+ int>char 8 shift ser# @ dup 0 bcd_read dup &90 < IF &10 + ELSE &90 - THEN int>char &24 shift over 2 bcd_read int>char &16 shift or swap 4 bcd_read 2 int>packed or r> swap >r dup >r sec>date drop drop drop nip nip 2 int>packed &16 shift or r> day_of_year 3 int>packed &8 shift $5F or >r split r> split r> split ; : dir_file_name tmp_buffer >r &11 r@ ! wsplit r@ 1 + ! r@ 2 + ! wsplit r@ 3 + ! r@ 4 + ! wsplit r@ 5 + ! r@ 6 + ! wsplit r@ 7 + ! r@ 8 + ! wsplit r@ 9 + ! r@ &10 + ! wsplit r> &11 + ! drop ; : log_file_name tmp_buffer >r wsplit r@ ! r@ 1 + ! wsplit r@ 2 + ! r@ 3 + ! wsplit r@ 4 + ! r@ 5 + ! wsplit r@ 6 + ! r@ 7 + ! [char] . r@ 8 + ! wsplit r@ 9 + ! r@ &10 + ! wsplit r> &11 + ! drop ; : >tmp_buffer tmp_buffer + ; : meta@ >tmp_buffer dup @ swap 1+ @ wjoin ; : meta! >tmp_buffer >r wsplit r@ 1+ ! r> ! ; variable coeff_ptr variable coeff_rev variable total_delay : coeff_halfband swap dup 7 + @ 2 2 meta! over 2 + @ 2- dup 0 meta! 4 coeff_ptr ! dup 4 * 2+ coeff_rev ! 2+ 4 / dup >r 2* + r> ?FOR dup r@ 1+ 2* - 2@ join 3 pick ashift r@ 2 mod IF negate THEN dup split swap coeff_ptr @2++ meta! coeff_ptr @2++ meta! 0 split swap coeff_ptr @2++ meta! coeff_ptr @2++ meta! split coeff_rev @2-- meta! coeff_rev @2-- meta! 0 split coeff_rev @2-- meta! coeff_rev @2-- meta! NEXT 2@ join -4 coeff_ptr +! rot shift split swap coeff_ptr @2++ meta! coeff_ptr @2++ meta! ; : coeff_decimation swap dup 7 + @ over 6 + @ 2 meta! over 2 + @ dup 0 meta! 4 coeff_ptr ! dup 4 * 2+ coeff_rev ! 2/ ?FOR dup r@ - @ 3 pick ashift dup split swap coeff_ptr @2++ meta! coeff_ptr @2++ meta! split coeff_rev @2-- meta! coeff_rev @2-- meta! NEXT drop nip ; : mk_spec over 0 meta@ 1- &500 * * total_delay +! 2 meta@ rot * swap ; : .coeff swap dup $80000000 = IF 1+ THEN dup dup abs = IF ." 0." ELSE negate ." -0." THEN 0 rot BEGIN swap 1+ swap base @ / ?dup 0= UNTIL ?FOR base @ um* int>char emit NEXT drop space ; : .filter dup 1+ cr cr ." [" >name count type ." ]" 2 meta@ cr . ." decimation" 0 meta@ dup cr . ." coefficients" 4 * dup 4 / ?FOR dup r@ 4 * - cr ." #" dup 4 / . dup meta@ swap 2+ meta@ join ." : " $1FFFFFFF .coeff pause NEXT drop ; : round_2_digits dup 1 1 rot max BEGIN swap &10 * swap &10 / dup &100 < UNTIL drop dup 2/ rot + over / * ; : sys_filter total_delay off 1 [ ' decimate >body ] Literal BEGIN count dup ['] EXIT <> WHILE 1- rot swap dup ['] FIR-Filter 1- = IF 0 coeff_decimation mk_spec .filter THEN drop swap REPEAT 2drop drop cr cr ." [delay]" &12000 samples/sec / cr . ." ms, " &12 . ." samples" ; : filters [ ' decimate >body ] Literal BEGIN count dup ['] EXIT <> WHILE .name ?cr REPEAT 2drop ; : header_sys_file sysio 1+ _SyncTime @ cr cr ." \\\" cr cr ." [sync_time]" cr .time&date backspace cr cr ." [this_card]" cr ." card #" . backspace cr cr ." [file_name]" drv_count ?FOR drv_count 1- r@ - *file [] >dos_cnt + @ IF drv_count 1- r@ - cr ." card #" dup 1+ . backspace ." : " _SyncTime @ build_file_name log_file_name tmp_buffer &12 type THEN NEXT stdio ; $80000000 Constant #no_skew : get_skew _SystemSkew @ 0= IF #no_skew EXIT THEN _SystemTime @ _SystemSkew @ - dup &2000000 > IF MESSAGE" (35) SKEW out of range" drop #no_skew EXIT THEN dup -&2000000 < IF MESSAGE" (35) SKEW out of range" drop #no_skew EXIT THEN &1000 * _SystemTicks @ + ; : trailer_sys_file sysio cr cr cr ." [skew_time]" _SystemSkew @ ?dup IF cr .time&date backspace ELSE cr ." not available" THEN cr cr ." [system_time]" _SystemTime @ ?dup IF cr .time&date ." and " _SystemTicks @ . ." ms" ELSE cr ." not available" THEN cr cr ." [deviation]" get_skew dup #no_skew = IF drop cr ." not available" ELSE cr . ." ms" THEN cr cr ." [messages]" cr print-errors cr cr ." [settings]" 'settings @ execute sys_filter stdio ; variable sys_bytes variable main_blks : max_dos_file #max_sec sec/blk @ / main_blks ! ; : main_start #fat_start #sys_sec_max sec/clu @ / + ; : main_sec_max fat_len main_start - sec/clu @ * #free_sec - sec/blk @ / sec/blk @ * ; : main_end main_start main_blks @ sec/blk @ * main_sec_max min sec/clu @ / + ; : sys_end #fat_start sys_bytes @ 1- -9 ashift 1+ #sys_sec_max min 1- sec/clu @ / 1+ + ; : scan_drives reset_adapter max_dos_file flush 0 *file [] >shift ! #blk_shift *file [] >sys_shift ! #blk_shift *file [] >dos_shift ! 0 *file [] >FileID ! #sys_view *file [] >sys_FileID ! #dos_view *file [] >dos_FileID ! #slots-1 FOR #slots-1 r@ - >r r@ card_present? IF _CIS_ENABLE @ IF cr ." card " r@ 1+ . r@ set_adapter min_voltage @ &3300 = IF ." (3.3 V) " ELSE ." (5.0 V) " THEN eval_cis_disk? IF ." (?)" THEN eval_cis_name IF ." (?)" THEN ELSE r@ set_adapter THEN identify_card 0 *file [] >off r@ + ! fat_off dup *file [] >sys_off r@ + ! #sys_sec_max + *file [] >dos_off r@ + ! total @ *file [] >cnt r@ + ! 1 *file [] >sys_cnt r@ + ! main_end main_start - sec/clu @ * #blk_size / *file [] >dos_cnt r@ + ! ELSE 0 dup *file [] >off r@ + ! dup *file [] >sys_off r@ + ! dup *file [] >dos_off r@ + ! dup *file [] >cnt r@ + ! dup *file [] >sys_cnt r@ + ! *file [] >dos_cnt r@ + ! THEN rdrop pause NEXT 0 dup *file [] >off #slots + ! dup *file [] >sys_off #slots + ! *file [] >dos_off #slots + ! #max_int dup *file [] >cnt #slots + ! #blk_size / dup *file [] >sys_cnt #slots + ! *file [] >dos_cnt #slots + ! flush-erom ; create vol_name ," MLS100_1 " create log_name ," MLS SYS" create init_name ," INIT" 1 constant #start_head 1 constant #start_sec 0 constant #start_cyl 0 constant #mbr_sector $00FF constant #cyl_low_mask $0300 constant #cyl_high_mask $AA55 constant #valid_tag $28 constant #volume_tag $20 constant #file_tag $00 constant first_entry $20 constant second_entry $40 constant third_entry Variable 12_bit_state Variable fat_blk_size Variable clear_rest : pos>cyl #cyl_low_mask and ; : pos>pck #cyl_high_mask and -2 shift or ; : media_0 partition_type @ IF $FFF8 ELSE $0FF8 THEN ; : media_1 partition_type @ IF $FFFF ELSE $0FFF THEN ; : time>word 6 shift + 5 shift swap 2/ + ; : date>word &1980 - 4 shift + 5 shift + ; : erase_sector_buffer dup $100 0 fill ; : write_mbr flush 1 raw_blk_secs ! #mbr_sector read_block dup $E7 + $18 0 fill partition_type @ 1+ $1C2 byte>sec! #valid_tag $1FE word>sec! #start_head $1BF byte>sec! #start_sec #start_cyl pos>pck $1C0 byte>sec! #start_cyl pos>cyl $1C1 byte>sec! heads @ 1- $1C3 byte>sec! sectors @ cylinders @ 1- pos>pck $1C4 byte>sec! cylinders @ 1- pos>cyl $1C5 byte>sec! sectors @ $1C6 long>sec! par_sec $1CA long>sec! drop #mbr_sector write_block ; 2 constant #fats_cnt $200 constant #sec_bytes $FFF8 constant #media_des : write_bootsector flush 1 raw_blk_secs ! sectors @ read_block $eb $000 byte>sec! $39 $001 byte>sec! $90 $002 byte>sec! $49 $003 byte>sec! $53 $004 byte>sec! $57 $005 byte>sec! $49 $006 byte>sec! $4e $007 byte>sec! $34 $008 byte>sec! $2e $009 byte>sec! $31 $00A byte>sec! #boot_len $00E word>sec! #fats_cnt $010 byte>sec! #root_entr $011 word>sec! fat_sec $016 word>sec! #media_des $015 byte>sec! sec/clu @ $00D byte>sec! #valid_tag $1FE word>sec! #sec_bytes $00B word>sec! sectors @ $018 word>sec! heads @ $01A byte>sec! sectors @ $01C long>sec! partition_type @ 5 = IF par_sec $020 long>sec! 0 $013 word>sec! ELSE 0 $020 long>sec! par_sec $013 word>sec! THEN now $027 long>sec! drop sectors @ write_block ; CODE 2dup_+_fat_count_++@ AR3 PUSH, AR2 PUSH, AR2 AR3 ADDI, fat_count AR1#LDI, NEXTD, AR1 *) AR2 LDI, 1 # AR2 ADDI, AR2 AR1 *) STI, END-CODE CODE swap_!_1+ partition_type AR0#LDI, AR0 *) R0 LDI, NZ IFD, 12_bit_state AR0#LDI, AR2 AR3 *) STI, NEXTD, AR2 POP, AR3 POP, 1 # AR2 ADDI, THEN, AR0 *) R0 LDI, AR0 *) R1 LDI, Z IFD, 1 # R1 ADDI, 3 # R1 AND, R1 AR0 *) STI, NEXTD, AR2 AR3 *) STI, AR2 POP, AR3 POP, THEN, 1 # R0 CMPI, EQ IF, &12 # AR2 LSH, AR3 *) R1 LDI, $FFFF # R1 AND, R1 AR2 OR, AR2 AR3 *++) STI, -&16 # AR2 LSH, AR2 AR3 *) STI, NEXTD, AR2 POP, AR3 POP, 1 # AR2 ADDI, THEN, 2 # R0 CMPI, EQ IF, 8 # AR2 LSH, AR3 *) R1 LDI, $FFFF # R1 AND, R1 AR2 OR, AR2 AR3 *++) STI, -&16 # AR2 LSH, AR2 AR3 *) STI, NEXTD, AR2 POP, AR3 POP, 1 # AR2 ADDI, THEN, 3 # R0 CMPI, EQ IF, 4 # AR2 LSH, AR3 *) R1 LDI, $FFFF # R1 AND, R1 AR2 OR, AR2 AR3 *) STI, NEXTD, AR2 POP, AR3 POP, 1 # AR2 ADDI, THEN, END-CODE W/BUF 1- constant W/BUF-1 : clear_eob BEGIN fat_count @ W/BUF-1 and $FF + W/BUF < IF $FF FOR 2dup + 0 swap_!_1+ NEXT fat_count @ $100 + fat_count ! ELSE 2dup + 0 swap_!_1+ fat_count increment THEN pause fat_count @ W/BUF-1 and 0= UNTIL 2drop ; : head_fat_block clear_rest off 2dup + media_0 swap_!_1+ 2dup + media_1 swap_!_1+ sys_end 3 - ?FOR 2dup_+_fat_count_++@ swap_!_1+ NEXT 2dup_+_fat_count_++@ drop fat_eof swap_!_1+ main_start sys_end - ?FOR 2dup_+_fat_count_++@ drop 0 swap_!_1+ NEXT ; : fill_fat_block clear_rest @ IF clear_eob EXIT THEN W/BUF fat_count @ + main_end 2- > IF fat_count @ main_end 1- < IF BEGIN fat_count @ $FF + main_end 2- u> 0= IF $FF FOR 2dup_+_fat_count_++@ swap_!_1+ NEXT ELSE 2dup_+_fat_count_++@ swap_!_1+ THEN fat_count @ main_end 2- u> pause UNTIL THEN fat_count @ main_end 1- = IF 2dup_+_fat_count_++@ drop fat_eof swap_!_1+ THEN clear_eob clear_rest on exit THEN BEGIN fat_count @ W/BUF-1 and $FF + W/BUF < IF $FF FOR 2dup_+_fat_count_++@ swap_!_1+ NEXT ELSE 2dup_+_fat_count_++@ swap_!_1+ THEN fat_count @ W/BUF-1 and 0= pause UNTIL 2drop ; : build_fat_block flush over alloc_block 0 fat_count @ 2 = IF head_fat_block THEN fill_fat_block ; : write_fats #blk_size partition_type @ 0= IF 3 * 4 / THEN fat_blk_size ! #fats_cnt ." ." ?FOR 12_bit_state off 2 fat_count ! fat_sectors #fats_cnt 1- r@ - fat_sec * + fat_sec build_fat_block BEGIN dup fat_blk_size @ u> IF fat_blk_size @ ELSE dup THEN >r r@ raw_blk_secs ! over write_block swap r@ + swap r> - dup WHILE build_fat_block REPEAT 2drop ." ." NEXT ; : write_root_dir swap 2dup >r >r >r >r flush #root_sec raw_blk_secs ! root_sectors alloc_block r> r> build_file_name dir_file_name dup #buffer_size 0 fill dup first_entry 2/ + vol_name dir_copy dup second_entry 2/ + log_name dir_copy dup third_entry 2/ + tmp_buffer dir_copy dup r> 1+ int>char 8 shift [char] _ or swap 3 + ! r> sec>date date>word dup dup >r >r >r time>word dup dup >r >r >r r> first_entry [time] word>sec! r> second_entry [time] word>sec! r> third_entry [time] word>sec! r> first_entry [date] word>sec! r> second_entry [date] word>sec! r> third_entry [date] word>sec! main_end main_start - sec/clu @ * 9 shift third_entry [size] long>sec! sys_bytes @ #sys_size min second_entry [size] long>sec! main_start dup main_end = IF drop 0 THEN third_entry [clu0] word>sec! #fat_start dup sys_end = IF drop 0 THEN second_entry [clu0] word>sec! #file_tag third_entry [type] byte>sec! #file_tag second_entry [type] byte>sec! #volume_tag first_entry [type] byte>sec! drop root_sectors write_block ; : pos_list> flush fat_blk raw_blk_secs ! 0 >r BEGIN dup 1- swap WHILE over fat_eof <> WHILE over >r swap fat>next fat_check swap REPEAT 2drop 0 BEGIN r> dup 0= UNTIL drop ; : copy_cluster BEGIN over ?dup pause WHILE fat>lba read_block over sec/clu @ 8 shift dup >r cmove r> + swap fat>lba free_block REPEAT 2drop ; LABEL ram_prefix AR2 *) AR1 CMPI, LO IF, 0 # AR1 LDI, RETSU, THEN, AR2 AR1 LDI, AR1 *++) AR5 LDI, 1 # AR5 SUBI, 0 # R0 LDI, DO, AR3 AR0 LDI, R0 AR0 ADDI, 1 # R0 ADDI, 1 # AR0 TSTB, NZ IFD, -1 # AR0 LSH, AR0 *) AR0 LDI, NOP, -8 # AR0 LSH, THEN, $00FF # AR0 AND, AR1 *++) R1 LDI, $20 # R1 CMPI, Z IF, $20 # AR0 CMPI, HI IF, 0 # AR1 LDI, RETSU, THEN, ELSE, $3F # R1 CMPI, NZ IF, AR0 R1 XOR, NZ IF, 0 # AR1 LDI, RETSU, THEN, THEN, THEN, AR5 LOOP, -1 # AR1 LDI, RETSU, END-CODE CODE ram_prefix? AR1 POP, AR3 PUSH, AR1 AR3 LDI, AR1 POP, ram_prefix # CALL, NEXTD, AR1 AR2 LDI, AR3 POP, NOP, END-CODE : ram_strpos? -rot dup ?FOR 3dup rot ram_prefix? IF rot drop rdrop exit THEN 1- swap 1+ swap pause NEXT rot drop ; here ," \\\ " constant drop_prefix here ," \\\ " constant drop_token : ram_no_comment 2dup drop_prefix ram_prefix? IF drop 0 exit THEN 2dup drop_token ram_strpos? 0= IF drop exit THEN nip over - ; : temp>destin rot >r dup #buffer_size $2020 fill r@ 1 AND IF over r@ 2/ + dup @ $FF and $2000 or swap ! THEN r> 1+ 2/ cmove ; : trunc_mls_sys -rot 2/ >r IF IF ." & erasing mls.sys" ELSE ." & creating mls.sys" THEN r@ W/BUF $2020 fill ELSE dup W/BUF 2/ > IF ." & truncating mls.sys" drop W/BUF 2/ ELSE dup IF ." & saving mls.sys" ELSE ." & creating mls.sys" THEN THEN dup 1 and IF dup $20 r@ rot byte>word! 1+ THEN 2/ dup r@ + swap W/BUF swap - $2020 fill THEN rdrop ; : move_sys_file #string log_name dir_copy pos_find #sys_sec_max sec/clu @ / pos_list> flush sec/clu @ raw_blk_secs ! #max_sec buffer lock-buffer dup >r copy_cluster r> #blk_size raw_blk_secs ! #fat_start fat>lba alloc_block dup >r temp>destin r> 2* #buffer_size 2* ram_asc_len ram_no_comment ram_asc_len trunc_mls_sys #fat_start fat>lba write_block #max_sec block drop empty-buffer ; : format_drive flush over drive over card_present? 0= IF 4 diskerror THEN over set_adapter identify_card dup IF #sys_size sys_bytes ! _SyncTime @ ELSE sys_blocks 0 block 2* #sys_size ram_asc_len sys_bytes ! drop dos_blocks 0 read_block [SyncTime] dword@ 0 free_block THEN -rot raw_blocks IF dup move_sys_file write_mbr write_bootsector THEN write_fats write_root_dir ; variable last_mb : .last_mb dup $800 / dup last_mb @ <> IF dup last_mb ! out @ over space u. ." MB" out @ swap - backspaces THEN drop ; : repair_drive flush dup drive dup card_present? 0= IF 4 diskerror THEN set_adapter identify_card raw_blocks last_mb on cr ." system area:" FAT_OFF 1- DUP 1+ ?FOR 1 raw_blk_secs ! dup r@ - .last_mb block drop key? IF key #ctrl-C = IF cr rdrop drop EXIT THEN THEN NEXT DROP ." done. " last_mb on cr ." data area:" FAT_LEN 3 - DUP 1+ ?FOR sec/clu @ raw_blk_secs ! dup r@ - 2+ FAT>LBA .last_mb block drop key? IF key #ctrl-C = IF cr rdrop drop EXIT THEN THEN NEXT DROP ." done. " last_mb on cr ." unused area:" TOTAL @ 1- DUP 1+ FAT_LEN FAT>LBA - ?FOR 1 raw_blk_secs ! dup r@ - .last_mb block drop key? IF key #ctrl-C = IF cr rdrop drop EXIT THEN THEN NEXT DROP ." done. " cr ; Forth definitions : seek_back curr_drive off last_index off data_index off 0 drive #DOS_VIEW _last_block ! 1 _main_size ! _disk_entry off _start_disk off _rec_resume off _level_ref off ; : init_header _SkewState @ 0= IF _SyncTime @ over [SyncTime] dword! get_skew over [Skew_32b] dword! ser# @ over [SerialNr] dword! #old_data over [status_bits] ! ELSE #new_data over [status_bits] ! THEN _SkewState @ over [SkewTime] dword! $8000 over [skew_offset] ! 2dup [disk_number] ! swap *file [] >dos_cnt + @ main_blks @ min *file [] >dos_shift @ 1 swap shift * swap [block_count] dword! ; : log_out_skew scan_drives get_skew dup #no_skew = IF drop cr ." deviation not available" ELSE cr ." deviation " . ." ms" THEN _rec_resume @ IF message" (25) abnormal termination, filelength not adjusted" max_dos_file drv_count ?FOR drv_count 1- r@ - >r r@ drive r@ cr ." unknown card " 1+ u. r@ over dos_blocks 0 read_block init_header 0 write_block trailer_sys_file ." maximizing file length" r> false format_drive pause NEXT ELSE curr_drive @ drv_count ?FOR drv_count 1- r@ - >r r@ dup drive cr 2dup > IF ." full " max_dos_file THEN 2dup < IF ." empty " 1 main_blks ! THEN 2dup = IF ." last " _main_size @ main_blks ! THEN r@ ." card " 1+ u. drop r@ dos_blocks 0 read_block init_header 0 write_block trailer_sys_file ." adjusting file length" r> false format_drive pause NEXT drop max_dos_file THEN flush fall_asleep pcm_off ; : decision_process flush raw_blocks #root_sec raw_blk_secs ! root_sectors block dup third_entry 2/ + @ $FF and dup 0= swap $7F > OR swap third_entry [CLU0] 2/ + @ main_start <> OR ?dup ?EXIT dos_blocks 0 block [status_bits] @ #new_data = IF cr ." !!! previous recording hasn't been saved yet !!!" cr ." abort formatting " dtr? dup IF user_y/n 0= dup IF cr ." DESTROY OLD DATA " FALSE user_y/n nip THEN ELSE #morse_f led_message ! THEN ELSE TRUE THEN ; : log_in_format scan_drives drv_count ?FOR drv_count 1- r@ - dup cr ." card " 1+ u. dup *file [] >dos_cnt + @ *file [] >dos_shift @ 1 swap shift * ." capacity " 2/ u. ." KB" drive decision_process IF ." , formatting card" drv_count 1- r@ - dup true format_drive pause dup dos_blocks 0 alloc_block dup sec/blk @ 8 shift 0 fill sec/blk @ over [dir_skip] dword! init_header 0 write_block header_sys_file flush pause ELSE rdrop true flush fall_asleep pcm_off EXIT THEN pause NEXT false flush fall_asleep pcm_off ; : std_type_info 0 split $1E meta! $1C meta! ser# @ split $1A meta! $18 meta! entry_nr @ $16 meta! 1 $14 meta! 1 $12 meta! 1 $10 meta! 1 $0E meta! _sample_period @ $0C meta! 2 $0A meta! _bits @ &30 + $08 meta! _channels @ $06 meta! 0 $04 meta! _SyncTime @ split $02 meta! $00 meta! #std_type_tag #std_type_cmd put_meta_info ; : std_mesg_info now split $02 meta! $00 meta! 0 $04 meta! "message [] $06 >tmp_buffer #message_len $06 + move> #std_mesg_tag #std_mesg_cmd #message_len $06 + or put_meta_info ; : str_event_info #str_event_short put_meta_info ; : str_end_info #str_end_short put_meta_info ; : str_reset_info #str_reset_short put_meta_info ; : str_sync_info #str_sync_short put_meta_info ; : str_sec_info #str_sec_value and #str_sec_short or put_meta_info ; : passcal_coeff 0 meta@ 1+ 4 * #passcal_fd_tag #passcal_fd_cmd rot or put_meta_info ; : passcal_fd [ ' decimate >body ] Literal BEGIN count dup ['] EXIT <> WHILE 1- dup ['] FIR-Filter 1- = IF 0 coeff_decimation passcal_coeff THEN drop REPEAT 2drop ; &16 Constant #name_len : tmp_copy 2dup + >r >r >tmp_buffer dup r@ BL fill swap count >r swap 2r> min cmove r> pause ; : passcal_ds total_delay off 1 [ ' decimate >body ] Literal BEGIN count dup ['] EXIT <> WHILE 1- rot swap dup ['] FIR-Filter 1- = IF 0 coeff_decimation mk_spec THEN drop swap REPEAT 2drop drop &12000000 samples/sec / tmp_buffer $200 bl fill 6 >r [ ' decimate >body ] Literal BEGIN count dup ['] EXIT <> WHILE 1- dup ['] FIR-Filter 1- = IF dup 1+ >name r> #name_len tmp_copy >r THEN drop REPEAT 2drop split $04 meta! $02 meta! r@ #name_len / $00 meta! #passcal_ds_tag #passcal_ds_cmd r> or put_meta_info ; : passcal_sc "exp_number [] $000 >tmp_buffer &2 move> "exp_name [] $002 >tmp_buffer &24 move> "exp_comment [] $01A >tmp_buffer &40 move> "stat_number [] $042 >tmp_buffer &4 move> "stat_name [] $046 >tmp_buffer &24 move> "stat_comment [] $05E >tmp_buffer &40 move> "chan_name_1 [] $086 >tmp_buffer &10 move> "chan_name_2 [] $090 >tmp_buffer &10 move> "chan_name_3 [] $09A >tmp_buffer &10 move> "chan_name_4 [] $0A4 >tmp_buffer &10 move> "chan_sensor_1 [] $0AE >tmp_buffer &12 move> "chan_sensor_2 [] $0BA >tmp_buffer &12 move> "chan_sensor_3 [] $0C6 >tmp_buffer &12 move> "chan_sensor_4 [] $0D2 >tmp_buffer &12 move> "chan_sensor_nr_1 [] $0DE >tmp_buffer &12 move> "chan_sensor_nr_2 [] $0EA >tmp_buffer &12 move> "chan_sensor_nr_3 [] $0F6 >tmp_buffer &12 move> "chan_sensor_nr_4 [] $102 >tmp_buffer &12 move> "chan_comment_1 [] $10E >tmp_buffer &40 move> "chan_comment_2 [] $136 >tmp_buffer &40 move> "chan_comment_3 [] $15E >tmp_buffer &40 move> "chan_comment_4 [] $186 >tmp_buffer &40 move> #passcal_sc_tag #passcal_sc_cmd put_meta_info ; Variable next_entry Variable entry Variable next_e_drv Variable e_drv : skip_prev_sequ dos_blocks get_reset_disk next_entry off 0 read_block dup Dir_ptr ! fall_asleep pcm_off BEGIN BEGIN next_e_drv @ e_drv ! next_entry @ entry ! curr_drive @ next_e_drv ! get_dir_entry next_entry ! entry @ 0> UNTIL next_entry @ WHILE entry @ e_drv @ *file [] >dos_cnt + @ u< 0= IF 6 diskerror THEN entry @ data_index ! entry_nr increment REPEAT drop entry @ data_index ! ; : write_header data_index @ alloc_block >dat_buffer std_type_info passcal_sc passcal_ds passcal_fd ; : write_trailer curr_drive @ drive str_sync_info str_event_info str_end_info fill_data_block data_index @ put_dir_entry ; : resume_state dup data_index ! alloc_block >dat_buffer str_sync_info seconds @ dup str_sec_info str_sec_info str_reset_info curr_drive @ _start_disk @ <> IF dir_offset decrement entry_nr decrement 1- THEN drop ; : start_sequence _circular @ IF message" (3) circular debugging, data will be lost!" THEN ticks @ last_command ! flush skip_prev_sequ Samples 4 #invalid fill buf_state off _sec/mark @ sec/mark_val ! _rec_resume @ IF data_index @ last_index @ 1+ resume_state ELSE curr_drive @ _start_disk ! now _level_ref ! write_header THEN flush-erom last_command off ; : stop_sequence ticks @ last_command ! write_trailer 0 level! 0 data_index @! _main_size ! flush fall_asleep pcm_off _rec_resume off flush-erom burst_value off last_command off ; : led_server led_display @ led_hidden @ xor IF ticks @ last_key ! led_display @ dup 0= IF 0 blinkrate 0 led! THEN dup 1+ 0= IF 0 blinkrate -1 led! THEN dup 0 > IF dup blinkrate THEN 0 send_morse $80000000 xor dup led_display ! led_hidden ! THEN led_message @ 1+ IF ticks @ last_key ! led_message @ dup IF &150 ms blinkrate send_morse ELSE led_hidden @ $80000000 xor led_display ! drop THEN led_message on THEN ticks @ last_key @ ?dup IF 2dup - nip #max_key u> ticks 6 + ! THEN drop ; : halted? 'sema swap at @ -1 = ; variable duty_cycle duty_cycle off BAT variable last_access_tmp last_access_tmp off : wdog_server last_access off last_command off BEGIN #250ms sleep led_server reboot_done @ IF #2sec feed_watchdog THEN adc_sec @ 0= IF duty_cycle off ELSE duty_cycle @++ dup 0= IF buf_cnt off THEN #max_access > IF duty_cycle off buf_cnt @ 0= IF message" (77) ADC-converter not present, rebooting" err_boot THEN seconds @ adc_sec @ - 1 > IF message" (78) ADC-converter not present, rebooting" err_boot THEN THEN THEN ticks @ last_access @ ?dup IF 2dup - nip #max_access u> IF message" (11) card-access is stuck, rebooting, cmd:" pcm_cmd @ MSG_VALUE err_boot THEN THEN last_command @ ?dup IF 2dup - nip #max_command u> IF message" (12) rec-command is stuck, rebooting" err_boot THEN THEN drop adc_task halted? IF err_boot THEN disk_task halted? IF err_boot THEN sequ_task halted? IF err_boot THEN erom_task halted? IF err_boot THEN REPEAT ; : depth? depth u< ; : >expect Pad 1+ swap expect Span @ Pad c! BL Pad count + c! Pad ; : not_from_file file-load? ABORT" (55) mask can only be used from terminal" ; : $$ 1+ Pad &19 + over - 0 max bl skip drop 1- convert dup @ ?" .:/" 0= over Pad &19 + u< not or ABORT" (32) mask requires numeric input" ; : $$.$$.$$_$$:$$:$$? &17 backspaces &17 >expect dup @ IF >r 0 0 r> $$ 4 FOR 0 swap $$ NEXT nip EXIT THEN 0= ; : new_date? 6 depth? ?dup ?EXIT not_from_file ." dd.mm.yy hh:mm:ss" $$.$$.$$_$$:$$:$$? dup ?EXIT 1 backspaces ." dd.mm.yy hh:mm:ss" ; : ddmmyyhhmmss>sec 3 pick >r -rot swap >r >r nip -rot r> -rot r> -rot r> dup &1980 < IF dup &80 < IF &2000 ELSE &1900 THEN + THEN date>sec ; : get_date new_date? dup 0=EXIT drop ddmmyyhhmmss>sec ; Forth definitions : .?timing_syntax ." FOR/EVERY SECS MINS HOURS DAYS" cr ." specifies a duration after the EVERY or FOR command." cr ." Each of the fields ist optional but at least one must exist." modcr ; : ?duration 2 depth? 0= abort" FOR/EVERY SECS MINS HOURS DAYS" ; Application definitions : ?secs .?timing_syntax ; : secs [ last @ 2 + ] literal last_send_command ! ?duration + ; : ?mins .?timing_syntax ; : mins [ last @ 2 + ] literal last_send_command ! ?duration &60 * + ; : ?hours .?timing_syntax ; : hours [ last @ 2 + ] literal last_send_command ! ?duration &3600 * + ; : ?days .?timing_syntax ; : days [ last @ 2 + ] literal last_send_command ! ?duration &86400 * + ; Forth definitions : .?level_syntax ." AFTER HOURS DAYS LEVELLING" CR ." EVERY HOURS DAYS AFTER HOURS DAYS LEVELLING" modcr ; Application definitions : ?every .?level_syntax ; : every [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) EVERY not while recording" 0 ; : ?after .?level_syntax ; : after [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) AFTER not while recording" 1 depth? 0= IF $7FFFFFFF THEN 0 ; : ?levelling .?level_syntax ; : levelling [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) LEVELLING not while recording" 2 depth? 0= ABORT" (48) LEVELLING not enough parameters" 1 [ FORTH ] max [ Application ] dup _level_off ! [ FORTH ] max [ Application ] _level_every ! modcr ; Forth definitions Label release_ISR _synctime addr Assembler AR0#ldi, AR0 _release addr _synctime addr - Assembler # +*) AR1 ldi, AR0 *) AR1 subi, Seconds AR0#ldi, AR0 *) AR1 cmpi, C IFD, 2 # AR0 ldi, AR0 AD_PINS #) sti, nop, $8002 # AR0 ldi, AR0 AD_PINS #) sti, THEN, retsu, end-code : init_release _synctime @ 0= IF _release off EXIT THEN _release @ 0=EXIT release_ISR 'secserver ! ; : .release _release @ 0= IF ." not set" EXIT THEN _release @ now u< IF ." activated" EXIT THEN _release @ 1+ .time&date ; Application definitions : ?release ." RELEASE" ; : release _SyncTime @ 0= ABORT" (40) RELEASE not synchronized" _rec_enable @ ABORT" (41) RELEASE not while recording" get_date ?dup 0=exit 1- _release ! init_release ; Forth definitions 1 Constant #remote_operation : .license ?cr #200hzmode case? IF ." 200_Sps " EXIT THEN #remote_operation case? IF ." remote_operation " EXIT THEN ." option_" . cr ; Application definitions Forth : ?license ." LICENSE activates option N." cr ." LICENSE without parameters displays activated options." modcr ; : license [ last @ 2 + ] literal last_send_command ! 3 depth? IF dup #licenses u< 0= ABORT" (33) LICENSE invalid option number" set_license syserom-flush THEN #licenses 0 DO I check_license IF I .license ?cr THEN LOOP modcr ; Forth definitions : (disk_full buf_adc off adc_sec off NO_INT INT_ADC INT! _disk_full on now _stop ! message" (60) cards full" ; : disk_capacity 0 drv_count ?FOR *file [] >dos_cnt r@ + @ 1- sec/blk @ * 0 max + NEXT 0 max 2/ 0 curr_drive @ ?FOR curr_drive @ 1- r@ - *file [] >dos_cnt + @ 1- sec/blk @ * 0 max + NEXT data_index @ _main_size @ max 1- sec/blk @ * + 2/ buf_ptr @ w/buf /mod drop -&10 shift + ; Variable sequencer : .stop _stop @ ?dup 0=EXIT cr ." Stop " .time&date ; : .start _start @ ?dup 0=EXIT cr ." Start " .time&date ; : .duration ?dup IF &60 /mod &60 /mod &24 /mod ?dup IF . ." days " THEN ?dup IF . ." hours " THEN ?dup IF . ." mins " THEN ?dup IF . ." secs " THEN ELSE ." 0 secs " THEN backspace ; : .levelling _level_off @ #max_int <> IF cr ." Levelling " _level_every @ #max_int <> IF ." Every " _level_every @ .duration ." " THEN ." After " _level_off @ .duration THEN ; : .intervall _every @ _for @ <> IF cr ." Interval " ." Every " _every @ .duration ." " ." For " _for @ .duration THEN ; : "word? [char] " word dup c@ ; : .channeldata "chan_name_1 [] over &11 * + .string space "chan_sensor_1 [] over &13 * + .string space "chan_sensor_nr_1 [] over &13 * + .string space "chan_comment_1 [] over &41 * + .string drop ; : .channels _channels @ dup 0 = IF ." hydrophone" THEN dup 2 = IF ." seismometer" THEN 3 = IF ." all" THEN ; Application definitions Forth : settings [ last @ 2 + ] literal last_send_command ! base push decimal rs232_sema lock cr ." Date & Unit " now .time&date space .serialnumber cr ." Synchronized " _SyncTime @ ?dup IF .time&date ELSE ." No" THEN cr ." Release " .release cr ." Channels " .channels cr ." Sampling " [ #Frequency $200 / ] Literal _sample_period @ / . ." Sps, " bits/sample . ." bits" _preview_src @ IF ." , 1 Sps preview buffer" THEN cr ." Capacity " disk_capacity _SkewState @ IF nip . ." kB data, cards closed" ELSE swap . ." kB total, " . ." kB recorded" THEN .start .stop .intervall .levelling cr ." Status " .mls_state cr ." Experiment " "exp_name .string cr ." Comment " "exp_comment .string modcr rs232_sema unlock ; Application ' settings alias st Forth Forth definitions : set_sec dup #MinFilter / swap 2* dup #Frequency $100 / BEGIN ?dup WHILE 2dup mod >r nip r> REPEAT / BEGIN 2dup > WHILE 2* REPEAT nip drop 1 _sec/mark ! ; Create bits_tab &15 , &18 , &19 , &20 , &21 , &22 , &22 , &22 , &22 , : set_adc dup 0 BEGIN over #MinFilter > WHILE 1+ swap 2/ swap REPEAT nip bits_tab + @ bits dup #HalfClock > IF 2/ 2* THEN dup set_sec _sample_period ! ; Application definitions : ?ms ." MS converts milliseconds into frequency for use with RATE." modcr ; : ms [ last @ 2 + ] literal last_send_command ! &1000 swap / ; Forth definitions Create Valid.rates &1 , &2 , &3 , &4 , &5 , &6 , &10 , &20 , &25 , &30 , &40 , &50 , &60 , &75 , &100 , &120 , &130 , &150 , &200 , 0 , : rate.valid? >r Valid.rates BEGIN dup @ dup WHILE r@ = dup 0= WHILE drop cell+ REPEAT rdrop nip ; Application definitions : ?rate ." RATE sets the effective sampling rate of the system." cr ." Valid rates are: 1, 2, 3, 4, 5, 6, 10, 20, 25, 30, 40, 50, 60, 75," cr ." 100, 120, 130, 150, and 200." modcr ; : rate [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) RATE not while recording" 1 depth? 0= ABORT" (50) RATE needs a parameter" dup 0= ABORT" (34) RATE samplerate not supported" dup rate.valid? 0= ABORT" (34) RATE sample rate not supported" dup &50 > IF #200hzmode check_license 0= ABORT" (46) RATE has not been licensed" THEN &128 * [ #Frequency 4 / ] Literal swap / set_adc modcr ; Forth definitions : set_channels NO_INT INT_ADC INT! Adc_task deactivate Active_channels ! _preview_src @ IF set_preview_src THEN adcq_empty Adc_task activate sampling ; Application definitions : ?channels ." <1, 3 or 4> CHANNELS" modcr ; : channels [ last @ 2 + ] literal last_send_command ! 1- _rec_enable @ ABORT" (41) CHANNELS not while recording" 1 depth? 0= ABORT" (50) CHANNELS needs a parameter" dup 3 u> ABORT" (36) CHANNELS range 1, 3 or 4" dup 1 = ABORT" (36) CHANNELS range 1, 3 or 4" dup _channels ! set_channels modcr ; : ?experiment ." EXPERIMENT " modcr ; : experiment [ last @ 2 + ] literal last_send_command ! "word? IF skip_bl fill_bl "exp_name &24 passcalstring EXIT THEN drop "exp_name .string modcr ; : ?comment ." COMMENT " modcr ; : comment [ last @ 2 + ] literal last_send_command ! "word? IF skip_bl fill_bl "exp_comment &40 passcalstring EXIT THEN drop "exp_comment .string modcr ; Application definitions Vocabulary Passcal : ? [ last @ 2 + ] literal last_send_command ! words modcr ; : ?forth Only Forth Application also Forth also definitions ; : ?passcal ." activates a sub-menue for defining PASSCAL name strings." modcr ; Passcal definitions : exit [ last @ 2 + ] literal last_send_command ! Application modcr ; : ?exit ." returns to the main menue." modcr ; : ? [ last @ 2 + ] literal last_send_command ! words modcr ; : ?expnumber ." ExpNumber" modcr ; : ExpNumber [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) ExpNumber not while recording" 1 depth? 0= ABORT" (50) ExpNumber needs a parameter" s>d <# # # #> uncount skip_bl fill_bl "exp_number [] 2 passcalstring modcr ; : ?expname ." ExpName <24-chars>" modcr ; : ExpName [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) ExpName not while recording" word" skip_bl fill_bl "exp_name &24 passcalstring modcr ; : ?expcomment ." ExpComment <40-chars>" modcr ; : ExpComment [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) ExpComment not while recording" word" skip_bl fill_bl "exp_comment &40 passcalstring modcr ; : ?statnumber ." StatNumber sets station number" modcr ; : StatNumber [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) StatNumber not while recording" 1 depth? 0= ABORT" (50) StatNumber needs a parameter" s>d <# # # # # #> uncount "stat_number [] 4 passcalstring modcr ; : ?statname ." StatName <24-chars> sets station name" modcr ; : StatName [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) StatName not while recording" word" skip_bl fill_bl "stat_name &24 passcalstring modcr ; : ?statcomment ." StatComment <40-chars> sets station comment" modcr ; : StatComment [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) StatComment not while recording" word" skip_bl fill_bl "stat_comment &40 passcalstring modcr ; : ?channame ." ChanName <10-chars> sets name of channel N" modcr ; : ChanName [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) ChanName not while recording" 1 depth? 0= ABORT" (50) ChanName needs a parameter" 1 - 3 umin &11 * >r word" skip_bl fill_bl "chan_name_1 [] r> + &10 passcalstring modcr ; : ?chansensor ." ChanSensor <12-chars> sets sensor of channel N" modcr ; : ChanSensor [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) ChanSensor not while recording" 1 depth? 0= ABORT" (50) ChanSensor needs a parameter" 1 - 3 umin &13 * >r word" skip_bl fill_bl "chan_sensor_1 [] r> + &12 passcalstring modcr ; : ?chansensornumber ." ChanSensorNumber <12-chars> sets sensor number" modcr ; : ChanSensorNumber [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) ChanSensorNumber not while recording" 1 depth? 0= ABORT" (50) ChanSensorNumber needs a parameter" 1 - 3 umin &13 * >r word" skip_bl fill_bl "chan_sensor_nr_1 [] r> + &12 passcalstring modcr ; : ?chancomment ." ChanComment <40-chars> sets comment for channel N" modcr ; : ChanComment [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) ChanComment not while recording" 1 depth? 0= ABORT" (50) ChanComment needs a parameter" 1 - 3 umin &41 * >r word" skip_bl fill_bl "chan_comment_1 [] r> + &40 passcalstring modcr ; : ?passcal? ." displays setting of PASSCAL name strings" modcr ; : passcal? [ last @ 2 + ] literal last_send_command ! RS232_sema lock cr ." Experiment number : " "exp_number .string cr ." Experiment name : " "exp_name .string cr ." Experiment comment : " "exp_comment .string cr ." Station number : " "stat_number .string cr ." Station name : " "stat_name .string cr ." Station comment : " "stat_comment .string cr cr ." Channel parameters" cr ." No Name Sensor Sensor# Comment" _channels @ 1+ 0 DO cr I 1+ 2 u.r space I .channeldata LOOP 2 spaces modcr RS232_sema unlock ; Forth definitions &666 ms Constant #666ms : go_active next_flush off true 2048Hz! str_event_info 1 sec/mark_cnt ! ADC_INT INT_ADC INT! init_seconds buf_adc on #250ms led_display ! ; : go_passive NO_INT INT_ADC INT! flush-adc adc_sec off spill @ IF #100ms led_display ! message" (75) skipping data due to slow card" ticks @ last_command ! save-buffers last_command off std_mesg_info spill off THEN #666ms led_display ! ; : interval_handler now 1+ _start @ - _every @ mod ?dup IF 1- _for @ < ELSE 1 THEN halted @ 0= and spill @ 0= and lowbat_timeout? 0= and Sequencer @ 2dup <> IF 2dup -1 = swap 0= or IF lowbat_timeout? IF message" (61) battery low" THEN go_passive Sequencer off THEN over 1 = IF dup 2 <> IF #666ms led_display ! #666ms sleep THEN go_active 1 Sequencer ! THEN over -1 = IF dup 1- IF go_active THEN Sequencer on THEN THEN 2drop ; : levelling_handler _level_off @ #max_int = ?exit now _level_off @ _level_ref @ + u> IF now _level_off @ - _level_ref @ - _level_every @ mod _level_for @ < ELSE 0 THEN level! ; 7 Field >admclock : init_adm_speed _sample_period @ #HalfClock > IF 1 ELSE 2 THEN Ticks >admclock ! 1 sleep ; : init_adc init_adm_speed adc_sec off set_preview_filter AD_0-3 AD_SEL ! ADC_INT INT_ADC INT! _sample_period @ DUP #HalfClock > IF 2/ THEN dup SET_ADC_FILTER SET_ADC_FILTER SET_ADC_MODE ?ADRDY $5c AD_OUT ! SYNC ; : finish_resume lowbat_timeout? IF Ticks >admclock off cr ." battery powered, waiting for power supply..." #50ms sleep False led! #cpu_slow Dev_Ctrl ! #peri_off Dev_Ctrl ! BEGIN pause lowbat_timeout? 0= UNTIL #cpu_fast Dev_Ctrl ! #peri_on Dev_Ctrl ! True led! #50ms sleep cr ." power reconnected" cr EXIT THEN _disk_full @ _SkewState @ or 0= _rec_resume @ and 0=EXIT start_sequence stop_sequence message" (21) finishing recording" ; : rec_off? _rec_enable @ 0= _disk_full @ OR _SkewState @ OR lowbat_timeout? 0<> OR ; : wait_for_start 1 sequ_state ! _disk_full @ IF _rec_enable off THEN BEGIN rec_off? WHILE finish_resume #250ms sleep REPEAT 2 sequ_state ! #PERI_ON DEV_CTRL ! ; : wait_for_stop init_adc spill off halted off BEGIN rec_off? 0= WHILE interval_handler levelling_handler 4 sequ_state ! #250ms sleep REPEAT 3 sequ_state ! halted on interval_handler SET_ADC_MODE ; Semaphor kick_sequ : sequencing sequ_state off dos_blocks kick_sequ wait BEGIN flush-erom wait_for_start #100ms led_display ! start_sequence wait_for_stop #100ms led_display ! stop_sequence led_display on _circular off REPEAT ; : reset_sequ_task Sequ_task cancel Sequ_task roundrobin spawn sequencing ; : booting_done reboot_done on kick_sequ signal ; LABEL prefix AR2 *) AR1 CMPI, LO IF, 0 # AR1 LDI, RETSU, THEN, AR2 AR1 LDI, AR1 *++) AR5 LDI, 1 # AR5 SUBI, 0 # R0 LDI, DO, AR3 AR0 LDI, R0 AR0 ADDI, 1 # R0 ADDI, AR0 *) AR0 LDI, AR1 *++) R1 LDI, $20 # R1 CMPI, Z IF, $20 # AR0 CMPI, HI IF, 0 # AR1 LDI, RETSU, THEN, ELSE, $3F # R1 CMPI, NZ IF, AR0 R1 XOR, NZ IF, 0 # AR1 LDI, RETSU, THEN, THEN, THEN, AR5 LOOP, -1 # AR1 LDI, RETSU, END-CODE CODE prefix? AR1 POP, AR3 PUSH, AR1 AR3 LDI, AR1 POP, prefix # CALL, NEXTD, AR1 AR2 LDI, AR3 POP, NOP, END-CODE : strpos? -rot dup ?FOR 3dup rot prefix? IF rot drop rdrop exit THEN 1- swap 1+ swap pause NEXT rot drop ; : no_comment 2dup drop_prefix prefix? IF drop 0 exit THEN 2dup drop_token strpos? 0= IF drop exit THEN nip over - ; CODE ASC_LEN 1 # AR2 CMPI, 1 # AR2 SUBI, HS IF, DO, AR3 AR0 LDI, AR2 AR0 ADDI, AR0 *) AR0 LDI, $20 # AR0 CMPI, HI IF, 1 # AR2 ADDI, NEXT, THEN, AR2 LOOP, THEN, 0 # AR2 LDI, NEXT, END-CODE : evaluate_sys_file reset_sequ_task flush scan_drives #STRING LOG_NAME DIR_COPY RAW_BLOCKS pad heap over - dos_load flush fall_asleep pcm_off dup IF _rec_resume off _rec_enable off THEN dup IF message" (2) loading MLS.SYS-file" asc_len dup ." ( " . no_comment asc_len dup ." bytes / " . ." code )" booting_done Forth also Application evaluate previous Application ELSE 2drop booting_done THEN ; : (close reset_sequ_task #100ms led_display ! now _SkewState ! log_out_skew flush-erom led_display on #morse_o led_message ! kick_sequ signal ; : (format reset_sequ_task #100ms led_display ! init-erom _SkewState off _SystemSkew off _SystemTime off _SystemTicks off log_in_format led_display on kick_sequ signal drv_count 0= over or _SkewState ! ABORT" (51) FORMAT no card found" drv_count 0= ABORT" (52) FORMAT can't format any cards" seek_back _disk_full off empty-errors drv_count cr u. ." cards locked for recording." #morse_o led_message ! cr ; : .dcf77_pin ." using the signal on the auxiliary input, pin-3 active_low" ; : abort_dcf led_display on kick_sequ signal #2sec feed_watchdog abort ; Application definitions : ?rec ." activates MLS for recording." modcr ; : rec [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) REC not while recording" _SyncTime @ 0= ABORT" (40) REC not synchronized" _SkewState @ ABORT" (45) REC cards have been closed" _disk_full @ ABORT" (60) REC cards full" _rec_enable on _stop off now _start ! RAM_preview *preview_ptr ! modcr ; : ?end ." terminates data recording." modcr ; : end _rec_enable @ 0=EXIT [ last @ 2 + ] literal last_send_command ! _rec_enable off now _stop ! RAM_preview *preview_ptr ! BEGIN PAUSE sequ_state @ 1 = UNTIL modcr ; Application definitions : ?repair ." repairs sectors with CRC-Errors on PCM-Flash-cards" modcr ; : repair [ last @ 2 + ] literal last_send_command ! _rec_enable @ ABORT" (41) REPAIR not while recording" _SyncTime @ ABORT" (47) REPAIR not while synchronized" 1 depth? 0= ABORT" (50) REPAIR needs a parameter" 1- dup &11 u> ABORT" (30) REPAIR range 1 to 12" reset_sequ_task reset_adapter scan_drives dup disk_present? 0= ABORT" (51) REPAIR no card found" cr ." press CTRL-C to abort." cr #100ms led_display ! repair_drive led_display on flush fall_asleep pcm_off kick_sequ signal modcr ; : ?synchronize ." [ day month year hour minute second ] SYNCHRONIZE" cr ." sets time and date and waits for a synchronisation pulse" cr .dcf77_pin cr ." and formats cards" modcr ; : synchronize _rec_enable @ ABORT" (41) SYNCHRONIZE not while recording" get_date ?dup 0=exit reset_sequ_task cr ." press CTRL-C to abort." #morse_w led_message ! cr ." waiting for a synchronisation pulse..." #max_int feed_watchdog sync_pulse ." synchronized" init_release #2sec feed_watchdog (format modcr ; : ?dcf77 ." synchronizes the clock and sets time and date" cr .dcf77_pin cr ." and formats cards" modcr ; : dcf77 _rec_enable @ ABORT" (41) DCF77 not while recording" reset_sequ_task #morse_w led_message ! ." waiting for sync pulse - press CTRL-C to abort" dcf77_init cr ." synchronized " #morse_s led_message ! wait_59th ." time and date: " #max_int feed_watchdog dcf77_exec #2sec feed_watchdog init_release (format modcr ; : ?format ." formats cards" modcr ; : format _rec_enable @ ABORT" (41) FORMAT not while recording" _SyncTime @ 0= ABORT" (40) FORMAT not synchronized" (format modcr ; Forth definitions variable error_cnt Create diskstat_vars &12 allot -2 Constant #N/A -1 Constant #OK : break-test? key? IF key #ctrl-c = IF 0 buffer drop unlock-buffer halt_task RoundRobin spawn idle_server led_display on true ABORT" user abort!" THEN ." CTRL-C to abort the test" cr THEN ; : write-blocks DO ." w" dup 0 1 d.r ." :" I u. ?cr 0 buffer $4000 I $FFFF and fill pause 0 buffer $40 I over * writemultiple IF 0 buffer drop unlock-buffer #100ms led_display ! dup diskstat_vars + I swap ! error_cnt increment ." write error" UNLOOP EXIT THEN break-test? pause LOOP ; code verify-block r1 pop, $FFFF # r0 ldi, $10 # r0 LSH, r0 r1 or, 1 # ar2 subi, DO, AR3 *++) r1 cmpi, ne IF, AR3 pop, -1 # ar2 ldi, NEXT, THEN, AR2 LOOP, 0 # ar2 ldi, AR3 pop, NEXT, end-code : verify-blocks DO ." v" dup 0 1 d.r ." :" I u. ?cr 0 buffer $40 I over * readmultiple IF 0 buffer drop unlock-buffer #100ms led_display ! dup diskstat_vars + I swap ! error_cnt increment ." read error" UNLOOP EXIT THEN I $FFFF and 0 buffer $4000 verify-block IF cr ." verifying failed. expected:" I u. ." read:" I @ $FFFF and u. 0 buffer drop unlock-buffer #100ms led_display ! dup diskstat_vars + I swap ! error_cnt increment UNLOOP EXIT THEN break-test? pause LOOP dup diskstat_vars + #ok swap ! ; : diskstat_init error_cnt off #slots 0 DO #N/A diskstat_vars I + ! LOOP ; : .diskstat #N/A case? IF ." N/A" EXIT THEN #OK case? IF ." OK" EXIT THEN ." ERROR : BLOCK NR:" u. ; : (diskstat cr ." Card Nr.* Status" cr #slots 0 DO I 0 3 d.r ." " diskstat_vars I + @ .diskstat cr LOOP ." *Note: the card number is referring to the number" cr ." of inserted cards and not a slot number!" ; : dtremit dtr? IF std_emit ELSE drop THEN ; : dtrcr dtr? IF std_cr THEN ; : dtrbackspace dtr? IF std_backspace THEN ; CREATE dtr_IO ] dtrEMIT dtrCR dtrBACKSPACE [ : (test&format base push decimal &100 led_display ! cr ." All data and the file system on the inserted cards" cr ." will be COMPLETELY DESTROYED! This procedure also " cr ." takes a lot of time ( approx. 3h for 1Gb)." cr ." Do you want to cancel operation" true user_y/n ABORT" Operation canceled" cr ." Are you sure" false user_y/n 0= ABORT" Operation canceled" cr ." CTRL-C to abort the test" cr diskstat_init halt_task cancel scan_drives 0 buffer drop lock-buffer #slots 0 DO I card_present? IF cr ." testing card:" I . cr ." identifying card:" I set_adapter identify_card I total @ dup 2/ u. ." kb " $40 / dup u. ." blocks" cr ." writing blocks " swap over 0 write-blocks cr cr ." verifying blocks " swap 0 verify-blocks cr THEN LOOP 0 buffer drop unlock-buffer cr error_cnt @ IF error_cnt @ u. ." cards failed" cr ." card formating skipped" cr #100ms led_display ! ELSE ." all cards passed test." cr ." formating all cards" cr (format THEN fall_asleep pcm_off halt_task RoundRobin spawn idle_server ; Application definitions Forth : ?test&format ." TEST&FORMAT checks functionality of all inserted cards." modcr ; : test&format _rec_enable @ ABORT" (41) TEST&FORMAT not while recording" (test&format modcr ; : ?diskstat ." DISKSTAT displays results of previous test&format" modcr ; : diskstat (diskstat modcr ; : ?close ." closes storage cards without writing a skew value." modcr ; : close _rec_enable @ ABORT" (41) CLOSE not while recording" _SyncTime @ 0= ABORT" (40) CLOSE not synchronized. WARNING: new synchronization destroys data" (close modcr ; : ?skew ." displays and writes clock skew to cards" modcr ; : skew _rec_enable @ ABORT" (41) SKEW not while recording" _SyncTime @ 0= ABORT" (40) SKEW not synchronized" reset_sequ_task ." waiting for sync pulse - press CTRL-C to abort" #morse_w led_message ! dcf77_init cr ." skew locked " #morse_s led_message ! wait_59th ." time and date: " #max_int feed_watchdog skew_exec #2sec feed_watchdog _SystemTicks ! _SystemTime ! _SystemSkew ! init_release (close modcr ; : ?drift ." displays clock skew without closing cards" modcr ; : drift _rec_enable @ ABORT" (41) DRIFT not while recording" _SyncTime @ 0= ABORT" (40) DRIFT not synchronized" ." waiting for sync pulse - press CTRL-C to abort" dcf77_init cr ." skew locked " wait_59th ." time and date: " #max_int feed_watchdog skew_exec #2sec feed_watchdog >r swap - dup abs &2000000 > IF MESSAGE" (35) DRIFT out of range" drop rdrop EXIT THEN &1000 * r> + ." deviation " . ." ms" modcr ; Forth definitions : ?remote_license #remote_operation check_license 0= ABORT" (46) remote_operation has not been licensed" ; Application definitions : ?resynchronize ." re-synchronizes the internal time base to the 1 pps-pulse" cr ." fed into Pin3 of the auxiliary connector." cr ." The deviation displayed is positive when the internal clock" cr ." was early, it is negative when it was late." ; : resynchronize ?remote_license true band! resync false band! timestamp [ here 3 + ] Literal ." Resynchronisation " e_addr dup msg_value . [ here 3 + ] Literal ." ms deviation" e_addr ; Application definitions Forth : ?load ." the MLS.SYS file" modcr ; : load _rec_enable @ ABORT" (41) LOAD not while recording" not_from_file reset_adapter 0 card_present? 0= ABORT" (53) LOAD insert card in slot #1 first" evaluate_sys_file modcr ; : ?messages ." displays the content of the system message queue." modcr ; : messages [ last @ 2 + ] literal last_send_command ! errors modcr ; Forth definitions -5 Constant #preview -6 Constant #out1 -7 Constant #out2 : ?on/off ABORT" use with PREVIEW, OUT1, OUT2" ; Application definitions Forth : ?out1 ." ON/OFF controls Pin4 of the Auxiliary Connector." ; #out1 Constant out1 : ?out2 ." ON/OFF controls Pin7 of the Auxiliary Connector." ; : out2 _release @ ABORT" is used as release output." #out2 ; : ?on ." is used to enable functions PREVIEW, OUT1, OUT2." ; : on #preview case? IF ?remote_license _rec_enable @ ABORT" (41) PREVIEW ON not while recording" set_preview_src EXIT THEN #out2 case? IF true dup _gain ! gain! EXIT THEN #out1 - ?on/off true dup _band ! band! ; : ?off ." is used to disable functions PREVIEW, OUT1, OUT2." ; : off #preview case? IF _preview_src off EXIT THEN #out2 case? IF false dup _gain ! gain! EXIT THEN #out1 - ?on/off false dup _band ! band! ; Forth definitions : .?retrieve_syntax ." FROM " cr ." FOR [ SECS] [ MINS] [ HOURS] RETRIEVE " cr ." retrieves recorded data from the specified date for the specified" cr ." duration and writes it to ." ; Application definitions Forth : ?from .?retrieve_syntax ; : from ?remote_license 0 ; : ?for .?timing_syntax ; : for ?remote_license 7 depth? IF ddmmyyhhmmss>sec swap IF .?retrieve_syntax abort THEN THEN 1 depth? IF 0 EXIT THEN .?timing_syntax abort ; : ?retrieve .?retrieve_syntax ; : retrieve ?remote_license #preview case? IF preview_transfer EXIT THEN 2 depth? 0= IF .?retrieve_syntax abort THEN transfer ; : ?preview ." PREVIEW RETRIEVE retrieves preview data." cr ." PREVIEW ON switches the preview queue on," cr ." PREVIEW OFF switches the preview queue off." ; : preview ?remote_license #preview ; Forth definitions $0000 Constant #year $0100 Constant #month $0200 Constant #day $0300 Constant #hour $0400 Constant #min $0500 Constant #sec $0600 Constant #shift $0700 Constant #ac_dc $0800 Constant #ref $0d00 Constant #channels $0e00 Constant #rate_hi $0f00 Constant #rate_lo $2000 Constant #monitor $2100 Constant #clear_text $2200 Constant #reset_ega variable show_zero variable show_adju variable show_shift variable show_offs : send-word $A5 ctx wsplit swap ctx ctx ; : code_cmd 2* 1 or ; : code_data -2 and ; : CodeWord wsplit >r swap r> or code_cmd send-word or code_cmd send-word ; : CodeByte $ff and or code_cmd send-word ; : send-time now sec>date &1900 - #year swap CodeByte #month swap CodeByte #day swap CodeByte #hour swap CodeByte #min swap CodeByte #sec swap CodeByte ; : send-ctrl #shift show_shift @ CodeByte #ac_dc show_adju @ 0= 1+ CodeByte #ref show_zero @ 0= 1+ CodeByte ; : send-header #clear_text 0 CodeByte #reset_ega 0 CodeByte #channels _channels @ 1+ CodeByte #rate_lo #rate_hi samples/sec CodeWord #monitor over 1+ CodeByte ; variable buf_own variable buf_full : mean_value>>10 >r 0 0 BEGIN swap over buf_base + @ + swap 1+ dup r@ 1- > UNTIL drop 6 ashift r> / 4 ashift ; : modify_gain show_shift @ + 0 max bits/sample 2- min show_shift ! ; : toggle_adju show_adju @ 0= show_adju ! buf_full @ IF pixels @ ELSE buf_in @ THEN mean_value>>10 show_offs ! ; : toggle_zero show_zero @ 0= show_zero ! ; : ctrl-c? True dtr? 0=EXIT 0= key? 0=EXIT drop key dup [char] + = IF 1 modify_gain THEN dup [char] - = IF -1 modify_gain THEN dup &13 = IF toggle_zero THEN dup bl = IF toggle_adju THEN dup &9 = IF show_shift off show_zero off show_adju off THEN #ctrl-C = dup 0= IF send-ctrl THEN ; : view_screens show_zero off show_adju off show_shift off show_offs off buf_full off buf_base pixels @ 0 fill 0 modify_gain send-ctrl BEGIN buf_in off buf_out off buf_own off send-time 0 BEGIN BEGIN pause ctrl-c? IF drop exit THEN buf_own @ buf_in @ < UNTIL buf_own @++ buf_base + @ dup >r 8 ashift show_offs @ dup -9 ashift 1+ 2/ - r> + show_offs ! show_adju @ IF show_offs @ -1 ashift 1+ 2/ - THEN &8 bits/sample - show_shift @ + ashift show_zero @ IF buf_own @ 1 and 0= and THEN $7fff min -$8000 max code_data send-word 1+ dup pixels @ 1- > UNTIL drop buf_full on REPEAT ; : eval_pixel_width &591 pixels ! 0 0 >r BEGIN key? WHILE rdrop key >r r@ #ctrl-C = IF rdrop drop exit THEN r@ &10 = IF rdrop #pixels_max min pixels ! exit THEN r@ $2F > WHILE r@ $40 < WHILE &10 * r@ $30 - + REPEAT rdrop drop ; Application definitions : hydrophone 1 ; : seismometer1 2 _channels @ 2 = + ; : seismometer2 3 _channels @ 2 = + ; : seismometer3 4 _channels @ 2 = + ; : seismometer 3 ; : all 4 ; : show dtr? 0=EXIT 1 depth? 0= ABORT" (50) SHOW needs a parameter" 1- dup 3 u> ABORT" (37) SHOW range 1 to 4" _channels @ over u< ABORT" (56) SHOW channel not active" ." press CTRL-C to finish." _rec_enable @ 0= swap over IF reset_sequ_task init_adc THEN #esc ctx ." \show" cr #1sec sleep eval_pixel_width send-header pixels @ 1+ buf_len ! _channels @ swap - buf_show ! view_screens buf_show on buf_in off buf_out off #1sec sleep IF adc_sec off NO_INT INT_ADC INT! SET_ADC_MODE flush-adc kick_sequ signal THEN ; forth definitions Constant #version Forth definitions : init_var 1 raw_blk_secs ! get_disk_dir off burst_value off data_index off curr_drive off last_index off Buf_adc off sequencer off adc_sec off halted on buf_show on buf_in off buf_out off led_display on led_message on led_hidden off show_zero off show_adju off show_shift off show_offs off diskstat_init max_dos_file ; : init_nv_disk #DOS_VIEW _last_block ! 1 _main_size ! _disk_entry off _start_disk off _rec_resume off _disk_full off _SystemSkew off _SkewState on ; : init_nv_var init_nv_disk #max_int _for ! #max_int _every ! #max_int _level_every ! #level_off _level_off ! #level_for _level_for ! _band off _level_ref off _cis_enable off _stop off _start off 3 _channels ! _SyncTime off _SystemTime off _SystemTicks off _circular off _boot_delay off _rec_enable off _gain on _release off _preview_src off &50 [ Application ] rate [ FORTH ] empty-errors Ehere @ (forget flush-erom ; : link_server ['] (disk_full 'disk_full ! [ Application ] ['] settings 'settings ! [ Forth ] ['] abort_dcf 'abort_dcf ! ['] std_fall_asleep IS fall_asleep ['] std_wake_up IS wake_up ['] std_r/w IS r/w ['] std_diskerror IS diskerror ['] new_std_error IS onerror ; : set_register _SyncTime @ 0= IF _stop off _start off _rec_enable off seconds off THEN my_tickerint tint0 INT! no_int int_adc INT! init_adm_speed eint_adc enable adcq_empty _channels @ set_channels dos_blocks 0 level! ; : init_tasks disk_task Priority spawn server [ nexttask disk_task at ] Literal [ 'pause disk_task at ] Literal ! pause adc_task disk_task spawn sampling pause sequ_task RoundRobin spawn sequencing wdog_task RoundRobin spawn wdog_server halt_task RoundRobin spawn idle_server ; : seek_curr_block _last_block @ /drive dup curr_drive ! *file [] >dos_off + @ - sec/blk @ / last_index ! ; : evaluate_cards dos_blocks skip_prev_sequ curr_drive @ lock_device data_index @ dup 1- block_alert @ = IF _disk_full on dup _main_size ! ELSE dup block_range @ = IF get_disk_dir on entry_nr @ disk_entry ! ELSE dup _main_size ! THEN THEN drop curr_drive @ dup drive _start_disk ! _SkewState off _rec_resume off offset @ write_log ; : repair_state reset_sequ_task buf_adc off adc_sec off NO_INT INT_ADC INT! flush-adc flush led_display on data_index @ IF stop_sequence THEN Adc_task cancel init_var init_nv_disk scan_drives _SkewState @ IF 3 FOR 3 r@ - >r r@ disk_present? IF r@ cr ." card " 1+ u. ." restoring information" r@ true format_drive r@ 0= IF evaluate_sys_file THEN r@ header_sys_file r@ #no_skew dos_blocks 0 read_block init_header 0 write_block flush THEN rdrop NEXT THEN evaluate_cards message" (23) settings restored, rebooting" err_boot ; : .who ." MLS-FIRMWARE " ; : boot_message decimal cr .WHO ." VER_" #version .VERSION #date .DATE .COPYRIGHT cr watchdog? IF ." boot " ELSE ." cold " THEN _synctime @ IF now .time&date ELSE ." unsynchronized " THEN ; : message_queue dtr? 0=EXIT escape_all @ ?EXIT _rec_enable @ 0= errors? and IF cr print-errors cr ." empty message queue" False boot_y/n IF empty-errors THEN THEN ; : escape_nv_delay? escape_all off true key? 0=exit not key bl = 0=exit message" (0) space-key detected" cr ." abort escape-boot-sequence (recommended) " TRUE boot_y/n ?exit cr ." ERASE MLS-STATE (all user-configuration) " FALSE boot_y/n 0=exit escape_all on init_nv_var ; : perform_nv_delay escape_all @ IF drop exit THEN _boot_delay @ 0= IF drop exit THEN _boot_delay @ $100 = over and IF message" (5) unrecoverable error, shutdown" _boot_delay off _rec_enable off THEN _boot_delay @ 2* 2* message" (24) boot_delay" ?FOR #250ms sleep key? IF key 2drop false THEN dup 0= IF ." skipped" drop rdrop EXIT THEN NEXT drop ; : stack_prompt cr #Tib @ 0= IF clear EXIT THEN ; : mls Only Forth Status off ['] stack_prompt is prompt Only previous Application also ; : NEW_EMP-BUF *BUF-LINK addr BEGIN RAM@ ?DUP WHILE LOCKED? 0= IF DUP [ ' empty-buffer 3 + @ , ] THEN REPEAT UPDATED_BUFS OFF ; : crx?_patch RS232_sema lock RXQUEUE QUEUED RS232_sema unlock ; : (QUIT_patch ECHO OFF cr BEGIN QUERY INTERPRET REPEAT ; $36 FIELD [CYLINDERS] SYS $37 FIELD [HEADS] SYS $38 FIELD [SECTORS] SYS $39 FIELD [ALL_LOW] SYS $3A FIELD [ALL_HGH] SYS $3fff constant #max_cylinders $ff constant #max_heads $3f constant #max_sectors $3ff000 Constant #max_total : IDENTIFY_CARD_NEW #SECTOR_BUF READIDENTIFY IF 4 DISKERROR THEN #SECTOR_BUF DUP [CYLINDERS] WORD@ DUP CYLINDERS ! #max_cylinders U> IF 5 DISKERROR THEN DUP [HEADS] WORD@ DUP HEADS ! #max_heads U> IF 5 DISKERROR THEN DUP [SECTORS] WORD@ DUP SECTORS ! #max_sectors U> IF 5 DISKERROR THEN DUP [ALL_LOW] WORD@ SWAP [ALL_HGH] WORD@ JOIN TOTAL ! TOTAL @ #max_total u> IF #max_total TOTAL ! TOTAL @ SECTORS @ / HEADS @ / CYLINDERS ! SECTORS @ HEADS @ CYLINDERS @ * * TOTAL ! THEN PAR_SEC 5 PARTITION_TYPE ! DUP $10000 U< IF 3 PARTITION_TYPE ! THEN $5000 U< IF 0 PARTITION_TYPE ! THEN FIND_FAT_PARAMETER ; : init #CPU_FAST DEV_CTRL ! DISK_VOLTAGE off key? IF key dup [char] q = over [char] Q = or IF QUIT THEN THEN _gain @ gain! init_release _band @ band! ['] crx?_patch becomes crx? ['] preview_ram_blocks becomes ram_blocks ['] new.errors becomes .errors ['] newerrors? becomes errors? ['] NEW_EMP-BUF becomes empty-buffers ['] IDENTIFY_CARD_NEW BECOMES IDENTIFY_CARD ['] SETPCMCIA 1+ $8831db ! ['] _new BECOMES PCMCIA> #romversion &146 = IF $086901F3 $88307F ! $15298034 $883080 ! THEN reboot_done off [ #max_boot sec ] Literal feed_watchdog my_(watchdog link_watchdog init-buffers #max_int buffers drop ['] quit 'unknown ! init_name dup count 1+ nip token swap cmove init_var link_server set_register init_tasks boot_message _rec_enable @ IF message" (20) resuming recording" THEN mls escape_nv_delay? perform_nv_delay message_queue #blk_size sec/blk ! 0 escape_all @! IF booting_done quit THEN escape_all @ 0= _boot_delay @ and $80 = IF message" (22) trying to restore settings" repair_state THEN seek_curr_block _SyncTime @ 0= 0 card_present? and IF evaluate_sys_file THEN booting_done modcr quit ; : forget-application ." found valid update, erasing old firmware" empty-erom boot ; autoboot init init_nv_var boot