100 ! RE-STORE "WF400 "
102 ! 25 sep 86 Chris Sutton, Thomas Lago
103 ! 10 june 87 Thomas Lago, File Transfer Capabilities
105 !Program to do waterfall plot using HP 3565S.
106 !
108 !This program call subprogram from the 3565S Sample Programs files.
110 !These next lines were executed to load the subprograms:
112 ! LOADSUB ALL FROM "HW"
114 ! LOADSUB ALL FROM "ICODE"
116 ! DELSUB Icode_debug
118 ! LOADSUB FROM "LIB"
120 ! LOADSUB FROM "USER"
122 !
124 DIM Sta$[200] !Will hold HP-IB module's status register response.
126 DIM Id$[40]
128 !some arrays used by the icode assembler:
130 DIM Source$(0:100)[80],Info$(0:100)[40],List$(0:300)[120]
132 INTEGER Object(0:200)
134 !
136 INTEGER I,Amp_pen_num,Big_screen,N
138 COM /Wf/ INTEGER Log_table(0:32766),Spectrum(0:511)
139 COM Center_freq,Span_freq,Input_level
140 COM File_name1$[10]
142 !Some arrays that match HP-IB module blocks:
143 INTEGER Coef(0:4095),Param(0:15)
144 COM INTEGER Freq(0:399)
146 !
147 OUTPUT 2;CHR$(255)&"K"; ! CLEAR SCREEN
148 OUTPUT 2;CHR$(255)&"{"; ! ACTIVATE FUNCTION KEYS
150 Loop=0
151 Center_freq=1620
152 Span_freq=3200
153 Input_level=-50
155 Create_null:!
156 ON KEY 1 LABEL "" GOSUB Dum_dum
157 ON KEY 2 LABEL "RECALL" GOSUB Hamta
158 ON KEY 3 LABEL "STOP" GOSUB Sluta
159 ON KEY 4 LABEL "" GOSUB Dum_dum
160 ON KEY 5 LABEL "CONFIG" GOSUB Create_new
161 ON KEY 6 LABEL "" GOSUB Dum_dum
162 ON KEY 7 LABEL "BDAT -> UBV-FILE" GOSUB Ubv_file
163 ON KEY 8 LABEL "BDAT -> ASCII" GOSUB Data_transfer
164 GOSUB Init
165 ! ON KEY 6 LABEL "SETTINGS" GOSUB Set_frequency
166 IF FNHw_srq THEN GOSUB Handle_error
167 GOSUB Make_icode
168 GOSUB Download_icode
169 GOSUB Start_icode
170 GOSUB Plot_init
171 IF FNHw_srq THEN GOSUB Handle_error
172 T0=TIMEDATE
173 LOOP
174 GOSUB Upload_freq
175 GOSUB Plot_freq
176 IF Stanna THEN GOTO Label1
177 DISP "Spectra per second: ";PROUND(1/(TIMEDATE-T0),-1)
178 T0=TIMEDATE
179 IF FNHw_srq THEN GOSUB Handle_error
180 Label1:!
181 END LOOP
182 !------------------------------------------------------------------------------
183 Set_frequency:! THIS ROUTINE DOESN'T WORK RIGHT NOW !?
187 LINPUT "FREQUENCY SPAN= ? (0 < FREQUENCY SPAN < 51200) (NO CHANGE=RETURN)",Slask$
188 IF Slask$="" THEN GOTO 192
189 IF NOT 0<Slask<51200 THEN GOTO Set_frequency
190 Slask=VAL(Slask$)
191 Span_freq=Slask
192 LINPUT "CENTER FREQUENCY= ? (1/2*FREQUENCY SPAN < CENTER FREQUENCY < 51200-1/2*FREQUENCY SPAN) (NO CHANGE=RETURN)",Slask$
193 IF Slask$="" THEN GOTO 204
194 Slask=VAL(Slask$)
195 IF NOT 1/2*Frequency_span<Slask<51200-1/2*Frequency_span THEN GOTO 192
196 Center_freq=Slask
197 LINPUT "WHAT SENSITIVITY DO YOU WANT ? (-52 < SENSITIVITY < 20 ) (NO CHANGE=RETURN)",Slask$
198 IF Slask$="" THEN GOTO 204
199 Slask=VAL(Slask$)
200 IF NOT -52<Slask<20 THEN GOTO 197
201 Input_level=Slask
202 IF FNHw_srq THEN GOSUB Handle_error
205 CALL Hw_mod_cmd(Input1,"CF "&VAL$(Center_freq))
206 CALL Hw_mod_cmd(Input1,"SP "&VAL$(Span_freq))
208 CALL Hw_mod_cmd(Input1,"RNG "&VAL$(Input_level))
209 IF FNHw_srq THEN GOSUB Handle_error
210 GOSUB Plot_init
212 RETURN
213 !-------------------------------------------------------------------------------
214 Create_new:!
215 ON KEY 1 LABEL "STORE " GOSUB Lagra
216 LINPUT "WHAT SHOULD I CALL THE FILE FOR THE FREQUENCY SPECTRAS ? ",Namn$
217 Name_store$=Namn$
218 LINPUT "HOW MANY SPECTRAS DO YOU WANT TO STORE ?",Antal$
219 Antal=VAL(Antal$)
220 ON ERROR GOSUB Create_failed
221 CREATE BDAT Namn$,Antal*4
222 ASSIGN @File TO Namn$
223 ON ERROR GOSUB Err_routine
224 RETURN
225 !-------------------------------------------------------------------------------
226 Create_failed:!
227 IF ERRN=54 THEN
228 ASSIGN @File TO * ! CLOSE ACTIVE FILE
229 LINPUT "FILE ALREADY EXISTS. OK TO OVERWRITE ? (Y or N)",Slask$
230 IF Slask$="Y" THEN PURGE Namn$
231 IF Slak$="N" THEN
232 LINPUT "WHAT SHOULD I CALL THE NEW FILE FOR THE FREQUENCY SPECTRAS ? ",Namn$
233 LINPUT "HOW MANY SPECTRAS DO YOU WANT TO STORE ?",Antal$
234 Antal=VAL(Antal$)
235 END IF
236 END IF
237 RETURN
238 !------------------------------------------------------------------------------
239 Err_routine:!
240 OFF ERROR
241 DISP ERRN
242 BEEP
243 RETURN
244 !-----------------------------------------------------------------------
245 Ubv_file:!
246 Ubv_flag=1
247 GOSUB Data_transfer
248 RETURN
249 !----------------------------------------------------------------------
250 Dum_dum:!
251 RETURN
252 !-----------------------------------------------------------------------
253 Lagra:!
254 Stanna=0
255 ON KEY 1 LABEL "" GOSUB Dum_dum
256 ON KEY 2 LABEL "" GOSUB Dum_dum
257 Flagga1=1
258 FOR I=1 TO 10
259 WRITEIO 9826,Lago+156;255
260 WAIT .02
261 NEXT I
262 ASSIGN @File TO Namn$;FORMAT OFF
263 OUTPUT @File;Antal
264 RETURN
265 !---------------------------------------------------------------------
266 Hamta:!
267 ON KEY 1 LABEL "" GOSUB Dum_dum
268 ON KEY 2 LABEL "" GOSUB Dum_dum
269 OFF KEY 2
270 Stanna=0
271 Name_store$=Namn$
272 LINPUT "WHAT FILE DO YOU WANT TO RECALL ? (DEFAULT=NORMAL FILE)",Slask$
273 IF Slask$="" THEN GOTO Hamta_2
274 Namn$=Slask$
275 ! OUTPUT 2;CHR$(255)&"K"; ! CLEAR SCREEN
276 ! GOSUB Plot_init
277 Hamta_2:!
278 Flagga2=1
279 FOR I=1 TO 10
280 WRITEIO 9826,Lago+156;255
281 WAIT .02
282 NEXT I
283 ASSIGN @File TO Namn$;FORMAT OFF
284 ENTER @File;Antal
285 ON KEY 4 LABEL "CONTINUE" GOSUB Fortsatt
286 RETURN
287 !-----------------------------------------------------------------------
288 Fortsatt:!
289 Stanna=0
290 Namn$=Name_store$
291 ON KEY 3 LABEL "STOP" GOSUB Sluta
292 ON KEY 4 LABEL "" GOSUB Dum_dum
293 RETURN
294 !-------------------------------------------------------------------------
295 Sluta:!
296 Stanna=1
297 Flagga1=0
298 Flagga2=0
299 ON KEY 3 LABEL "" GOSUB Dum_dum
300 ON KEY 4 LABEL "CONTINUE" GOSUB Fortsatt
301 ASSIGN @File TO *
302 RETURN
303 !-------------------------------------------------------------------------
304 Data_transfer:!
305 OUTPUT 2;CHR$(255)&"K";
306 Stanna=1
307 Xmin=.5*Span_freq-Center_freq
308 Xmax=Center_freq+.5*Span_freq
309 Ymax=Input_level
310 Ymin=Input_level-80
311 LINPUT "WHAT FILE SHOULD I TRANSFER ? (DEFAULT=THE STORED NAME)",File_name$
312 IF File_name$="" THEN
313 File_name$=Namn$
314 File_name1$=Namn$
315 GOTO 320
316 END IF
317 Create_next:!
318 LINPUT "DO YOU WANT ANOTHER FILE NAME ? ('Y' IF YOU WANT TO CHANGE NAME)",Slask$
319 IF Slask$="Y" THEN GOSUB Ny_fil
320 LINPUT "WHAT MAS STORAGE UNIT SPECIFIER DO YOU WANT TO USE ? (DEFAULT=:,1401,1)",Slask$
321 IF Slask$="" THEN Slask$=":,1401,1"
322 Spec$=Slask$
323 Svans$="_A"
324 ASSIGN @File TO File_name$
325 ENTER @File;Antal
326 ASSIGN @File TO *
327 File_size=(12*40+402*25.0*Antal)/256
328 IF Ubv_flag THEN File_size=(12*40+402*50.0*Antal)/256
329 ON ERROR GOTO Create_crash
330 GOTO Create_1
331 Ny_fil:!
332 LINPUT "WHAT DO YOU WANT TO CALL THE NEW FILE ?",File_name1$
333 RETURN
334 !------------------------------------------------------------------------------------
335 Create_crash:!
336 IF ERRN=54 THEN
337 LINPUT "FILE ALREADY EXISTS. OK TO OVERWRITE ? (Y or N)",Slask$
338 IF Slask$="Y" THEN GOTO Create_noll
339 GOTO Create_next
340 END IF
341 Create_noll:!
342 PURGE File_name1$&Svans$&Spec$
343 Create_1:!
344 CREATE ASCII File_name1$&Svans$&Spec$,File_size
345 ON ERROR GOTO Store_crash
346 ASSIGN @File TO File_name1$&Svans$&Spec$
347 ASSIGN @File2 TO File_name$;FORMAT OFF
348 ENTER @File2;Antal ! GET THE NUMBER OF SPECTRAS
349 DISP "STORING DATA IN FILE ";File_name1$&Svans$&Spec$
350 OUTPUT @File;"SPAMHDR("
351 OUTPUT @File;" XUNI:Hz"
352 OUTPUT @File;" YUNI:dB"
353 OUTPUT @File;" XMIN:";Xmin
354 OUTPUT @File;" XMAX:";Xmax
355 OUTPUT @File;" YMIN:";Ymin
356 OUTPUT @File;" YMAX:";Ymax
357 OUTPUT @File;" XLOG:"
358 OUTPUT @File;" YLOG:"
359 OUTPUT @File;" XDMI:"
360 OUTPUT @File;" YDMI:"
361 OUTPUT @File;");"
362 N=400
363 IF Ubv_flag THEN
364 ALLOCATE INTEGER Y(1:N),Y$(1:2*N)[21]
365 ELSE
366 ALLOCATE INTEGER Y(1:N),Y$(1:N)[21]
367 END IF
368 OUTPUT @File;"DATAHDR("
369 OUTPUT @File;" LBL:WATERFALL,"
370 OUTPUT @File;" DATE:"&DATE$(TIMEDATE)&","
371 OUTPUT @File;" OVLD:,"
372 OUTPUT @File;" DATA#ASCI,";Antal;","
373 FOR I=1 TO Antal
374 ENTER @File2;Block_exponent
375 ENTER @File2;Y(*) ! GET THE SPECTRA
376 OUTPUT @File;"SPECTRA ";I
377 OUTPUT @File;Block_exponent
378 IF Ubv_flag THEN
379 FOR J=1 TO N
380 OUTPUT Y$(J*2-1);J
381 OUTPUT Y$(J*2) USING "#,MD.12DESZZZ,A";Y(J),"," !CONVERT THE SPECTRA
382 NEXT J
383 ELSE
384 FOR J=1 TO N
385 OUTPUT Y$(J) USING "#,MD.12DESZZZ,A";Y(J),"," !CONVERT THE SPECTRA
386 NEXT J
387 END IF
388 DISP "I AM TRANSFERING SPECTRA ";I;" RIGHT NOW ! (THERE ARE ";Antal;" SPECTRAS TO MOVE.)"
389 OUTPUT @File;Y$(*) ! OUTPUT THE SPECTRA IN ASCII
390 NEXT I
391 DISP "I AM READY !"
392 OUTPUT @File;");" ! END
393 ASSIGN @File TO * ! CLOSE
394 ASSIGN @File2 TO * ! CLOSE
395 OUTPUT 2;CHR$(255)&"K"; !CLEAR SCREEN
396 GOSUB Plot_init
397 Stanna=0
398 RETURN
399 !--------------------------------------------------------------------------------
400 Store_crash:!
401 BEEP
402 DISP "CRASH !"
403 STOP
404 New_file:!
405 LINPUT "WHAT FILE NAME DO YOU WANT TO USE ?",File_name1$
406 RETURN
407 !--------------------------------------------------------------------------------
408 Init: !----------------------------------------------------------
409 !This subprogram initializes the 3565S system and software.
410 CALL Hw_hw !to initialize subprograms.
411 CALL Lib_lib
412 CALL Icode_icode
413 !
414 !Initialize LOG look-up table if needed.
415 IF Log_table(3000)=0 THEN CALL Init_log_table(Log_table(*))
416 !
417 CALL Hw_set_dev_sel(711) !set the 35651A HP-IB address
418 Using_source=0 !flag. 1= use source 0=don't
419 Source1=1 !slot number for source.
420 Input1=2 !change in Icode too !slot number for input.
421 !
422 DISP "Initializing HP3565S hardware"
423 CALL Hw_cmd("ABRT; DISA",10) !initialize HP-IB module.
424 IF FNHw_io_error THEN CALL User_stop("HP-IB timeout. 3565S not responding.")
425 !Program HP-IB module to pull SRQ on messages, errors, and IRQs.
426 CALL Hw_cmd("RQS "&VAL$(FNHw_str_2_stat("IRQ,ERR")))
427 !
428 !Read status register to clear power-on SRQ and check for errors.
429 Sta$=FNHw_stat_2_str$(VAL(FNHw_cmd_rsp$("STA?")))
430 IF POS(Sta$,"ERR") OR POS(Sta$,"IRQ") THEN GOSUB Handle_error
431 !
432 !Program source1 to output a sine wave
433 IF Using_source THEN
434 Id$=FNHw_mod_cmd_rsp$(Source1,"ID?",5)
435 IF FNHw_io_error OR (Id$<>"HP35653A") THEN CALL User_stop("35653A not responding.")
436 CALL Hw_mod_cmd(Source1,"RST") !Reset the source module.
437 CALL Hw_mod_cmd(Source1,"INTR 32") !Pull IRQ on errors.
438 CALL Hw_mod_cmd(Source1,"OPTM CRND; AM -18")!-20dBVp noise.
439 CALL Hw_mod_cmd(Source1,"ZOOM ON")
440 CALL Hw_mod_cmd(Source1,"SP 200") !200 Hz Span
441 Noise_freq=100
442 CALL Hw_mod_cmd(Source1,"CF "&VAL$(Noise_freq)) !1KHz
443 CALL Hw_mod_cmd(Source1,"STRT") !start the source
444 END IF
445 Id$=FNHw_mod_cmd_rsp$(Input1,"ID?",5)
446 IF FNHw_io_error OR (Id$<>"HP35652A") THEN CALL User_stop("35652A not responding.")
447 CALL Hw_mod_cmd(Input1,"RST",10) !Reset the input module
448 CALL Hw_mod_cmd(Input1,"ZOOM ON") !Zoom for FFT
449 CALL Hw_mod_cmd(Input1,"CF "&VAL$(Center_freq))
450 CALL Hw_mod_cmd(Input1,"SP "&VAL$(Span_freq))
451 IF Using_source THEN
452 CALL Hw_mod_cmd(Input1,"RNG -30")
453 ELSE
454 CALL Hw_mod_cmd(Input1,"RNG "&VAL$(Input_level))
455 END IF
456 DISP
457 RETURN
458 !
459 Handle_error: !--------------------------------------------------
460 Sta$=FNHw_stat_2_str$(VAL(FNHw_cmd_rsp$("STA?")))
461 PRINT "HP-IB module status: ";Sta$
462 PRINT "HP-IB module errors: "
463 PRINT FNHw_get_errstr$(VAL(FNHw_cmd_rsp$("err?")))
464 PRINT FNHw_get_errstr$(VAL(FNHw_cmd_rsp$("err?")))
465 PRINT "Input module errors:"
466 PRINT FNHw_mod_cmd_rsp$(Input1,"ERR?",5)
467 PRINT FNHw_mod_cmd_rsp$(Input1,"ERR?",5)
468 IF Using_source THEN
469 PRINT "Source module errors:"
470 PRINT FNHw_mod_cmd_rsp$(Source1,"ERR?",5)
471 PRINT FNHw_mod_cmd_rsp$(Source1,"ERR?",5)
472 END IF
473 CALL User_stop("3565S harware has errors. Press Continue.")
474 RETURN
475 !
476 Make_icode: !--------------------------------------------------
477 !This Icode program is an infinite loop that does FFTs from
478 !one input module and leaves the spectrum in Freq block.
479 !Each time a Freq block is ready, this program sends a signal
480 !to the host and then pauses. The host should read the block
481 !and then continue the Icode program.
482 !
483 Icode_program: !
484 !first define the names of the memory blocks.
485 DATA "DEFBLK_SP Coef 4096,2 !Coefficient table for FFT"
486 DATA "DEFBLK_SP Param 128,2 !FFT parameter block"
487 DATA "DEFBLK_SP Window 1024,2 !Window"
488 DATA "DEFBLK_SP Time 1024,2 !Time record from input module"
489 DATA "DEFBLK_SP Fftout 1024,2 !FFT output (32-bit)"
490 DATA "DEFBLK_MAIN Ftemp 512,2 !FFT output (16 bit)"
491 DATA "DEFBLK_MAIN Freq 800,2 !FFT output (16 bit), 800 lines."
492 DATA "DEFBLK_MAIN Block1 2048,2 !512 floating pt."
493 DATA "DEFBLK_MAIN Block2 512,2 !512 short integers."
494 !
495 DATA "CONST Input1 2 !Address of input module."
496 DATA "VAR Zero 0 !Really a constant."
497 DATA "VAR Freq_exp 0 !Block exponent of fft_out block."
498 !
499 DATA "!-------------------------------------------------------------"
500 DATA " C_GOSUB Init !Initialize modules and thruput"
501 !
502 DATA " C_GOSUB Start_fft !Read data from input and start FFT"
503 DATA "Loop: "
504 DATA " C_GOSUB Finish_fft"
505 DATA " C_GOSUB Start_fft !start next one while send-ing last"
506 DATA " F_WAIT_TO_SIG Freq_exp !Tell host data is ready"
507 DATA " C_GOTO Loop !loop forever"
508 DATA " C_END"
509 !
510 DATA "!-------------------------------------------------------------"
511 DATA "Start_fft: !subprogram to read in data and start FFT"
512 DATA " F_THRUPUT 1,0 !read input1->Time"
513 DATA " V_PUT32_INDEXED Param,0,Zero !init block exponent."
514 DATA " F_SIG_PROC 4032,0,5,Param,0,Coef,0,Window,0,Time,0,Fftout,0"
515 DATA " C_RTS"
516 DATA "!------------------------------------------------------------"
517 DATA "Finish_fft:" !subprogram to do post-fft stuff"
518 DATA "Wloop: C_SP_BEQ Wloop,2 !wait for FFT done"
519 DATA " V_GET32_INDEXED Param,0,Freq_exp !get block exponent."
520 DATA " V_PUT32_INDEXED ^Fftout,0,Freq_exp !put block exponent."
521 DATA " F_INT_TO_SHORT Fftout,0,Ftemp,0,512"
522 DATA " V_GET32_INDEXED ^Ftemp,0,Freq_exp !get block exponent."
523 DATA " !these 2 moves delete the guard band and swap spectrum"
524 DATA " F_MOVE_BLOCK Ftemp, 0,Freq,200,200 !block swap "
525 DATA " F_MOVE_BLOCK Ftemp,312,Freq, 0,200 !block swap "
526 DATA " C_RTS"
527 DATA "!------------------------------------------------------------"
528 DATA "Init: !subprogram to initialize modules and thruput"
529 DATA " F_EXEC 2"
530 DATA " F_MOD_COMMAND Input1,'INTR 32' !Pull IRQ on errors."
531 DATA " F_MOD_COMMAND Input1,'RQS 2048' !Pull SRQ when block ava."
532 DATA " F_MOD_COMMAND Input1,'STRT' !Start the input module"
533 DATA " F_READY_RAM 0,Time,0,1024,1,1,Input1 !setup thruput"
534 DATA " F_KEEP_READY_RAM"
535 DATA " F_FLOAT_WINGEN Block1, 0, 512, 2, 0.499984, -.499984"
536 DATA " F_FLOAT_TO_SHORT Block1, 0, Block2, 0, 512"
537 DATA " F_SHORT_INTRLVE Block2, 0, Block2, 0, Window, 0, 512"
538 DATA " C_RTS"
539 !
540 DATA "EL_COMPLETO"
541 !--------------------------------------------------------------------
542 !
543 !These lines read the above DATA statments into Source$(*) and
544 !call the Icode assembler to get Object(*)
545 RESTORE Icode_program
546 Source_ptr=-1
547 REPEAT
548 Source_ptr=Source_ptr+1
549 READ Source$(Source_ptr)
550 UNTIL POS(UPC$(Source$(Source_ptr)),"EL_COMPLETO")
551 Error_count=FNIcode_assemble(Source$(*),Object(*),1,Info$(*),1,List$(*))
552 IF Error_count<>0 THEN
553 DISP "Errors during assemble. Program paused"
554 PAUSE
555 END IF
556 RETURN
557 !
558 Download_icode: !-----------------------------------------------------
559 !Now download the Icode program (and allocate blocks)
560 Icode_id=FNIcode_dld(Object(*),1,Info$(*))
561 IF Icode_id<=0 THEN CALL User_stop("Icode download failed.")
562 !
563 !The FFT parameter block must be filled in with initial values.
564 Param(0)=0 !dest_exp MSW
565 Param(1)=0 !dest_exp LSW
566 Param(2)=9 !blk_size_exp: 2^9th for 512pt complex time record
567 Param(3)=0 !overflow_flag
568 Param(4)=0 !swap_flag
569 Param(5)=1 !window_flag
570 Param(6)=2 !IFFT_flag: 2^1=do mag_sq
571 !
572 !Download the FFT parameter block
573 Param_id=FNIcode_ext_id("Param",Info$(*)) !get block id from icode
574 CALL Hw_write_blk(Param_id,Param(*))
575 IF FNHw_io_error THEN CALL User_stop("Param block download failed.")
576 !
577 !Generate and download cosine table used by FFT
578 CALL Lib_fft_coefs(Coef(*)) !generate table
579 Coef_id=FNIcode_ext_id("Coef",Info$(*)) !get block id from icode
580 CALL Hw_write_blk(Coef_id,Coef(*)) !download
581 !
582 Freq_id=FNIcode_ext_id("Freq",Info$(*)) !get block id from icode
583 RETURN
584 !
585 Start_icode: !--------------------------------------------------
586 CALL Hw_cmd("PROG "&VAL$(Icode_id)) !Start ICODE program
587 RETURN
588 !
589 Upload_freq: !------------------------------------------------
590 !This subroutine waits until the I-code program has a new Freq(*)
591 !block to be uploaded.
592 !
593 IF Stanna THEN RETURN
594 IF Flagga2 THEN GOTO Upload_2
595 Blk_exponent=VAL(FNHw_cmd_rsp$("WSG?")) !block_expoent is
596 !sent back as the signal.
597 CALL Hw_read_blk(Freq_id,Freq(*)) !Upload
598 IF FNHw_io_error THEN CALL User_stop("Freq block upload failed.")
599 IF MIN(Freq(*))<0 THEN CALL User_stop("Error: negative numbers in magnitude squared data from 3565S")
600 IF Flagga1 THEN
601 OUTPUT @File;Block_exponent
602 OUTPUT @File;Freq(*)
603 Loop=Loop+1
604 IF Loop=Antal THEN
605 DISP "I AM READY WITH ";Antal;" FREQUENCY SPECTRAS"
606 WAIT .5
607 Flagga1=0
608 ASSIGN @File TO *
609 Loop=0
610 FOR I=1 TO 10
611 WRITEIO 9826,Lago+156;255
612 WAIT .02
613 NEXT I
614 ON KEY 1 LABEL "STORE" GOSUB Lagra
615 ON KEY 2 LABEL "RECALL" GOSUB Hamta
616 END IF
617 END IF
618 Upload_2:!
619 IF Flagga2 THEN
620 ENTER @File;Block_exponent
621 ENTER @File;Freq(*)
622 Loop=Loop+1
623 IF Loop=Antal THEN
624 DISP "I AM READY WITH ";Antal;" FREQUENCY SPECTRAS"
625 Stanna=1
626 Flagga2=0
627 ASSIGN @File TO *
628 Loop=0
629 FOR I=1 TO 10
630 WRITEIO 9826,Lago+156;255
631 WAIT .02
632 NEXT I
633 ON KEY 1 LABEL "STORE" GOSUB Lagra
634 ON KEY 2 LABEL "RECALL" GOSUB Hamta
635 END IF
636 END IF
637 IF Using_source THEN
638 Noise_freq=Noise_freq+300 !increment Source frequency
639 IF Noise_freq>5000 THEN Noise_freq=100
640 CALL Hw_mod_cmd(Source1,"CF "&VAL$(Noise_freq)) !send freq to source
641 END IF
642 RETURN
643 !
644 Plot_init: !-------------------------------------------------
645 GINIT
646 PLOTTER IS CRT,"INTERNAL";COLOR MAP
647 SET PEN 1 INTENSITY 1,1,1
648 SET PEN 2 INTENSITY .3,.3,.9
649 SET PEN 3 INTENSITY .3,.5,.8
650 SET PEN 4 INTENSITY .3,.7,.7
651 SET PEN 5 INTENSITY .4,.7,.6
652 SET PEN 6 INTENSITY .4,.8,.4
653 SET PEN 7 INTENSITY .6,.6,.3
654 SET PEN 8 INTENSITY .7,.5,.2
655 SET PEN 9 INTENSITY .8,.6,.2
656 SET PEN 10 INTENSITY .9,.5,.1
657 SET PEN 11 INTENSITY .9,.4,.1
658 SET PEN 12 INTENSITY 1,.3,0
659 GCLEAR
660 G_base=2097152 !start of graphics memory
661 IF NOT POS(SYSTEM$("CRT ID"),"CGB") THEN CALL User_stop("Incompatible display type.")
662 IF POS(SYSTEM$("CRT ID"),"128") THEN
663 Big_screen=1
664 ELSE
665 Big_screen=0
666 END IF
667 IF Big_screen THEN
668 Start_addr=G_base+1024*568.0+150 !start 568 pixels down, 150 over
669 WINDOW 0,1024,-768,0 !same as pixels
670 PEN 1
671 CSIZE 100.0*30/767
672 MOVE 150,-580
673 LORG 3
674 LABEL "\ "&VAL$(Center_freq-Span_freq/2)
675 MOVE 150+400,-580
676 LORG 9
677 LABEL VAL$(Center_freq+Span_freq/2)&" Hz /"
678 ELSE
679 Start_addr=G_base+1024*278.0+150
680 WINDOW 0,1024,-400,0
681 PEN 1
682 CSIZE 100*15/399
683 MOVE 150,-285
684 LORG 3
685 LABEL "\ "&VAL$(Center_freq-Span_freq/2)
686 MOVE 150+400,-285
687 LORG 9
688 LABEL VAL$(Center_freq+Span_freq/2)&" Hz /"
689 END IF
690 WAIT .1
691 CALL Init_scroll(Lago)
692 RETURN
693 Plot_freq: !--------------------------------------------------
694 IF Stanna THEN RETURN
695 CALL Look_up(400,Log_table(*),Freq(*),Spectrum(*))
696 Amp_pen_num=MAX(2,MIN(12,Blk_exponent+17))
697 !
698 !use one of the next two lines:
699 ! CALL Mwrite(Start_addr,1,-1024,Amp_pen_num,399,Spectrum(*)) !solidcolor
700 CALL Mwrite(Start_addr,2,-1024,2,399,Spectrum(*)) !rainbow
701 !
702 CALL Mwrite(Start_addr,0,-1024,1,399,Spectrum(*)) !border
703 IF (Time_counter>5) AND (TIMEDATE-Last_time>5) THEN
704 IF Big_screen THEN
705 PRINT TABXY(3,35);
706 ELSE
707 PRINT TABXY(1,16);
708 END IF
709 PRINT TIME$(TIMEDATE)
710 Time_counter=0
711 Last_time=INT(TIMEDATE)
712 ELSE
713 Time_counter=Time_counter+1
714 END IF
715 WRITEIO 9826,Lago+156;255 !Scroll th display
716 RETURN
717 END
718 !-----------------------------------------------------------------
719 Init_log_table:SUB Init_log_table(INTEGER Log_table(*))
720 INTEGER I,Max_pen,Max_i
721 DISP "Initializing log table"
722 Max_amp=31
723 Min_amp=3
724 Max_i=7000
725 MAT Log_table= (Max_amp)
726 Log_table(0)=Min_amp
727 Fudge_factor=(Max_amp-Min_amp-1)/LGT(Max_i)
728 FOR I=1 TO Max_i
729 Log_table(I)=1+LGT(I)*Fudge_factor+Min_amp
730 NEXT I
731 DISP
732 SUBEND
733 !-----------------------------------------------------------------
734 SUB Init_scroll(Lago)
735 Lago=5652480
736 ! SOURCE
737 Xs=5
738 Ys=4
739 ! DESTINATION
740 Xd=9
741 Yd=3
742 ! WIDTH OF THE SCREEN TO BE MOVED
743 Bredd=1000
744 ! HEIGHT OF THE SCREEN TO BE MOVED
745 IF POS(SYSTEM$("CRT ID"),"128") THEN
746 Hojd=570
747 Xd=6
748 ELSE
749 Hojd=280
750 END IF
751 ! REPLACEMENT RULE
752 WRITEIO 9826,Lago+238;3
753 WRITEIO 9826,Lago+136;255
754 ! SOURCE COORDINATES
755 WRITEIO -9826,Lago+242;Xs
756 WRITEIO -9826,Lago+246;Ys
757 ! DESTINATION COORDINATES
758 WRITEIO -9826,Lago+250;Xd
759 WRITEIO -9826,Lago+254;Yd
760 ! WIDTH
761 WRITEIO -9826,Lago+258;Bredd
762 ! HEIGHT
763 WRITEIO -9826,Lago+262;Hojd
764 !
765 SUBEND
766 CSUB Mwrite(Start_addr,INTEGER Fill_mode,Offset,Pen_num,Num_pts,D_array(*))
767 CSUB Look_up(INTEGER Num_pts,Table(*),Inn(*),Out(*))
768 Hw_hw:SUB Hw_hw
769 !
770 ! This subprogram is used to initialize the HP3565S demo programs
771 ! hardware interface file. Note that Hw_hw does not initialize the
772 ! device selector address of the HP3565S hardware.
773 !
774 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
775 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
776 Io_error=0
777 Hpib_addr=0
778 Sel_code=7
779 ASSIGN @Hpib_mod TO 700
780 ASSIGN @Bin_hpib_mod TO 700;FORMAT OFF
781 SUBEND
782 !
783 Hw_cmd:SUB Hw_cmd(Op_string$,OPTIONAL Timeout_time)
784 !
785 ! This subprogram is used to send a command string to the HP-IB
786 ! module. The command string sent is specified by <Op_string$>.
787 ! <Timeout_time> is an optional timeout parameter in seconds.
788 !
789 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
790 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
791 Io_error=0
792 ON ERROR GOTO Hw_io_error
793 IF NPAR=2 THEN
794 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
795 END IF
796 OUTPUT @Hpib_mod;Op_string$
797 IF 0 THEN
798 Hw_io_error:Io_error=1
799 END IF
800 SUBEND
801 !
802 Hw_rsp:DEF FNHw_rsp$(OPTIONAL Timeout_time)
803 !
804 ! This function is used to read a response from HP-IB module. This
805 ! function returns the response to the caller in the function result
806 ! string. <Timeout_time> is an optional timeout parameter in
807 ! seconds.
808 !
809 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
810 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
811 DIM Temp$[255]
812 Io_error=0
813 ON ERROR GOTO Hw_io_error
814 IF NPAR=1 THEN
815 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
816 END IF
817 ENTER @Hpib_mod;Temp$
818 IF 0 THEN
819 Hw_io_error:!
820 Io_error=1
821 Temp$=""
822 END IF
823 RETURN Temp$
824 FNEND
825 !
826 Hw_cmd_rsp:DEF FNHw_cmd_rsp$(Op_string$,OPTIONAL Timeout_time)
827 !
828 ! This function is used to send a command string to the HP-IB module
829 ! and read a response string back from then HP-IB module. First the
830 ! command string, specified by <Op_string$>, is sent to the HP-IB
831 ! module. Then a response is read back from then HP-IB module.
832 ! This function returns the response to the caller in the function
833 ! result string. <Timeout_time> is an optional timeout parameter in
834 ! seconds.
835 !
836 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
837 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
838 DIM Temp$[255]
839 Io_error=0
840 ON ERROR GOTO Hw_io_error
841 IF NPAR=2 THEN
842 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
843 END IF
844 OUTPUT @Hpib_mod;Op_string$
845 ENTER @Hpib_mod;Temp$
846 IF 0 THEN
847 Hw_io_error:!
848 Io_error=1
849 Temp$=""
850 END IF
851 RETURN Temp$
852 FNEND
853 !
854 Hw_mod_cmd:SUB Hw_mod_cmd(Mf_mod,Op_string$,OPTIONAL Timeout_time)
855 !
856 ! This function is used to send a command string to an input module
857 ! or an source module. The module address is specified by <mf_mod>.
858 ! The command string to be sent is specified by <op_string$>.
859 ! <Timeout_time> is an optional timeout parameter in seconds.
860 !
861 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
862 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
863 Io_error=0
864 ON ERROR GOTO Hw_io_error
865 IF NPAR=3 THEN
866 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
867 END IF
868 OUTPUT @Hpib_mod;"WCM ";Mf_mod;",'";Op_string$;"'"
869 IF 0 THEN
870 Hw_io_error: !
871 Io_error=1
872 END IF
873 SUBEND
874 !
875 Hw_mod_rsp:DEF FNHw_mod_rsp$(Mf_mod,OPTIONAL Timeout_time)
876 !
877 ! This function is used to read a response string from an input
878 ! module or an source module. The module is specified by <mf_mod>.
879 ! The response is returned to the caller in the function result
880 ! string. <Timeout_time> is an optional timeout parameter in
881 ! seconds.
882 !
883 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
884 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
885 DIM Temp$[255]
886 Io_error=0
887 ON ERROR GOTO Hw_io_error
888 IF NPAR=2 THEN
889 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
890 END IF
891 OUTPUT @Hpib_mod;"RRSP ";Mf_mod
892 ENTER @Hpib_mod;Temp$
893 IF 0 THEN
894 Hw_io_error: !
895 Io_error=1
896 Temp$=""
897 END IF
898 RETURN Temp$
899 FNEND
900 !
901 Hw_mod_cmd_rsp:DEF FNHw_mod_cmd_rsp$(Mf_mod,Op_string$,OPTIONAL Timeout_time)
902 !
903 ! This function is used to send a command string to an input module
904 ! or an source module, and read a string response back from the
905 ! specified module. The module address is specified by <mf_mod>.
906 ! First, the specified module is sent the command string
907 ! <op_string$>. Then, the response string is read from the
908 ! specified module and returned to the host in the function result
909 ! string. <Timeout_time> is an optional timeout parameter in
910 ! seconds.
911 !
912 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
913 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
914 DIM Temp$[255]
915 Io_error=0
916 ON ERROR GOTO Hw_io_error
917 IF NPAR=3 THEN
918 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
919 END IF
920 OUTPUT @Hpib_mod;"WCM ";Mf_mod;",'";Op_string$;"'"
921 OUTPUT @Hpib_mod;"RRSP ";Mf_mod
922 ENTER @Hpib_mod;Temp$
923 IF 0 THEN
924 Hw_io_error: !
925 Io_error=1
926 Temp$=""
927 END IF
928 RETURN Temp$
929 FNEND
930 !
931 Hw_gbl_cmd:SUB Hw_gbl_cmd(Class,Op_string$,OPTIONAL Timeout_time)
932 !
933 ! This subprogram is used to send a global class command string to
934 ! all modules in a specified class. All modules in the fast bus
935 ! class specified by <class> will be sent the command string
936 ! <op_string$>. For information on global classes, see HP3565S
937 ! module documentation. <Timeout_time> is an optional timeout
938 ! parameter in seconds.
939 !
940 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
941 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
942 Io_error=0
943 ON ERROR GOTO Hw_io_error
944 IF NPAR=3 THEN
945 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
946 END IF
947 OUTPUT @Hpib_mod;"WGCM ";Class;",'";Op_string$;"'"
948 IF 0 THEN
949 Hw_io_error: !
950 Io_error=1
951 END IF
952 SUBEND
953 !
954 Hw_write_blk:SUB Hw_write_blk(Block_id,INTEGER Block_array(*),OPTIONAL Timeout_time)
955 !
956 ! This function is used to write a short integer data array into a
957 ! HP-IB module data RAM block. All short integer data in the array
958 ! <block_array(*)> will be downloaded into the HP-IB module data RAM
959 ! block specified by <block_id>. <Timeout_time> is an optional
960 ! timeout parameter in seconds.
961 !
962 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
963 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
964 Io_error=0
965 ON ERROR GOTO Hw_io_error
966 IF NPAR=3 THEN
967 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
968 END IF
969 Block_size=FNLib_sizeof(Block_array(*))
970 OUTPUT @Hpib_mod USING "#,K";"WBLD ";Block_id;",";Block_size;",#I"
971 OUTPUT @Bin_hpib_mod;Block_array(*)
972 IF 0 THEN
973 Hw_io_error: !
974 Io_error=1
975 END IF
976 SUBEND
977 !
978 Hw_read_blk:SUB Hw_read_blk(Block_id,INTEGER Block_array(*),OPTIONAL Timeout_time)
979 !
980 ! This subprogram is used to read a short integer data block from a
981 ! HP-IB module data RAM block. Short integer data will be read from
982 ! the data RAM block specified by <block_id> until the short integer
983 ! array <block_array(*)> is full. <Timeout_time> is an optional
984 ! timeout parameter in seconds.
985 !
986 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
987 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
988 INTEGER Pound_i
989 REAL Block_size
990 Io_error=0
991 ON ERROR GOTO Hw_io_error
992 IF NPAR=3 THEN
993 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
994 END IF
995 Block_size=FNLib_sizeof(Block_array(*))
996 OUTPUT @Hpib_mod;"RBLD ";Block_id;",";Block_size
997 ENTER @Hpib_mod USING "#,W";Pound_i
998 IF Pound_i<>9033 THEN
999 Io_error=1
1000 OUTPUT @Hpib_mod;" "
1001 ELSE
1002 ENTER @Bin_hpib_mod;Block_array(*)
1003 END IF
1004 IF 0 THEN
1005 Hw_io_error:!
1006 Io_error=1
1007 END IF
1008 SUBEND
1009 !
1010 Hw_enter_blk:SUB Hw_enter_blk(INTEGER Block_array(*),OPTIONAL Timeout_time)
1011!
1012! This subprogram is used to read a short integer data array from a
1013! running ICODE program. See HP-IB module documentation for
1014! information on how ICODE can send data to the host. This
1015! subprogram uses the HP-IB module RBLK HP-IB command. After
1016! sending the RBLK command, data is read from HP-IB and put into the
1017! short integer array <block_array(*)>. Data is read until
1018! <Block_array(*)> is full. <Timeout_time> is an optional timeout
1019! parameter in seconds.
1020!
1021 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1022 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1023 INTEGER Pound_i
1024 Io_error=0
1025 ON ERROR GOTO Hw_io_error
1026 IF NPAR=2 THEN
1027 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1028 END IF
1029 OUTPUT @Hpib_mod;"RBLK"
1030 ENTER @Hpib_mod USING "#,W";Pound_i
1031 IF Pound_i<>9033 THEN
1032 Io_error=1
1033 OUTPUT @Hpib_mod;" "
1034 ELSE
1035 ENTER @Bin_hpib_mod;Block_array(*)
1036 END IF
1037 IF 0 THEN
1038 Hw_io_error:!
1039 Io_error=1
1040 END IF
1041 SUBEND
1042 !
1043 Hw_output_blk:SUB Hw_output_blk(INTEGER Block_array(*),OPTIONAL Timeout_time)
1044!
1045! This subprogram is used to send a short integer data array to a
1046! running ICODE program. For information on ICODE and how ICODE can
1047! accept a block of data, see HP-IB module documentation. This
1048! subprogram uses the HP-IB module WBLK HP-IB command. After
1049! issuing the WBLK command, the data in the short integer array
1050! <block_array(*)> is sent to HP-IB module. <Timeout_time> is an
1051! optional timeout parameter in seconds.
1052!
1053 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1054 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1055 INTEGER Pound_i
1056 Io_error=0
1057 ON ERROR GOTO Hw_io_error
1058 IF NPAR=2 THEN
1059 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1060 END IF
1061 OUTPUT @Hpib_mod USING "#,K";"WBLK #I"
1062 OUTPUT @Bin_hpib_mod;Block_array(*)
1063 IF 0 THEN
1064 Hw_io_error:!
1065 Io_error=1
1066 END IF
1067 SUBEND
1068 !
1069 Hw_read_mod_blk:SUB Hw_read_mod_blk(Mf_mod,INTEGER Block_array(*),OPTIONAL Timeout_time)
1070 !
1071 ! This subprogram is used to read a short integer data block from an
1072 ! input module. This subprogram uses the HP-IB module RDT command.
1073 ! Data is read from the module specified by <mf_mod> and placed in
1074 ! <Block_array(*)>. Data is read until <Block_array(*)> is full.
1075 ! <Timeout_time> is an optional timeout parameter in seconds.
1076 !
1077 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1078 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1079 INTEGER Pound_i
1080 REAL Block_size
1081 Io_error=0
1082 ON ERROR GOTO Hw_io_error
1083 IF NPAR=3 THEN
1084 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1085 END IF
1086 Block_size=FNLib_sizeof(Block_array(*))
1087 OUTPUT @Hpib_mod;"RDT ";Mf_mod;",";Block_size
1088 ENTER @Hpib_mod USING "#,W";Pound_i
1089 IF Pound_i<>9033 THEN
1090 Io_error=1
1091 OUTPUT @Hpib_mod;" "
1092 ELSE
1093 ENTER @Bin_hpib_mod;Block_array(*)
1094 END IF
1095 IF 0 THEN
1096 Hw_io_error:!
1097 Io_error=1
1098 END IF
1099 SUBEND
1100 !
1101 Hw_write_fblk:SUB Hw_write_fblk(Block_id,Block_array(*),OPTIONAL Timeout_time)
1102 !
1103 ! This function is used to write a floating point data array into a
1104 ! HP-IB module data RAM block. All floating point data in the array
1105 ! <block_array(*)> will be downloaded into the HP-IB module data RAM
1106 ! block specified by <block_id>. <Timeout_time> is an optional
1107 ! timeout parameter in seconds.
1108 !
1109 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1110 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1111 Io_error=0
1112 ON ERROR GOTO Hw_io_error
1113 IF NPAR=3 THEN
1114 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1115 END IF
1116 Block_size=FNLib_fsizeof(Block_array(*))*4
1117 OUTPUT @Hpib_mod USING "#,K";"WBLD ";Block_id;",";Block_size;",#I"
1118 OUTPUT @Bin_hpib_mod;Block_array(*)
1119 IF 0 THEN
1120 Hw_io_error:!
1121 Io_error=1
1122 END IF
1123 SUBEND
1124 Hw_read_fblk:SUB Hw_read_fblk(Block_id,Block_array(*),OPTIONAL Timeout_time)
1125 !
1126 ! This subprogram is used to read a floating point data block from a
1127 ! HP-IB module data RAM block. Floating point data will be read
1128 ! from the data RAM block specified by <block_id> until the floating
1129 ! point array <block_array(*)> is full. <Timeout_time> is an
1130 ! optional timeout parameter in seconds.
1131 !
1132 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1133 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1134 INTEGER Pound_i,I
1135 REAL Block_size
1136 Io_error=0
1137 ON ERROR GOTO Hw_io_error
1138 IF NPAR=3 THEN
1139 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1140 END IF
1141 Block_size=FNLib_fsizeof(Block_array(*))*4
1142 OUTPUT @Hpib_mod;"RBLD ";Block_id;",";Block_size
1143 ENTER @Hpib_mod USING "#,W";Pound_i
1144 IF Pound_i<>9033 THEN
1145 Io_error=1
1146 OUTPUT @Hpib_mod;" "
1147 ELSE
1148 ENTER @Bin_hpib_mod;Block_array(*)
1149 END IF
1150 IF 0 THEN
1151 Hw_io_error:!
1152 Io_error=1
1153 END IF
1154 SUBEND
1155 !
1156 Hw_enter_fblk:SUB Hw_enter_fblk(Block_array(*),OPTIONAL Timeout_time)
1157!
1158! This subprogram is used to read a floating point data array from a
1159! running ICODE program. See HP-IB module documentation for
1160! information on how ICODE can send data to the host. This
1161! subprogram uses the HP-IB module RBLK HP-IB command. After
1162! sending the RBLK command, data is read from HP-IB and put into the
1163! floating point array <Block_array(*)>. Data is read until
1164! <block_array(*)> is full. <Timeout_time> is an optional timeout
1165! parameter in seconds.
1166!
1167 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1168 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1169 INTEGER Pound_i
1170 Io_error=0
1171 ON ERROR GOTO Hw_io_error
1172 IF NPAR=2 THEN
1173 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1174 END IF
1175 OUTPUT @Hpib_mod;"RBLK"
1176 ENTER @Hpib_mod USING "#,W";Pound_i
1177 IF Pound_i<>9033 THEN
1178 Io_error=1
1179 OUTPUT @Hpib_mod;" "
1180 ELSE
1181 ENTER @Bin_hpib_mod;Block_array(*)
1182 END IF
1183 IF 0 THEN
1184 Hw_io_error:!
1185 Io_error=1
1186 END IF
1187 SUBEND
1188 !
1189 Hw_output_fblk:SUB Hw_output_fblk(Block_array(*),OPTIONAL Timeout_time)
1190!
1191! This subprogram is used to send a floating point data array to a
1192! running ICODE program. For information on ICODE and how ICODE can
1193! accept a block of data, see HP-IB module documentation. This
1194! subprogram uses the HP-IB module WBLK HP-IB command. After
1195! issuing the WBLK command, the data in the floating point array
1196! <block_array(*)> is sent to HP-IB module. <Timeout_time> is an
1197! optional timeout parameter in seconds.
1198!
1199 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1200 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1201 INTEGER Pound_i
1202 Io_error=0
1203 ON ERROR GOTO Hw_io_error
1204 IF NPAR=2 THEN
1205 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1206 END IF
1207 OUTPUT @Hpib_mod USING "#,K";"WBLK #I"
1208 OUTPUT @Bin_hpib_mod;Block_array(*)
1209 IF 0 THEN
1210 Hw_io_error:!
1211 Io_error=1
1212 END IF
1213 SUBEND
1214 !
1215 Hw_wait_mod_rdy:SUB Hw_wait_mod_rdy(Mf_mod,OPTIONAL Timeout_time)
1216!
1217! This subprogram is used to hold off execution of the host program
1218! until a specified HP3565S input module or source module is ready.
1219! When the HP3565S module specified by <mf_mod> has its ready bit
1220! asserted, this subprogram will terminate, returning host processor
1221! control to the caller. <Timeout_time> is an optional timeout
1222! parameter in seconds.
1223!
1224 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1225 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1226 INTEGER Status,Timeout_active
1227 REAL Start_time
1228 Io_error=0
1229 ON ERROR GOTO Hw_io_error
1230 Timeout_active=0
1231 IF NPAR=2 THEN
1232 IF Timeout_time>0 THEN Timeout_active=1
1233 END IF
1234 IF Timeout_active THEN
1235 ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1236 Start_time=TIMEDATE
1237 REPEAT
1238 OUTPUT @Hpib_mod;"RMST ";Mf_mod
1239 ENTER @Hpib_mod;Status
1240 IF BIT(Status,4) THEN SUBEXIT
1241 UNTIL ABS(TIMEDATE-Start_time)>Timeout_time
1242 ELSE
1243 REPEAT
1244 OUTPUT @Hpib_mod;"RMST ";Mf_mod
1245 ENTER @Hpib_mod;Status
1246 IF BIT(Status,4) THEN SUBEXIT
1247 UNTIL 1=0
1248 SUBEXIT
1249 END IF
1250 Hw_io_error:Io_error=1
1251 SUBEND
1252 !
1253 Hw_wait_gbl_rdy:SUB Hw_wait_gbl_rdy(OPTIONAL Timeout_time)
1254!
1255! This subprogram is used to hold off execution of the host program
1256! until all HP3565S input modules and source modules are ready.
1257! When all HP3565S modules (except the HP-IB module) have asserted
1258! their ready bits, this subprogram will terminate, returning host
1259! processor control to the caller. This subprogram uses the HP-IB
1260! module RGSS command. <Timeout_time> is an optional timeout
1261! parameter in seconds.
1262!
1263 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1264 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1265 INTEGER Status,Timeout_active
1266 REAL Start_time
1267 Io_error=0
1268 ON ERROR GOTO Hw_io_error
1269 Timeout_active=0
1270 IF NPAR=1 THEN
1271 IF Timeout_time>0 THEN Timeout_active=1
1272 END IF
1273 IF Timeout_active THEN
1274 ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1275 Start_time=TIMEDATE
1276 REPEAT
1277 OUTPUT @Hpib_mod;"RGSS"
1278 ENTER @Hpib_mod;Status
1279 IF BIT(Status,4) THEN SUBEXIT
1280 UNTIL ABS(TIMEDATE-Start_time)>Timeout_time
1281 ELSE
1282 REPEAT
1283 OUTPUT @Hpib_mod;"RGSS"
1284 ENTER @Hpib_mod;Status
1285 IF BIT(Status,4) THEN SUBEXIT
1286 UNTIL 1=0
1287 END IF
1288 Hw_io_error:Io_error=1
1289 SUBEND
1290 !
1291 Hw_mod_rst:SUB Hw_mod_rst(Mf_mod,OPTIONAL Timeout_time)
1292!
1293! This subprogram is used to reset an input module or an source
1294! module. The module to reset is specified by <mf_mod>. The module
1295! is reset through the use of the HP-IB module RST n command.
1296! <Timeout_time> is an optional timeout parameter in seconds.
1297 !
1298 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1299 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1300 Io_error=0
1301 ON ERROR GOTO Hw_io_error
1302 IF NPAR=2 THEN
1303 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1304 END IF
1305 OUTPUT @Hpib_mod;"RST ";Mf_mod
1306 IF 0 THEN
1307 Hw_io_error:Io_error=1
1308 END IF
1309 SUBEND
1310 !
1311 Hw_gbl_mod_rst:SUB Hw_gbl_mod_rst(OPTIONAL Timeout_time)
1312 !
1313 ! This subprogram is used to reset all modules on the fast bus (not
1314 ! the HP-IB module). This is equivalent to a power on state for the
1315 ! modules reset. <Timeout_time> is an optional timeout parameter in
1316 ! seconds.
1317 !
1318 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1319 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1320 Io_error=0
1321 ON ERROR GOTO Hw_io_error
1322 IF NPAR=1 THEN
1323 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1324 END IF
1325 OUTPUT @Hpib_mod;"RCF;TCF" ! this resets all inpt/srce modules
1326 IF 0 THEN
1327 Hw_io_error:Io_error=1
1328 END IF
1329 SUBEND
1330 !
1331 Hw_rmst:DEF FNHw_rmst(Mf_mod,OPTIONAL Timeout_time)
1332!
1333! This function is used to get the module status register of the
1334! specified input module or source module. The module is specified
1335! by <mf_mod>. The value of the specified module's status register
1336! is returned to the caller in the function result. This function
1337! makes use of the HP-IB module RMST command. <Timeout_time> is an
1338! optional timeout parameter in seconds.
1339!
1340 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1341 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1342 Io_error=0
1343 ON ERROR GOTO Hw_io_error
1344 IF NPAR=2 THEN
1345 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1346 END IF
1347 OUTPUT @Hpib_mod;"RMST ";Mf_mod
1348 ENTER @Hpib_mod;Temp
1349 IF 0 THEN
1350 Hw_io_error:!
1351 Io_error=1
1352 Temp=0
1353 END IF
1354 RETURN Temp
1355 FNEND
1356 !
1357 Hw_gbl_rmst:DEF FNHw_gbl_rmst(OPTIONAL Timeout_time)
1358 !
1359 ! This function is used to read the global fast bus module status
1360 ! register. For information on the global fast bus module status
1361 ! register, see RGSS in HP-IB module documentation. The global fast
1362 ! bus module status register is returned to the caller as the
1363 ! function result. <Timeout_time> is an optional timeout parameter
1364 ! in seconds.
1365 !
1366 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1367 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1368 Io_error=0
1369 ON ERROR GOTO Hw_io_error
1370 IF NPAR=1 THEN
1371 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1372 END IF
1373 OUTPUT @Hpib_mod;"RGSS"
1374 ENTER @Hpib_mod;Temp
1375 IF 0 THEN
1376 Hw_io_error:!
1377 Io_error=1
1378 Temp=0
1379 END IF
1380 RETURN Temp
1381 FNEND
1382 !
1383 Hw_sel_abort:SUB Hw_sel_abort
1384!
1385! This function is used to cease activity on the HP-IB interface.
1386! If the host is not currently the active HP-IB controller, then it
1387! (the host) will assume active control. This is equivalent to the
1388! BASIC ABORT command.
1389!
1390 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1391 Io_error=0
1392 ON ERROR GOTO Hw_io_error
1393 ABORT Sel_code
1394 IF 0 THEN
1395 Hw_io_error:Io_error=1
1396 END IF
1397 SUBEND
1398 !
1399 Hw_wait_srq:SUB Hw_wait_srq(OPTIONAL Timeout_time)
1400!
1401! This subprogram is used to hold off execution of the host program
1402! until the HP-IB SRQ line is asserted. When the HP-IB SRQ line is
1403! asserted, this subprogram will terminate, returning host processor
1404! control to the caller. <Timeout_time> is an optional timeout
1405! parameter in seconds.
1406!
1407 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1408 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1409 INTEGER Status,Timeout_active
1410 REAL Start_time
1411 ON ERROR GOTO Hw_io_error
1412 Timeout_active=0
1413 IF NPAR=1 THEN
1414 IF Timeout_time>0 THEN Timeout_active=1
1415 END IF
1416 IF Timeout_active THEN
1417 Start_time=TIMEDATE
1418 REPEAT
1419 STATUS Sel_code,7;Status
1420 IF BIT(Status,10) THEN SUBEXIT
1421 UNTIL ABS(TIMEDATE-Start_time)>Timeout_time
1422 ELSE
1423 REPEAT
1424 STATUS Sel_code,7;Status
1425 IF BIT(Status,10) THEN SUBEXIT
1426 UNTIL 1=0
1427 END IF
1428 Hw_io_error:Io_error=1
1429 SUBEND
1430 !
1431 Hw_wait_cntrlr:SUB Hw_wait_cntrlr(OPTIONAL Timeout_time)
1432!
1433! This subprogram is used to hold off execution of the host program
1434! until the host becomes the active HP-IB bus controller. When the
1435! host becomes the active controller of the HP-IB bus, this
1436! subprogram will terminate, returning host processor control to the
1437! caller. <Timeout_time> is an optional timeout parameter in
1438! seconds.
1439!
1440 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1441 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1442 INTEGER Status,Timeout_active
1443 REAL Start_time
1444 Io_error=0
1445 ON ERROR GOTO Hw_io_error
1446 Timeout_active=0
1447 IF NPAR=1 THEN
1448 IF Timeout_time>0 THEN Timeout_active=1
1449 END IF
1450 IF Timeout_active THEN
1451 Start_time=TIMEDATE
1452 REPEAT
1453 STATUS Sel_code,6;Status
1454 IF BIT(Status,6) THEN SUBEXIT
1455 UNTIL ABS(TIMEDATE-Start_time)>Timeout_time
1456 ELSE
1457 REPEAT
1458 STATUS Sel_code,6;Status
1459 IF BIT(Status,6) THEN SUBEXIT
1460 UNTIL 1=0
1461 END IF
1462 Hw_io_error:Io_error=1
1463 SUBEND
1464 !
1465 Hw_io_error:DEF FNHw_io_error
1466 !
1467 ! This function is used to see if an error occurred during the last
1468 ! activation of a hardware interface subprogram. A timeout is
1469 ! considered an error. Returned as the function result is a boolean
1470 ! with a value of true if an error or timeout did occur.
1471 !
1472 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1473 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1474 INTEGER Temp
1475 Temp=Io_error
1476 Io_error=0
1477 RETURN Temp
1478 FNEND
1479 !
1480 Hw_srq:DEF FNHw_srq
1481 !
1482 ! This function is used to see if the HP-IB SRQ line is currently
1483 ! being asserted. Returned in the function result is a boolean
1484 ! value of true if the HP-IB SRQ line is currently being asserted.
1485 !
1486 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1487 INTEGER Status
1488 Io_error=0
1489 ON ERROR GOTO Hw_io_error
1490 STATUS Sel_code,7;Status
1491 IF 0 THEN
1492 Hw_io_error:!
1493 Io_error=1
1494 Status=0
1495 END IF
1496 RETURN BIT(Status,10)
1497 FNEND
1498 !
1499 Hw_cntrlr:DEF FNHw_cntrlr
1500 !
1501 ! This function is used to see if the host is currently the active
1502 ! controller of the HP-IB bus. Returned in the function result is a
1503 ! boolean with a value of true if the host is currently the active
1504 ! controller of the HP-IB bus. Otherwise, false is returned.
1505 !
1506 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1507 INTEGER Status
1508 Io_error=0
1509 ON ERROR GOTO Hw_io_error
1510 STATUS Sel_code,6;Status
1511 IF 0 THEN
1512 Hw_io_error:!
1513 Io_error=1
1514 Status=0
1515 END IF
1516 RETURN BIT(Status,6)
1517 FNEND
1518 !
1519 Hw_pass_cntrlr:SUB Hw_pass_cntrlr(OPTIONAL Timeout_time)
1520 !
1521 ! The subprogram is used to pass control of the HP-IB bus to the
1522 ! HP-IB module. What else can I say?
1523 !
1524 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1525 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1526 Io_error=0
1527 ON ERROR GOTO Hw_io_error
1528 IF NPAR=1 THEN
1529 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1530 END IF
1531 PASS CONTROL @Hpib_mod
1532 IF 0 THEN
1533 Hw_io_error:Io_error=1
1534 END IF
1535 SUBEND
1536 !
1537 Hw_host_addr:DEF FNHw_host_addr
1538 !
1539 ! This function is used to get the host HP-IB device address. The
1540 ! host HP-IB device address is returned in the function result.
1541 !
1542 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1543 INTEGER Host_addr
1544 Io_error=0
1545 ON ERROR GOTO Hw_io_error
1546 STATUS Sel_code,3;Host_addr
1547 IF 0 THEN
1548 Hw_io_error:!
1549 Io_error=1
1550 Host_addr=0
1551 END IF
1552 RETURN Host_addr MOD 32
1553 FNEND
1554 !
1555 Hw_dev_clear:SUB Hw_dev_clear(OPTIONAL Timeout_time)
1556!
1557! This subprogram is used to send a device clear to the HP-IB
1558! module. A device clear will abort a running ICODE program and set
1559! the HP-IB module HP-IB interface to a reset state. Note that this
1560! does not dispose any HP-IB module memory blocks.
1561!
1562 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1563 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1564 ON ERROR GOTO Hw_io_error
1565 IF NPAR=1 THEN
1566 IF Timeout_time THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1567 END IF
1568 Io_error=0
1569 CLEAR @Hpib_mod
1570 IF 0 THEN
1571 Hw_io_error:Io_error=1
1572 END IF
1573 SUBEND
1574 !
1575 Hw_get_dev_sels:SUB Hw_get_dev_sels(INTEGER Dev_sel_list(*),INTEGER Cant_check_list(*))
1576!
1577! This subprogram is used to find out the device select code of
1578! every HP3565S hardware system currently connected to the host.
1579! All selector slots (7 through 31) are checked for HP-IB cards.
1580! All selector slots that are found to have HP-IB cards are searched
1581! for HP3565S hardware. To search a selector slot for HP3565S
1582! hardware, all HP-IB device address (0 through 31 except host
1583! address) are sent ID?. If the device responds with 'HP35651A',
1584! then the device selector address is noted in <dev_sel_list(*)>.
1585! The list of HP3565S hardware device selector addresses is returned
1586! to the host in <dev_sel_list(*)>. Note that a device selector
1587! address of 934 can be broken down into a selector of 9 and a
1588! device address of 34. See BASIC manual for more information of
1589! device selectors. <Cant_check_list(*)> contains information about
1590! entire selectors and device selector addresses that could not be
1591! checked. If a HP-IB card is not an active controller, then the
1592! device addresses on that selector bus can not be checked. The
1593! selector number (7 through 31) of any non-active HP-IB controller
1594! is entered into <cant_check_list>. For every HP-IB card found,
1595! there is one device address that can not be checked. That is the
1596! address of the host on that bus. For every active controller
1597! HP-IB card in the host, the device selector address of the host is
1598! placed in <cant_check_list(*)> (700->731,800->831,...,3100->3131).
1599! Both <dev_sel_list(*)> and <cant_check_list(*)> are REDIMed to the
1600! number of elements placed in each respective list. If either
1601! array is not large enough to hold the entire list, then entries
1602! are made until the lists are full and an error is logged. If no
1603! HP3565S hardware system is found, then <dev_sel_list(*)> is
1604! REDIMed to one element containing one zero and an error is logged.
1605!
1606 COM /Hw_com2/ INTEGER Io_error,INTEGER Dummy1,INTEGER Dummy2
1607 INTEGER Dev_sel_size,Dev_sel_last,Cant_check_size,Cant_check_last
1608 INTEGER Sel_code,Sel_status,Hpib_addr,Host_hpib_addr,Dev_sel_code
1609 DIM Id_response$[255]
1610 !
1611 Print_hpib_addr=1
1612 !
1613 Io_error=0
1614 MAT Dev_sel_list= (0)
1615 Dev_sel_size=SIZE(Dev_sel_list,1)
1616 Dev_sel_last=0
1617 MAT Dev_sel_list= (0)
1618 Cant_check_size=SIZE(Cant_check_list,1)
1619 Cant_check_last=0
1620 !
1621 FOR Sel_code=7 TO 31
1622 ON ERROR GOTO Hw_no_sel_code
1623 STATUS Sel_code,0;Sel_status
1624 IF 0 THEN
1625 Hw_no_sel_code:Sel_status=-1
1626 END IF
1627 IF Sel_status=1 THEN
1628 STATUS Sel_code,3;Sel_status
1629 IF NOT BIT(Sel_status,6) THEN !hp-ib card isn't active controller
1630 Cant_check_last=Cant_check_last+1
1631 IF Cant_check_last<=Cant_check_size THEN
1632 Cant_check_list(Cant_check_last)=Sel_code
1633 ELSE
1634 Io_error=1
1635 END IF
1636 ELSE !hp-ib card is active controller
1637 Host_hpib_addr=Sel_status MOD 32 !check all addrs except host addr
1638 FOR Hpib_addr=0 TO 31
1639 Dev_sel_code=(Sel_code*100)+Hpib_addr
1640 IF Hpib_addr=Host_hpib_addr OR Hpib_addr=Print_hpib_addr THEN
1641 Cant_check_last=Cant_check_last+1
1642 IF Cant_check_last<=Cant_check_size THEN
1643 Cant_check_list(Cant_check_last)=Dev_sel_code
1644 ELSE
1645 Io_error=1
1646 END IF
1647 ELSE
1648 ON TIMEOUT Sel_code,.1 GOTO Hw_no_response
1649 ON ERROR GOTO Hw_no_response
1650 CLEAR Dev_sel_code
1651 OUTPUT Dev_sel_code;" "
1652 OUTPUT Dev_sel_code;"ID?"
1653 ENTER Dev_sel_code;Id_response$
1654 IF 0 THEN
1655 Hw_no_response:Id_response$=""
1656 END IF
1657 OFF TIMEOUT Sel_code
1658 OFF ERROR
1659 IF POS(Id_response$,"HP35651A") THEN
1660 Dev_sel_last=Dev_sel_last+1
1661 IF Dev_sel_last<=Dev_sel_size THEN
1662 Dev_sel_list(Dev_sel_last)=Dev_sel_code
1663 ELSE
1664 Io_error=1
1665 END IF
1666 END IF ! found Interface Module
1667 END IF
1668 NEXT Hpib_addr
1669 END IF ! host is active controller
1670 END IF ! hp-ib card present
1671 NEXT Sel_code
1672 !
1673 REDIM Dev_sel_list(1:MIN(Dev_sel_size,MAX(Dev_sel_last,1)))
1674 REDIM Cant_check_list(1:MIN(Cant_check_size,MAX(Cant_check_last,1)))
1675 IF Dev_sel_list(1)=0 THEN Io_error=1
1676 !
1677 SUBEND
1678 !
1679 Hw_set_dev_sel:SUB Hw_set_dev_sel(INTEGER Dev_sel_code)
1680!
1681! This subprogram is used to set the current device select code for
1682! the HP3565S hardware. The current device select code will be set
1683! to <dev_sel_code>. Until this subprogram is used to set the
1684! current device select code, no other hardware interface subprogram
1685! may be used. The three exceptions to this are Hw_get_dev_sels,
1686! Hw_hw, and Hw_io_error. Once the current device select code is
1687! set, no other HP3565S demo program files need worry about device
1688! select codes, I/O addresses, or other such nasty things. Note
1689! that this subprogram should be used the CNFG file ONLY.
1690!
1691 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1692 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1693 Io_error=0
1694 ON ERROR GOTO Hw_bad_ds_code
1695 Sel_code=Dev_sel_code DIV 100
1696 Hpib_addr=Dev_sel_code MOD 100
1697 ASSIGN @Hpib_mod TO Dev_sel_code
1698 ASSIGN @Bin_hpib_mod TO Dev_sel_code;FORMAT OFF
1699 IF 0 THEN
1700 Hw_bad_ds_code:Io_error=1
1701 END IF
1702 SUBEND
1703 !
1704 Hw_cur_dev_sel:DEF FNHw_cur_dev_sel
1705!
1706! This function is used to get the current device select code. The
1707! current device select code is returned as the function result.
1708! Note that the device select code is set by the configuration
1709! (CNFG) file.
1710!
1711 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1712 Io_error=0
1713 RETURN Sel_code*100+Hpib_addr
1714 FNEND
1715 !
1716 Hw_stat_2_str:DEF FNHw_stat_2_str$(Stat)
1717 !
1718 ! This function is used to convert a HP-IB module status register
1719 ! value into a string containing a three letter mnemonic code for
1720 ! each active status bit. Following each mnemonic code will be a
1721 ! '|'. The mnemonic codes are as follows:
1722 !
1723 ! Bit Value Bit Pos Mnemonic Definition
1724 ! --------- ------- -------- ---------------------------------
1725 ! 1= bit 0 RQS| Request Control of HP-IB bus.
1726 ! 2= bit 1 - - - - - not used - - - - -
1727 ! 4= bit 2 UPP| ICODE program paused.
1728 ! 8= bit 3 PRG| ICODE program complete.
1729 ! 16= bit 4 RDY| Ready for anything.
1730 ! 32= bit 5 ERR| Error condition exists.
1731 ! 64= bit 6 RQS| Service Request.
1732 ! 128= bit 7 MSG| A message is ready for the host.
1733 ! 256= bit 8 FRQ| Fast bus SRQ signal line.
1734 ! 512= bit 9 IRQ| Fast bus IRQ signal line.
1735 ! 1024= bit10 SHT| Fast bus SHUTDOWN signal line.
1736 ! 2048= bit11 TRG| Fast bus TRG signal line.
1737 ! 4096= bit12 - - - - - not used - - - - -
1738 ! 8091= bit13 - - - - - not used - - - - -
1739 ! 16384= bit14 PON| Power on.
1740 !
1741 ! The string is returned to the caller in the function result string.
1742 ! For example, FNHw_stat_2_str$(2184) would return "PRG|MSG|TRG|".
1743 !
1744 DIM A$[255]
1745 A$=""
1746 IF BIT(Stat,0) THEN
1747 A$=A$&"RQC|"
1748 END IF
1749 IF BIT(Stat,2) THEN
1750 A$=A$&"UPP|"
1751 END IF
1752 IF BIT(Stat,3) THEN
1753 A$=A$&"PRG|"
1754 END IF
1755 IF BIT(Stat,4) THEN
1756 A$=A$&"RDY|"
1757 END IF
1758 IF BIT(Stat,5) THEN
1759 A$=A$&"ERR|"
1760 END IF
1761 IF BIT(Stat,6) THEN
1762 A$=A$&"RQS|"
1763 END IF
1764 IF BIT(Stat,7) THEN
1765 A$=A$&"MSG|"
1766 END IF
1767 IF BIT(Stat,8) THEN
1768 A$=A$&"FRQ|"
1769 END IF
1770 IF BIT(Stat,9) THEN
1771 A$=A$&"IRQ|"
1772 END IF
1773 IF BIT(Stat,10) THEN
1774 A$=A$&"SHT|"
1775 END IF
1776 IF BIT(Stat,11) THEN
1777 A$=A$&"TRG|"
1778 END IF
1779 IF BIT(Stat,14) THEN
1780 A$=A$&"PON|"
1781 END IF
1782 IF A$="" THEN RETURN ""
1783 RETURN TRIM$(A$[1,LEN(A$)-1])
1784 FNEND
1785 !
1786 Hw_mainmem_aval:DEF FNHw_mainmem_aval(OPTIONAL Timeout_time)
1787 !
1788 ! This function is used to get the total amount (in words) of HP-IB
1789 ! module main data RAM that has not been allocated. The amount will
1790 ! be returned in the function result. Note that the value returned
1791 ! by this function is not necessarily the size of the largest block.
1792 ! <Timeout_time> is an optional timeout parameter in seconds.
1793 !
1794 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1795 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1796 REAL Mem_available,Dummy
1797 Io_error=0
1798 ON ERROR GOTO Hw_io_error
1799 IF NPAR=1 THEN
1800 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1801 END IF
1802 !
1803 OUTPUT @Hpib_mod;"MEM?"
1804 ENTER @Hpib_mod;Mem_available,Dummy,Dummy,Dummy
1805 IF 0 THEN
1806 Hw_io_error:!
1807 Io_error=1
1808 Mem_available=0
1809 END IF
1810 RETURN Mem_available
1811 FNEND
1812 !
1813 Hw_mainblk_aval:DEF FNHw_mainblk_aval(OPTIONAL Timeout_time)
1814 !
1815 ! The function is used to get the size (in words) of the largest
1816 ! HP-IB module main data RAM block. This value will be returned as
1817 ! the function result. <Timeout_time> is an optional timeout
1818 ! parameter in seconds.
1819 !
1820 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1821 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1822 REAL Mem_available,Dummy
1823 Io_error=0
1824 ON ERROR GOTO Hw_io_error
1825 IF NPAR=1 THEN
1826 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1827 END IF
1828 OUTPUT @Hpib_mod;"MEM?"
1829 ENTER @Hpib_mod;Dummy,Mem_available,Dummy,Dummy
1830 IF 0 THEN
1831 Hw_io_error:!
1832 Io_error=1
1833 Mem_available=0
1834 END IF
1835 RETURN Mem_available
1836 FNEND
1837 !
1838 Hw_spmem_aval:DEF FNHw_spmem_aval(OPTIONAL Timeout_time)
1839 !
1840 ! This function is used to get the total amount (in words) of HP-IB
1841 ! module SP data RAM that has not been allocated. The amount will
1842 ! be returned in the function result. Note that the value returned
1843 ! by this function is not necessarily the size of the largest block.
1844 ! <Timeout_time> is an optional timeout parameter in seconds.
1845 !
1846 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1847 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1848 REAL Mem_available,Dummy
1849 Io_error=0
1850 ON ERROR GOTO Hw_io_error
1851 IF NPAR=1 THEN
1852 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1853 END IF
1854 OUTPUT @Hpib_mod;"MEM?"
1855 ENTER @Hpib_mod;Dummy,Dummy,Mem_available,Dummy
1856 IF 0 THEN
1857 Hw_io_error:!
1858 Io_error=1
1859 Mem_available=0
1860 END IF
1861 RETURN Mem_available
1862 FNEND
1863 !
1864 Hw_spblk_aval:DEF FNHw_spblk_aval(OPTIONAL Timeout_time)
1865 !
1866 ! The function is used to get the size (in words) if the largest
1867 ! HP-IB module SP data RAM block. This value will be returned as
1868 ! the function result. <Timeout_time> is an optional timeout
1869 ! parameter in seconds.
1870 !
1871 COM /Hw_com1/ @Hpib_mod,@Bin_hpib_mod
1872 COM /Hw_com2/ INTEGER Io_error,INTEGER Sel_code,INTEGER Hpib_addr
1873 REAL Mem_available,Dummy
1874 Io_error=0
1875 ON ERROR GOTO Hw_io_error
1876 IF NPAR=1 THEN
1877 IF Timeout_time>0 THEN ON TIMEOUT Sel_code,Timeout_time GOTO Hw_io_error
1878 END IF
1879 OUTPUT @Hpib_mod;"MEM?"
1880 ENTER @Hpib_mod;Dummy,Dummy,Dummy,Mem_available
1881 IF 0 THEN
1882 Hw_io_error:Io_error=1
1883 Mem_available=0
1884 END IF
1885 RETURN Mem_available
1886 FNEND
1887 !
1888 Hw_get_errstr:DEF FNHw_get_errstr$(Error_num)
1889 !
1890 ! This function is used to convert an HP-IB module error number into
1891 ! the appropriate error message string. The error number (or error
1892 ! code) is passed to this function in <Error_num>. The appropriate
1893 ! error message string is returned to the caller in the function
1894 ! result string. If an invalid error number is passed in to this
1895 ! function, then VAL$(Error_num) is returned to the caller.
1896 !
1897 DIM Msg$[100]
1898 INTEGER Current_err
1899 ON ERROR GOTO Hw_not_found
1900 REPEAT
1901 READ Current_err,Msg$
1902 UNTIL Current_err=Error_num
1903 OFF ERROR
1904 RETURN Msg$
1905 STOP
1906 Hw_not_found:OFF ERROR
1907 RETURN VAL$(Error_num)
1908 STOP
1909 DATA -100,"Command error (unknown command)"
1910 DATA -101,"Invalid character received"
1911 DATA -110,"Command Header error"
1912 DATA -111,"Header delimiter error"
1913 DATA -120,"Numeric argument error"
1914 DATA -121,"Wrong Data Type (numeric expected)"
1915 DATA -122,"Precision error; rounding occurred"
1916 DATA -123,"Numeric overflow"
1917 DATA -129,"Missing numeric argument"
1918 DATA -130,"non numeric argument error (char, string or block)"
1919 DATA -131,"Wrong Data Type (char expected)"
1920 DATA -132,"Wrong Data Type (string expected)"
1921 DATA -133,"Wrong Data Type (block type #A required)"
1922 DATA -134,"Data Overflow: string or block too long"
1923 DATA -139,"Missing non numeric argument"
1924 DATA -141,"Command Buffer Overflow"
1925 DATA -142,"Too many arguments"
1926 DATA -143,"Argument delimiter error"
1927 DATA -144,"Invalid message unit delimiter"
1928 DATA -200,"No Can Do (generic execution error)"
1929 DATA -201,"Not executable in local mode"
1930 DATA -202,"Settings lost due to rtl or pon "
1931 DATA -203,"Trigger ignored"
1932 DATA -211,"Legal command, but settings conflict"
1933 DATA -212,"Argument out of range"
1934 DATA -221,"Busy doing something else"
1935 DATA -222,"Insufficient capability or configuration"
1936 DATA -231,"Input buffer full or overflow"
1937 DATA -232,"Output buffer full or overflow"
1938 DATA -1,"unexpected interrupt"
1939 DATA -2,"stack overflow"
1940 DATA -3,"reference to NIL pointer"
1941 DATA -4,"integer overflow"
1942 DATA -5,"divide by zero"
1943 DATA -6,"real math overflow"
1944 DATA -7,"real math underflow"
1945 DATA -8,"value range error"
1946 DATA -9,"case value range error"
1947 DATA -10,"Bad input format or String subscript out of range"
1948 DATA -11,"CPU word access to odd address"
1949 DATA -12,"CPU bus error"
1950 DATA -13,"illegal CPU instruction"
1951 DATA -14,"CPU privilege violation"
1952 DATA -15,"bad argument SIN/COS"
1953 DATA -16,"bad argument LN"
1954 DATA -17,"bad argument SQRT"
1955 DATA -18,"bad argument real/BCD conversion"
1956 DATA -19,"bad argument BCD/real conversion"
1957 DATA -20,"stopped by user"
1958 DATA -21,"unassigned CPU trap"
1959 DATA -25,"undefined macro parameter"
1960 DATA -26,"I/O routine error"
1961 DATA -28,"CPU trace exception"
1962 DATA 101,"unable to allocate block. ( see NEW and SNEW )"
1963 DATA 102,"Undefined blockid."
1964 DATA 103,"Block will not hold all the data."
1965 DATA 104,"Output string buffer overflow."
1966 DATA 105,"Output request buffer overflow."
1967 DATA 200,"FP-IB bus is reset, unable to take control. (see TCF)"
1968 DATA 201,"Other FP-IB controller present. (see TCF)"
1969 DATA 202,"FP-IB read transfer timeout."
1970 DATA 203,"FP-IB write transfer timeout."
1971 DATA 204,"FP-IB read overflow."
1972 DATA 205,"Interface FP-IB address used."
1973 DATA 206,"Interface module not in control of FP-IB."
1974 DATA 207,"I/O aborted because the FP-IB module is not responding."
1975 DATA 208,"SYNC timeout error."
1976 DATA 209,"FP-IB went into an unexpected reset state."
1977 DATA 210,"Trigger sequence timeout error.(Someone is asserting trig line)"
1978 DATA 300,"An ICODE program is not running."
1979 DATA 301,"An ICODE program cannot be continued because it is not paused."
1980 DATA 302,"Command cannot be completed because an ICODE program is active."
1981 DATA 303,"Attempt to fetch past the end of an ICODE block has occurred."
1982 DATA 304,"Non-existent icode variable fetch."
1983 DATA 305,"Illegal blockid use."
1984 DATA 306,"ICODE value range error."
1985 DATA 307,"Block offset too large for block."
1986 DATA 308,"Branch out of bounds."
1987 DATA 309,"Access past block boundaries."
1988 DATA 310,"Subroutines nested more than 16."
1989 DATA 311,"An RTS instruction has been executed without an active sub."
1990 DATA 312,"f_thruput executed before a f_ready_ram or f_ready_disc."
1991 DATA 313,"Illegal block size"
1992 DATA 314,"Block exponent offset is out of header block."
1993 DATA 315,"Block exponent overflow."
1994 DATA 316,"Block exponent underflow."
1995 DATA 317,"No header block allocated for block exponent."
1996 DATA 318,"Requested window size is odd."
1997 DATA 319,"Illegal relationship between f_sample args."
1998 DATA 320,"Illegal opcode."
1999 DATA 321,"Work block not declared."
2000 DATA 322,"Work block is too small."
2001 DATA 323,"Fast average exponent out of range."
2002 DATA 324,"Missing mf_mod from f_ready_ram/f_ready_disc mf_mod list."
2003 DATA 325,"f_ready_ram/f_ready_disc mf_mod list block too small."
2004 DATA 326,"f_ready_disc disc segment block too small."
2005 DATA 327,"disc address not on block boundary."
2006 DATA 328,"f_keep_ready_ram with out f_ready_ram."
2007 DATA 401,"HP-IB deadlock."
2008 DATA 402,"The interface module is not in control of the HP-IB."
2009 DATA 403,"The interface module is not addressed to listen."
2010 DATA 404,"The interface module is not addressed to talk."
2011 DATA 405,"HP-IB timeout."
2012 DATA 406,"Disc Error reported."
2013 DATA 407,"Disc reports no device present."
2014 DATA 408,"Disc blocksize too large ( > 1024 )"
2015 DATA 409,"Disc reports bad mode."
2016 DATA 410,"Disc reports no such block."
2017 DATA 411,"The disc is uninitialized."
2018 DATA 412,"Disc initialization failed."
2019 DATA 413,"The disc is not ready."
2020 DATA 414,"The disc is write protected."
2021 DATA 415,"Disc reports no such block."
2022 DATA 416,"Disc reported a bad block."
2023 DATA 417,"The disc medium was changed during transfer."
2024 DATA 418,"A icode transfer of this type has not been set up. (RBLK,WBLK)"
2025 DATA 419,"HP-IB transfer not completed. (Usually to the host)"
2026 DATA 420,"Disc message length error."
2027 DATA 500,"undefined, reserved"
2028 DATA 501,"unexpected interrupt during power on tests"
2029 DATA 502,"interrupt test generation failure"
2030 DATA 503,"tms320 failure"
2031 DATA 504,"timer failure"
2032 DATA 505,"dma_failure"
2033 DATA 506,"fpib failure"
2034 DATA 507,"hpib failure"
2035 DATA 508,"undefined, reserved"
2036 DATA 509,"high byte rom checksum error"
2037 DATA 510,"low byte rom checksum error"
2038 DATA 511,"signal processor program ram failure"
2039 DATA 512,"signal processor data ram failure"
2040 DATA 513,"ram refresh failure"
2041 DATA 514,"ram error (non refresh error)"
2042 DATA 515,"not enough ram"
2043 DATA 523,"io dtack failure ( ie leds )"
2044 DATA 524,"timer chip dtack failure"
2045 DATA 525,"dma dtack failure"
2046 DATA 526,"fpib dtack failure"
2047 DATA 527,"hpib dtack failure"
2048 DATA 528,"sp program ram dtack failure"
2049 DATA 529,"sp data ram dtack failure"
2050 DATA 530,"main ram dtack failure"
2051 DATA 540,"main ram test failure"
2052 DATA 541,"fpib test failure"
2053 DATA 542,"sp ram failure"
2054 DATA 543,"sp random number generator failure"
2055 DATA 544,"sp USM chip failure"
2056 DATA 545,"novram checksum error"
2057 DATA 546,"sp not responding"
2058 DATA 547,"sp interrupt routine not responding"
2059 DATA 548,"dma chip is inactive"
2060 DATA 549,"bus error during dma operation"
2061 DATA 550,"generic sp failure."
2062 DATA 600,"bit 0 of main ram bad."
2063 DATA 601,"bit 1 of main ram bad."
2064 DATA 602,"bit 2 of main ram bad."
2065 DATA 603,"bit 3 of main ram bad."
2066 DATA 604,"bit 4 of main ram bad."
2067 DATA 605,"bit 5 of main ram bad."
2068 DATA 606,"bit 6 of main ram bad."
2069 DATA 607,"bit 7 of main ram bad."
2070 DATA 608,"bit 8 of main ram bad."
2071 DATA 609,"bit 9 of main ram bad."
2072 DATA 610,"bit 10 of main ram bad."
2073 DATA 611,"bit 11 of main ram bad."
2074 DATA 612,"bit 12 of main ram bad."
2075 DATA 613,"bit 13 of main ram bad."
2076 DATA 614,"bit 14 of main ram bad."
2077 DATA 615,"bit 15 of main ram bad."
2078 DATA 700,"bit 0 of signal processor data ram bad."
2079 DATA 701,"bit 1 of signal processor data ram bad."
2080 DATA 702,"bit 2 of signal processor data ram bad."
2081 DATA 703,"bit 3 of signal processor data ram bad."
2082 DATA 704,"bit 4 of signal processor data ram bad."
2083 DATA 705,"bit 5 of signal processor data ram bad."
2084 DATA 706,"bit 6 of signal processor data ram bad."
2085 DATA 707,"bit 7 of signal processor data ram bad."
2086 DATA 708,"bit 8 of signal processor data ram bad."
2087 DATA 709,"bit 9 of signal processor data ram bad."
2088 DATA 710,"bit 10 of signal processor data ram bad."
2089 DATA 711,"bit 11 of signal processor data ram bad."
2090 DATA 712,"bit 12 of signal processor data ram bad."
2091 DATA 713,"bit 13 of signal processor data ram bad."
2092 DATA 714,"bit 14 of signal processor data ram bad."
2093 DATA 715,"bit 15 of signal processor data ram bad."
2094 DATA 800,"bit 0 of signal processor prog ram bad."
2095 DATA 801,"bit 1 of signal processor prog ram bad."
2096 DATA 802,"bit 2 of signal processor prog ram bad."
2097 DATA 803,"bit 3 of signal processor prog ram bad."
2098 DATA 804,"bit 4 of signal processor prog ram bad."
2099 DATA 805,"bit 5 of signal processor prog ram bad."
2100 DATA 806,"bit 6 of signal processor prog ram bad."
2101 DATA 807,"bit 7 of signal processor prog ram bad."
2102 DATA 808,"bit 8 of signal processor prog ram bad."
2103 DATA 809,"bit 9 of signal processor prog ram bad."
2104 DATA 810,"bit 10 of signal processor prog ram bad."
2105 DATA 811,"bit 11 of signal processor prog ram bad."
2106 DATA 812,"bit 12 of signal processor prog ram bad."
2107 DATA 813,"bit 13 of signal processor prog ram bad."
2108 DATA 814,"bit 14 of signal processor prog ram bad."
2109 DATA 815,"bit 15 of signal processor prog ram bad."
2110 FNEND
2111 !
2112 ! PAGE ->
2113 !***************************************************************
2114 Hw_str_2_stat:DEF FNHw_str_2_stat(A$)
2115 !
2116 ! This function is used to convert a string with HP-IB module status
2117 ! bit mnemonic codes into an numerical value representing that
2118 ! status string. Each mnemonic string can be delimited by a ',' or
2119 ! '|'. The list of valid mnemonic strings is as follows:
2120 !
2121 ! Bit Value Bit Pos Mnemonic
2122 ! --------- ------- ---------------------------------------
2123 ! 1= bit 0 RQS or REQUEST CONTROL
2124 ! 2= bit 1 BIT1
2125 ! 4= bit 2 UPP or PAUSE
2126 ! 8= bit 3 PRG or STOPPED
2127 ! 16= bit 4 RDY or READY
2128 ! 32= bit 5 ERR or ERROR
2129 ! 64= bit 6 RQS
2130 ! 128= bit 7 MSG or MESSAGE
2131 ! 256= bit 8 FRQ or FAST BUS SRQ
2132 ! 512= bit 9 IRQ
2133 ! 1024= bit10 SHT or SHUT or SHUTDOWN
2134 ! 2048= bit11 TRG or TRIG or TRIGGER
2135 ! 4096= bit12 BIT12
2136 ! 8091= bit13 BIT13
2137 ! 16384= bit14 PON or POWER ON
2138 !
2139 ! The numerical value calculated will be returned in the function
2140 ! result. For example, FNHw_str_2_stat("PAUSE|RQS,FAST BUS SRQ")
2141 ! would return 324 as a result. If any field of Hp_ib_stat_str$ is
2142 ! not recognized by this function, then an error is logged on the
2143 ! CRT and no value returned. This is the inverse of FNHw_stat_2_str$
2144 ! which converts the numerical value into a status string containing
2145 ! a mnemonic entry for each active status bit.
2146 !
2147 ALLOCATE Temp$[255],Bit$[40]
2148 Temp$=TRIM$(UPC$(A$))
2149 Stat=0
2150 WHILE POS(Temp$,",")
2151 Temp$[POS(Temp$,",");1]="|"
2152 END WHILE
2153 WHILE POS(Temp$,"|")
2154 Bit$=Temp$[1,POS(Temp$,"|")-1]
2155 GOSUB Hw_add_bit_val
2156 Temp$=Temp$[POS(Temp$,"|")+1]
2157 END WHILE
2158 IF Temp$<>"" THEN
2159 Bit$=Temp$
2160 GOSUB Hw_add_bit_val
2161 END IF
2162 RETURN Stat
2163 Hw_add_bit_val: !
2164 SELECT TRIM$(Bit$)
2165 CASE "RQC","REQUEST CONTROL"
2166 Stat=Stat+1 !bit 0
2167 CASE "BIT1"
2168 Stat=Stat+2
2169 CASE "UPP","PAUSE"
2170 Stat=Stat+4 !bit 2
2171 CASE "PRG","STOPPED"
2172 Stat=Stat+8 !bit 3
2173 CASE "RDY","READY"
2174 Stat=Stat+16 !bit 4
2175 CASE "ERR","ERROR"
2176 Stat=Stat+32 !bit 5
2177 CASE "RQS"
2178 Stat=Stat+64 !bit 6
2179 CASE "MSG","MESSAGE"
2180 Stat=Stat+128 !bit 7
2181 CASE "FRQ","FAST BUS SRQ"
2182 Stat=Stat+256 !bit 8
2183 CASE "IRQ"
2184 Stat=Stat+512 !bit 9
2185 CASE "SHT","SHUT","SHUTDOWN"
2186 Stat=Stat+1024 !bit 10
2187 CASE "TRG","TRIG","TRIGGER"
2188 Stat=Stat+2048 !bit 11
2189 CASE "BIT12"
2190 Stat=Stat+4096 !bit 12
2191 CASE "BIT13"
2192 Stat=Stat+8192 !bit 13
2193 CASE "PON","POWER ON"
2194 Stat=Stat+16384 !bit 14
2195 CASE ELSE
2196 User_error("*** Couldn't recognize "&Bit$&" in FNHw_str_2_stat***")
2197 END SELECT
2198 RETURN
2199 FNEND
2200 !
2201 ! PAGE ->
2202 !****************************************************************
2203 Icode_icode:SUB Icode_icode
2204 !
2205 ! This subroutine is used to initialize the ICODE file. As you can see
2206 ! there is not much to initialize.
2207 !
2208 SUBEND
2209 !
2210 Icode_assemble:DEF FNIcode_assemble(Source$(*),INTEGER Object(*),INTEGER Info_info,Info$(*),INTEGER Enable_list_arg,List$(*))
2211!
2212!
2213! This subprogram 'Icode_assemble', is used to translate ICODE assembly
2214! language programs into object code that can be run in the HP3565S HP-IB
2215! module. The ICODE assembly language is defined in the ICODE section of
2216! demo programs manual.
2217!
2218! ==> Assembler activation:
2219!
2220! Error_count=FNIcode_assemble(Source$(*),INTEGER Object(*)
2221! INTEGER Info_info,Info$(*),INTEGER Enable_list_arg
2222! List$(*))
2223!
2224! Source$(*): Input - Holds ICODE source code. Each line of Source$
2225! contains one line of source code. Instructions
2226! with large parameter list may use more than one
2227! line by using a continuation line. The first
2228! character of a continuation line must be a '.'.
2229! The Source$ index must start at 0.
2230! The length the string elements in Source$ is
2231! defined by the user.
2232! Assembly will start at the beginning of Source$
2233! and continue until the end of Source$ is found,
2234! or until a line containing 'EL_COMPLETO' is
2235! found. If 'EL_COMPLETO' is used to terminate
2236! assembly, then Source$ is REDIMed to the actual
2237! size of the source program.
2238! Object(*): Output - Holds assembled ICODE object code.
2239! The Object index must start at 0.
2240! Object(*) is REDIMed to the size of the object
2241! code.
2242! Note that Info_info=2 will increase the size
2243! object array by 1 element for each assembled
2244! instruction.
2245! Info_info: Input - Determines what information the assembler
2246! should put in the Info$(*) array.
2247! 0 - Info$(*) is not accessed.
2248! 1 - Info$(*) is filled with information
2249! to be used by 'Icode_dld', 'Icode_ext_id'
2250! and 'Icode_def_ext'.
2251! 2 - Info$(*) is filled with information as
2252! if Info_info=1, and filled with info
2253! to be used by the 'Icode_debug'.
2254! Info_info=2 will also cause 'c_nop's to
2255! be insert in between each instruction.
2256! This is used by the debugger to set break
2257! points. Note that this will increase the
2258! size of the object code and also the size
2259! of the listing output if enabled.
2260! This mode may be used during program
2261! development.
2262! Info$(*): Output - Holds information to be used by other ICODE
2263! file subprograms.
2264! The Info$ index must start at 0.
2265! If Info_info=0, then Info$(*) is unaffected.
2266! If Info_info<>0 then Info$(*) string elements
2267! must be 40 characters long.
2268! If Info_info=1 then Info$(*) must have 6 lines
2269! + one line for each DEFBLK_SP,DEFBLK_MAIN or
2270! DEFBLK_EXT.
2271! If Info_info=2 then Info$(*) must have as many
2272! lines as in Info_info=1 + 4 + one line for each
2273! DEFBLK_VAR, DEFBLK_CON, VAR, + one line for
2274! each label, + one line for each 10 instructions.
2275! Enable_list_arg: Input - If 0, then List$(*) will not be accessed.
2276! If 1, then List$(*) will be filled with the
2277! assembly listing.
2278! List$(*): Output - Holds the assembly listing.
2279! The number of elements and the length of each
2280! string in List$ is defined by the user.
2281! The List$ index must start at 0.
2282! List$ string elements should be 15 chars
2283! longer than the string elements in Source(*).
2284! The number of elements in List$ should be
2285! ABOUT 2 to 4 times the number of lines in
2286! Source$(*). Note that Info_info=2 will cause
2287! the assembler to insert 'c_nop's in between
2288! each instruction. These 'c_nop's will show
2289! up in List$. List$ will be REDIMed to the size
2290! required to host the assembly listing
2291!
2292! ==> Example assembler activation:
2293!
2294! The following is an example of how the assemble an in line ICODE program.
2295!
2296! 110 Icode_program:!
2297! 120 DATA " err_abrt_count 5"
2298! 130 DATA " err_disp_lines 3"
2299! 140 DATA " var loop_ptr 0 "
2300! 150 DATA " const loop_max 10 ! loop 10 times"
2301! 160 DATA " "
2302! 170 DATA "loop_begin: f_signal loop_ptr
2303! 180 DATA " v_add loop_ptr,loop_ptr,1 ! inc ptr"
2304! 190 DATA " c_beq loop_begin loop_ptr "
2305! 200 DATA ". loop_max "
2306! 210 DATA " c_end "
2307! 220 DATA "el_completo"
2308! .
2309! .
2310! 500 DIM Source$(0:200)[80],List$(0:400)[120],Source_line$[80]
2311! 510 INTEGER Object(0:300),Info_info,Enable_list,Prog_id,Error_count
2312! .
2313! 600 Source_ptr=-1
2314! 610 RESTORE Icode_program
2315! 620 REPEAT
2316! 630 READ Source_line$
2317! 640 Source_ptr=source_ptr+1
2318! 650 Source$(Source_ptr)=Source_line$
2319! 660 UNTIL Source_line="el_completo"
2320! 670 !
2321! 680 Info_info=2 ! Enable auto allocate vars and debugger
2322! 690 Enable_list=1 ! Enable listing
2323! 700 !
2324! 710 Error_count=FNIcode_assemble(Source$(*),Object(*),Info_info,Info$(*)
2325! Enable_list,List$(*))
2326! 720 IF Error_count<>0 THEN
2327! 730 OUTPUT CRT; "Errors during assembly. Program paused"
2328! 740 PAUSE
2329! 750 END IF
2330! 760 Prog_id=FNIcode_dld(Object(*),Info_info,Info$(*)) ! download prog
2331! 770 IF Prog_id<=0 THEN
2332! 780 OUTPUT CRT; "Couldn't download ICODE program. Program paused."
2333! 790 PAUSE
2334! 800 END IF
2335! 810 FNHw_cmd("PROG "&Prog_id) ! start ICODE program
2336! .
2337! .
2338!
2339! ==> Listing format: (all values in Hex)
2340!
2341! OBJ ASM ASM SOURCE CODE
2342! ADDR VALU VALU
2343!
2344! 0004 0000 0004 var loop_ptr 0
2345! 000A const loop_max 10 ! loop 10 times
2346!
2347! 0006 003D <c_nop>
2348! 0007 0012,FFFE loop_begin: f_signal loop_ptr ! send loop ptr
2349! 0009 003D <c_nop>
2350! 000A 0047,FFFE v_add loop_ptr,loop_ptr,1 ! inc ptr
2351! 000C FFFE,0001
2352! 000E 003D <c_nop>
2353! 000F 0039,0000 c_beq loop_begin loop_ptr
2354! 0011 0006,FFFE . loop_max
2355! 0013 000A
2356! 0014 003D <c_nop>
2357! 0015 0030 c_end
2358! 0016 003D <c_nop>
2359!
2360! The array List$ will be filled the the assembly listing if the input
2361! parameter List_enable is non zero. The listing has the following format:
2362! + The first column of the listing indicates the hex address into the
2363! object array.
2364! + The second and third columns are the data values inserted into the
2365! Object array.
2366! + The rest of the line is the source code
2367! + Lines that contain <c_nop> are inserted by the assembler for use by
2368! the debugger in setting break points. These <c_nop>s would not be e
2369! if Info_info were equal to 0 or 1.
2370!
2371! ==> Source code format general:
2372!
2373! The source code passed to the assembler through Source$(*) has two
2374! sections. The first section is the pseudo-op section, and the second
2375! section is the main assembly section. Most of the syntax is similar
2376! to that of a standard assembler. Some global notes follow:
2377! + All parameter fields that require a numerical field may be in
2378! decimal or in hex. Hex numbers are specified by a "$" directly
2379! before the hex number.
2380! + All characters after the first occurrence of an '!' on any line
2381! will be treated as comments.
2382! + Parameter list elements may be delimited by either a space or by
2383! a comma. Between the opcode and the parameter list must be a
2384! space.
2385! + This is a one pass assembler. Labels are the only type of symbol
2386! that may be referenced before the symbol is defined.
2387! + Once a CONST has been defined, the CONST symbol may be used any
2388! place a numerical field is used.
2389! + All symbols may be up to 16 characters long and are case
2390! insensitive. The first character in a symbol must be a letter.
2391! The rest should be letters, numbers or an underscore. Other
2392! characters may not generate an error. User beware.
2393! + Symbols may be larger than 16 characters but only the first 16
2394! are significant. It would be best to make sure that all symbols
2395! are <= 16 characters in length.
2396! + ***** NOTE: When a new symbol is defined (Variable name, *****
2397! ***** Block name, etc ), NO checking is done to make *****
2398! ***** sure that the symbol is not already defined. *****
2399! ***** When a reference is made to a duplicate symbol,*****
2400! ***** it is undefined as to which one will be *****
2401! ***** referenced. *****
2402! + Below is a list of characters with special meaning.
2403! - '$' used to indicate a hex number.
2404! - '^' used to reference a header block.
2405! - '@' used to reference a variable through indirection.
2406! - ':' used as a label terminator.
2407! - ''' used to delimit a string parameter.
2408! - '!' used to indicate the beginning of a comment.
2409! - ',' used to delimit two parameters.
2410! - '.' used to indicate a continuation line.
2411!
2412!
2413! ==> Pseudo-op section:
2414!
2415! The pseudo-op section of a program begins at the beginning of Source(*)
2416! and continues until the end-of-program is found or until the first main
2417! assembly instruction is found. Below is a description of each pseudo-op
2418! pseudo-op.
2419!
2420!
2421! ERR_ABRT_COUNT <error count>
2422!
2423! This pseudo-op is used to tell the assembler how many errors should
2424! cause the assembler to stop assembling. By default, this value is
2425! four.
2426!
2427! ERR_DISP_LINES <# lines to disp before error>
2428!
2429! This pseudo-op is used to tell the assembler how many source lines
2430! before an instruction with an error should be displayed on the CRT.
2431! By default, this value is two.
2432!
2433! VAR <variable_name> <init value>
2434!
2435! This pseudo-op is used to define and initialize an ICODE variable.
2436! The <init value> field may be a CONST only if the constant has
2437! already been defined. To initialize one variable to the variable
2438! number of another variable (which must already be defined) do as
2439! follows:
2440!
2441! 20 DATA " var first_var 100 "
2442! 30 DATA " var second_var @first_var"
2443!
2444! In the above example, if 'first_var' is variable number 5, then
2445! 'second_var' will be initialized to 5. Note that 'first_var' must
2446! be defined before it may be used to initialize another variable.
2447! This may be useful if indirect variable accesses are being used.
2448!
2449!
2450! CONST <const name> <const value>
2451!
2452! This pseudo-op is used to define a constant. A constant symbol may
2453! be used any place an immediate parameter (floating point or integer)
2454! can be used once the CONST has been defined. If the constant is
2455! given a floating point value, and is used is a place that requires
2456! an integer (most of the time), the value used is INT(const_val).
2457! i.e. the floating point number is truncated.
2458!
2459! DEFBLK_CON <block_name> <block_id>
2460!
2461! This pseudo-op is used to define a block id if the block id is known
2462! at assembly time.
2463!
2464! DEFBLK_VAR <block_name> <block_id_var_init_value>
2465!
2466! This pseudo-op is used to define a block id where the block id will be
2467! put in a variable. An init value must be specified even though the
2468! variable need not contain the actual block id until runtime.
2469!
2470! DEFBLK_EXT <block_name>
2471!
2472! This pseudo-op is used to define a block name symbol within the ICODE
2473! program, but let the actual binding of the block name to the block id
2474! be done external to the assembly process. To bind a block id to the
2475! block symbol, the function 'FNIcode_def_ext' need be used. This may
2476! be useful if the block type (MAIN or SP) or size is not known at
2477! assembly time. This is also useful if multiple ICODE programs wish
2478! to share the same block. Through the used of 'FNIcode_def_ext', the
2479! user may allocate their own block and then bind it to <block_name> or
2480! tell 'FNIcode_def_ext' the block type and size, and have 'FNIcode_dld'
2481! allocate the block at runtime. To access the header block that may be
2482! associated with <block_name> a 'hat' may be placed in from of the
2483! <block_name> in the ICODE program. i.e. ^fft_blk_name
2484!
2485! DEFBLK_SP <block_name> <blk_size> <hblk_size>
2486!
2487! This pseudo-op is used to define an HP-IB module SP data RAM block
2488! for the assembly process and have the downloader allocate the block
2489! at runtime. For assembly, only the block size and the header block
2490! size need be known. 'FNIcode_dld' will allocate and bind the correct
2491! block id to <block_name>. To access the header block that may be
2492! associated with <block_name> a 'hat' may be placed in from of the
2493! <block_name> in the ICODE program. i.e. ^fft_blk_name
2494!
2495! DEFBLK_MAIN <block_name> <blk_size> <hblk_size>
2496!
2497! This pseudo-op is used to define an HP-IB module MAIN data RAM block
2498! for the assembly process and have the downloader allocate the block
2499! at runtime. For assembly, only the block size and the header block
2500! size need be known. 'FNIcode_dld' will allocate and bind the correct
2501! block id to <block_name>. To access the header block that may be
2502! associated with <block_name> a 'hat' may be placed in front of the
2503! <block_name> in the ICODE program. i.e. ^fft_blk_name
2504!
2505! LBL_TBL_SIZE <label_table_size>
2506!
2507! This pseudo-op is used to define the size of the label table size.
2508! When the assembler comes across a label definition, its name and
2509! location are placed in this table. Therefore, the label table must
2510! have one entry for each label in the ICODE program. By default,
2511! the label table has 50 entries.
2512!
2513! FORLBL_TBL_SIZE <forward_label_table_size>
2514!
2515! This pseudo-op is used to define the size of the forward reference
2516! label table. When the assembler comes across a label reference to
2517! a label that has not been defined yet, an entry is made in this
2518! table. Note that there may be more than one entry for a single
2519! label definition. When the label is defined, entry(s) referring
2520! to the defined label are removed. Since the size of this table
2521! is not a function of the number of labels, but rather the number
2522! of undefined forward references outstanding at one time, it is
2523! a little harder to choose the correct table size. By default, the
2524! forward reference label table has 100 entries.
2525!
2526! ==> Main assembly section:
2527!
2528! This is the section of the ICODE program that contain the executable
2529! instructions defined in the HP3565S ICODE manual. The syntax is
2530! similar to that of a 'normal' assembler. Some general rules are as
2531! follows:
2532! + Each instruction must begin on a new line. Instructions with
2533! parameter lists that require more than one line may use
2534! continuation lines. A continuation line must have a '.' as
2535! the first character on that line. Continuation across symbol
2536! boundaries is not allowed.
2537! + Too define a label, the label must be the first symbol on the
2538! line. The label is terminated with an ':'. More than one
2539! label may be used to point to one place in the ICODE program,
2540! but each label must be on a separate line.
2541! + Between the opcode and the parameter list must be a space.
2542! No comma.
2543! + Between the parameter list elements may be commas or spaces.
2544! + Below is some example ICODE source code. This code is NOT
2545! meant to mean anything program wise. It is meant to show
2546! some of the basic constructs used in ICODE instructions.
2547!
2548! 210 DATA "label1: f_signal first_variable ! this is a comment "
2549! 220 DATA " f_sync "
2550! 230 DATA "label2: ! label2 and label3 are equivalent"
2551! 240 DATA "label3: v_add loop_ptr loop_ptr 1 "
2552! 250 DATA " c_beq exit_prog,loop_ptr,10 "
2553! 260 DATA " v_mult loop_index ! "
2554! 270 DATA ". loop_ptr 10 !this is a continuation line"
2555! 370 DATA " c_goto label1 "
2556!
2557! + The HP3565S ICODE documentation says that a string parameter
2558! is preceeded by the length of the string. To specify a string
2559! parameter, the string need only be enclosed in single quotes
2560! '''. The assembler will deal with the length field.
2561! + If it is desired to enter immediate data into the ICODE
2562! program, then the ASM_OFF directive may be used. The ASM_OFF
2563! directive is of the form:
2564!
2565! ASM_OFF <parm_count> <parm1>,...,<parmn>
2566!
2567! <parm_count> is used to specify how many parameters follow.
2568! Each parameter is evaluated (immediate, variable, or const)
2569! and placed in the object array. The ASM_OFF directive may
2570! not be embedded in another instructions parameter list.
2571!
2572 Icode_asm_start:!
2573 DIM Line$[255],Opcode$[20],Label$[20],Disp_line$[100],Version$[10]
2574 DIM Arg$[20],Variable$[20],Inst_info$[255]
2575 INTEGER Asm_loop_done,Def_loop_done,Line_ptr,I,J,K,Enable_list
2576 REAL Real_temp,Arg,Max_32_int,Min_32_int,Max_16_int,Min_16_int
2577 INTEGER Int_temp,Int_hi,Int_lo,Add_object
2578 INTEGER Source_last,Object_last
2579 INTEGER Old_forlbl_last
2580 INTEGER Info_inst_base,Info_inst_cnt,Inst_cnt
2581 DIM Error_string$[100],Block_name$[20]
2582 DIM Repeat_str$[512]
2583 !
2584 ! Let's do some initialization
2585 !
2586 Icode_version:!
2587 Version$="1.0"
2588 Disp_line$="ICODE Assembler version "&Version$&" "
2589 DISP Disp_line$;" Initializing."
2590 !
2591 Source_size=SIZE(Source$,1)
2592 Object_size=SIZE(Object,1)
2593 Info_size=SIZE(Info$,1)
2594 List_size=SIZE(List$,1)
2595 !
2596 Lbl_tbl_size=50 ! default label table size
2597 Forlbl_tbl_size=100 ! default forward reference label tbl size
2598 Err_abrt_count=4 ! default error count to abort assembly
2599 Err_disp_lines=2 ! default # lines to disp when error is found
2600 !
2601 Error_count=0
2602 Missing_arg=0
2603 !
2604 ! Init table pointers. Pointers point to last entry used.
2605 Last_alloc_var=1 ! first var allocated will be var 2
2606 Vars_allocated=0
2607 Source_last=-1
2608 Object_last=-1
2609 Old_object_last=-1
2610 List_last=-1
2611 !
2612 Max_32_int=(2^31)-1
2613 Min_32_int=-(2^31)
2614 Max_16_int=(2^15)-1
2615 Min_16_int=-(2^15)
2616 !
2617 MAT List$= ("")
2618 MAT Info$= ("")
2619 !
2620 ! Check out parameter arrays to see if they are indexed correctly
2621 !
2622 IF BASE(Object,1)<>0 THEN
2623 Error_string$="Object(*) index must start at zero"
2624 GOSUB Icode_init_err
2625 END IF
2626 IF BASE(Source$,1)<>0 THEN
2627 Error_string$="Source(*) index must start at zero"
2628 GOSUB Icode_init_err
2629 END IF
2630 IF Enable_list_arg THEN
2631 IF BASE(List$,1)<>0 THEN
2632 Error_string$="Listing array index must start at zero"
2633 GOSUB Icode_init_err
2634 END IF
2635 ON ERROR GOTO Icode_list_lerr !List$(*) must be at least 80 chars wide
2636 List$(0)=RPT$(" ",80) ! Even though List$ elements have 80
2637 List$(0)="" ! chars doesn't mean that they are
2638 IF 0 THEN ! large enough.
2639 Icode_list_lerr:OFF ERROR
2640 Error_string$="List$(*) elements should be GREATER than 80 chars"
2641 Enable_list=0
2642 GOSUB Icode_init_err
2643 END IF
2644 END IF
2645 !
2646 GOSUB Icode_chk_info ! Check Info$(*) for correct dimensions
2647 !
2648 ! Do Pre-pass. Go through pseudo-op section of ICODE program and
2649 ! find out how large tables must be.
2650 !
2651 Var_tbl_size=0
2652 Blkvar_tbl_size=0
2653 Blkext_tbl_size=0
2654 Blkcon_tbl_size=0
2655 Const_tbl_size=0
2656 !
2657 DISP Disp_line$;" Doing Pre-pass."
2658 Icode_def_loop: ! Pre-pass: Just get table size info
2659 Enable_list=0 ! Disable listing for pre-pass.
2660 Def_loop_done=0
2661 REPEAT
2662 GOSUB Icode_next_line
2663 GOSUB Icode_skip_lbl
2664 GOSUB Icode_get_opcod
2665 GOSUB Icode_init_inst
2666 SELECT Opcode$
2667 CASE "VAR"
2668 Var_tbl_size=Var_tbl_size+1
2669 CASE "DEFBLK_VAR"
2670 Blkvar_tbl_size=Blkvar_tbl_size+1
2671 CASE "DEFBLK_SP","DEFBLK_MAIN","DEFBLK_EXT"
2672 Blkext_tbl_size=Blkext_tbl_size+2
2673 CASE "DEFBLK_CON"
2674 Blkcon_tbl_size=Blkcon_tbl_size+1
2675 CASE "CONST"
2676 Const_tbl_size=Const_tbl_size+1
2677 CASE "DEF_END"
2678 Def_loop_done=1
2679 CASE "LBL_TBL_SIZE"
2680 Enable_const=1
2681 GOSUB Icode_get_arg
2682 IF Missing_arg THEN
2683 Error_string$="Missing LBL_TBL_SIZE parameter"
2684 GOSUB Icode_err
2685 ELSE
2686 IF Arg>0 AND Arg<32767 THEN
2687 Lbl_tbl_size=Arg
2688 ELSE
2689 Error_string$="Invalid LBL_TBL_SIZE specification - '"&VAL$(Arg)&"'"
2690 GOSUB Icode_err
2691 END IF
2692 END IF
2693 CASE "FORLBL_TBL_SIZE"
2694 Enable_const=1
2695 GOSUB Icode_get_arg
2696 IF Missing_arg THEN
2697 Error_string$="Missing FORLBL_TBL_SIZE parameter"
2698 GOSUB Icode_err
2699 ELSE
2700 IF Arg>0 AND Arg<32767 THEN
2701 Forlbl_tbl_size=Arg
2702 ELSE
2703 Error_string$="Invalid FORLBL_TBL_SIZE specification - '"&VAL$(Arg)&"'"
2704 GOSUB Icode_err
2705 END IF
2706 END IF
2707 CASE "ERR_ABRT_COUNT"
2708 Enable_const=1
2709 GOSUB Icode_get_arg
2710 IF Missing_arg THEN
2711 Error_string$="Missing ERR_ABRT_COUNT parameter"
2712 GOSUB Icode_err
2713 ELSE
2714 IF Arg>0 AND Arg<1000 THEN
2715 Err_abrt_count=Arg
2716 ELSE
2717 Error_string$="Invalid ERR_ABRT_COUNT specification - '"&VAL$(Arg)&"'"
2718 GOSUB Icode_err
2719 END IF
2720 END IF
2721 CASE "ERR_DISP_LINES"
2722 Enable_const=1
2723 GOSUB Icode_get_arg
2724 IF Missing_arg THEN
2725 Error_string$="Missing ERR_DISP_LINES parameter"
2726 GOSUB Icode_err
2727 ELSE
2728 IF Arg>=0 AND Arg<100 THEN
2729 Err_disp_lines=Arg
2730 ELSE
2731 Error_string$="Invalid ERR_DISP_LINES specification - '"&VAL$(Arg)&"'"
2732 GOSUB Icode_err
2733 END IF
2734 END IF
2735 CASE ELSE
2736 CALL Icode_inst_str(Opcode$,Inst_info$)
2737 IF Inst_info$<>"-1" OR Opcode$="EL_COMPLETO" THEN Def_loop_done=1
2738 END SELECT
2739 GOSUB Icode_next_inst
2740 UNTIL Def_loop_done
2741 !
2742 Enable_list=Enable_list_arg ! Enable listing of so desired
2743 !
2744 GOSUB Icode_alloc_tbl ! Allocate all internal tables
2745 !
2746 Source_last=-1 ! reset pointer into source array
2747 List_last=-1 ! and listing array
2748 !
2749 ! Allocate variable space. Variable space needs to be allocated
2750 ! for all VAR, DEFBLK_VAR, DEFBLK_SP, DEFBLK_MAIN, and DEFBLK_EXT
2751 ! pseudo-ops. Don't forget, variables start at 2.
2752 DISP Disp_line$;" Allocating variable space."
2753 Icode_alloc_var:!
2754 Vars_allocated=Var_tbl_size+Blkvar_tbl_size+Blkext_tbl_size+2
2755 IF Vars_allocated<>0 THEN ! allocate room in ICODE prog for vars
2756 Object(0)=49 ! insert c_goto around variable space
2757 Object(1)=0 ! programs can't be greater than 32K
2758 Real_temp=Vars_allocated*2
2759 IF Real_temp>=Object_size THEN
2760 Error_string$="Object code array too small for required variable space"
2761 GOSUB Icode_fatal_err
2762 END IF
2763 Object(2)=Real_temp
2764 FOR I=3 TO Real_temp-1 ! Set all vars to 0. Dont' really need
2765 Object(I)=0 ! to do this.
2766 NEXT I
2767 Object_last=Real_temp-1
2768 END IF
2769 !
2770 ! Insert listing header into List$(*)
2771 !
2772 IF Enable_list THEN
2773 List_last=List_last+1
2774 IF List_last<List_size THEN
2775 ON ERROR GOTO Icode_list_len
2776 List$(List_last)="ICODE Assembler version "&Version$&". Assembled "&DATE$(TIMEDATE)&" "&TIME$(TIMEDATE)
2777 OFF ERROR
2778 IF 0 THEN
2779 Icode_list_len:OFF ERROR
2780 Error_string$="Listing lines need to be longer"
2781 Enable_list=0
2782 GOSUB Icode_fatal_err
2783 END IF
2784 ELSE
2785 Error_string$="Listing table overflow"
2786 GOSUB Icode_fatal_err
2787 END IF
2788 END IF
2789 !
2790 IF Info_info=2 THEN
2791 !
2792 ! For each instruction, an entry is made into Info$(*). Each entry
2793 ! consists of the address of the opcode and the source$(*) line
2794 ! index. Only need for the debugger. i.e. Info_info=2
2795 !
2796 Info_inst_base=Info_hdr_size
2797 Inst_cnt=0
2798 END IF
2799 !
2800 IF Enable_list_arg THEN
2801 DISP Disp_line$;" Assembling. Listing Enabled"
2802 ELSE
2803 DISP Disp_line$;" Assembling."
2804 END IF
2805 !
2806 ! This loop assembles the pseudo-op section of the ICODE program.
2807 ! This loop is terminated when a non-pseudo-op instruction is
2808 ! found.
2809 !
2810 Icode_tbl_loop:!
2811 Tbl_loop_done=0
2812 REPEAT
2813 GOSUB Icode_next_line ! find next instruction
2814 GOSUB Icode_skip_lbl ! don't really want to look at labels
2815 GOSUB Icode_get_opcod ! get Opcode$
2816 GOSUB Icode_init_inst ! Init ptrs for listing and errs
2817 SELECT Opcode$
2818 Icode_var:!
2819 CASE "VAR"
2820 Enable_const=0 ! Variable name may not be a CONST
2821 GOSUB Icode_get_arg ! returns Arg$, Arg, and Missing_arg
2822 IF Missing_arg OR Arg$="" THEN
2823 Error_string$="Missing variable name"
2824 GOSUB Icode_err
2825 ELSE
2826 Variable$=Arg$
2827 Enable_const=1 ! Init value may be a CONST
2828 GOSUB Icode_get_arg
2829 IF Missing_arg THEN
2830 Error_string$="Missing or invalid variable init value"
2831 GOSUB Icode_err
2832 ELSE
2833 IF Arg>Max_32_int OR Arg<Min_32_int THEN
2834 Error_string$="Invalid variable init value - '"&VAL$(Arg)&"'"
2835 GOSUB Icode_err
2836 ELSE
2837 IF Arg$[1;1]="@" THEN ! Is init val another variables var number
2838 Var_pos=FNIcode_search(Var_name$(*),Var_last,Arg$[2])
2839 IF Var_pos=-1 THEN
2840 Error_string$="Undefined variable reference - '"&Arg$[2]&"'"
2841 GOSUB Icode_err
2842 ELSE
2843 Arg=Var_num(Var_pos)
2844 END IF
2845 ELSE
2846 IF Arg$<>"" THEN
2847 Error_string$="Invalid variable init value - '"&Arg$&"'"
2848 GOSUB Icode_err
2849 END IF
2850 END IF
2851 END IF
2852 END IF
2853 IF Error_string$="" THEN
2854 Var_last=Var_last+1
2855 Last_alloc_var=Last_alloc_var+1
2856 Var_name$(Var_last)=Variable$
2857 Var_num(Var_last)=Last_alloc_var
2858 Lib_32_to_16(Arg,Int_hi,Int_lo)
2859 Object(Last_alloc_var*2)=Int_hi
2860 Object(Last_alloc_var*2+1)=Int_lo
2861 IF Enable_list THEN
2862 List$(Old_list_last)[1;15]=IVAL$(Last_alloc_var*2,16)&" "&IVAL$(Int_hi,16)&","&IVAL$(Int_lo,16)
2863 END IF
2864 END IF
2865 END IF
2866 Defblk_var:!
2867 CASE "DEFBLK_VAR"
2868 Enable_const=0 ! Block name may not be a CONST
2869 GOSUB Icode_get_arg ! returns Arg$, Arg and Missing_arg
2870 IF Missing_arg OR LEN(Arg$)=0 THEN
2871 Error_string$="Missing DEFBLK_VAR block name"
2872 GOSUB Icode_err
2873 ELSE
2874 Block_name$=Arg$
2875 Enable_const=1 ! Init value may be a CONST
2876 GOSUB Icode_get_arg
2877 IF Missing_arg OR Arg$<>"" THEN
2878 Error_string$="Missing or invalid DEFBLK_VAR init value"
2879 GOSUB Icode_err
2880 ELSE
2881 IF Arg>Max_32_int OR Arg<Min_32_int THEN
2882 Error_string$="Invalid DEFBLK_VAR init value - '"&VAL$(Arg)&"'"
2883 GOSUB Icode_err
2884 ELSE
2885 Blkvar_last=Blkvar_last+1
2886 Last_alloc_var=Last_alloc_var+1
2887 Blkvar_name$(Blkvar_last)=Block_name$
2888 Blkvar_id(Blkvar_last)=Last_alloc_var
2889 CALL Lib_32_to_16(Arg,Int_hi,Int_lo)
2890 Object(Last_alloc_var*2)=Int_hi
2891 Object(Last_alloc_var*2+1)=Int_lo
2892 IF Enable_list THEN
2893 List$(List_last)[1;15]=IVAL$(Last_alloc_var*2,16)&" "&IVAL$(Int_hi,16)&","&IVAL$(Int_lo,16)
2894 END IF
2895 END IF
2896 END IF
2897 END IF
2898 !
2899 Defblk_con:!
2900 CASE "DEFBLK_CON"
2901 Enable_const=0 ! Block_name may not be a CONST
2902 GOSUB Icode_get_arg ! returns Token$ and Error_flag
2903 IF Missing_arg OR LEN(Arg$)=0 THEN
2904 Error_string$="Missing DEFBLK_CON block name"
2905 GOSUB Icode_err
2906 ELSE
2907 Block_name$=Arg$
2908 Enable_const=1 ! block_id may be a CONST
2909 GOSUB Icode_get_arg
2910 IF Missing_arg OR Arg$<>"" THEN
2911 Error_string$="Missing or invalid DEFBLK_CON constant value"
2912 GOSUB Icode_err
2913 ELSE
2914 IF (Arg<=0 OR Arg>=32768) THEN
2915 Error_string$="Illegal DEFBLK_CON init value"
2916 GOSUB Icode_err
2917 ELSE
2918 IF Error_string$="" THEN
2919 Blkcon_last=Blkcon_last+1
2920 Blkcon_name$(Blkcon_last)=Block_name$
2921 Blkcon_id(Blkcon_last)=Arg
2922 IF Enable_list THEN List$(Old_list_last)[6;4]=IVAL$((Arg),16)
2923 END IF
2924 END IF
2925 END IF
2926 END IF
2927 !
2928 Defblk_main:!
2929 Defblk_sp:!
2930 CASE "DEFBLK_SP","DEFBLK_MAIN"
2931 IF Info_info=0 THEN
2932 Error_string$="Can't use "&Opcode$&" without Info$ array"
2933 GOSUB Icode_err
2934 ELSE
2935 Block_type=1
2936 IF Opcode$[8]="SP" THEN Block_type=2
2937 Enable_const=0 ! Block_name may not be a CONST
2938 GOSUB Icode_get_arg ! returns Arg$, Arg, and Missing_arg
2939 IF Missing_arg OR LEN(Arg$)=0 THEN
2940 Error_string$="Missing "&Opcode$&" block name"
2941 GOSUB Icode_err
2942 ELSE
2943 Block_name$=Arg$
2944 Enable_const=1 ! block_size may be a CONST
2945 GOSUB Icode_get_arg
2946 IF Missing_arg OR Arg$<>"" OR Arg<=0 OR Arg>Max_32_int THEN
2947 Error_string$="Missing or invalid "&Opcode$&" block size"
2948 GOSUB Icode_err
2949 ELSE
2950 Block_size=Arg
2951 Blkext_last=Blkext_last+1
2952 Last_alloc_var=Last_alloc_var+2
2953 Enable_const=1 ! header_block_size may be a CONST
2954 GOSUB Icode_get_arg
2955 IF Missing_arg OR Arg$<>"" OR Arg<0 THEN
2956 Error_string$="Missing or invalid "&Opcode$&" header size"
2957 GOSUB Icode_err
2958 ELSE
2959 Header_size=Arg
2960 END IF
2961 Blkext_name$(Blkext_last)=Block_name$
2962 Blkext_id(Blkext_last)=(Last_alloc_var-1)
2963 Blkext_type(Blkext_last)=Block_type
2964 Blkext_size(Blkext_last)=Block_size
2965 Blkext_hsize(Blkext_last)=Header_size
2966 IF Enable_list THEN
2967 List$(Old_list_last)[1;14]=IVAL$((Last_alloc_var-1)*2,16)&" ****,****"
2968 END IF
2969 END IF
2970 END IF
2971 END IF
2972 !
2973 Defblk_ext:!
2974 CASE "DEFBLK_EXT"
2975 Enable_const=0 ! block_name may not be a CONST
2976 GOSUB Icode_get_arg ! returns Arg$, Arg, and Missing_arg
2977 IF Missing_arg OR LEN(Arg$)=0 THEN
2978 Error_string$="Missing DEFBLK_EXT block name"
2979 GOSUB Icode_err
2980 ELSE
2981 Blkext_last=Blkext_last+1
2982 Last_alloc_var=Last_alloc_var+2
2983 Blkext_name$(Blkext_last)=Arg$
2984 Blkext_id(Blkext_last)=(Last_alloc_var-1)
2985 Blkext_type(Blkext_last)=0
2986 Blkext_size(Blkext_last)=-1
2987 Blkext_hsize(Blkext_last)=-1
2988 IF Enable_list THEN
2989 List$(Old_list_last)[1;14]=IVAL$((Last_alloc_var-1)*2,16)&" ****,****"
2990 END IF
2991 END IF
2992 !
2993 Const:!
2994 CASE "CONST"
2995 DIM Constant_name$[16]
2996 Enable_const=0 ! New CONST_name may not be a CONST
2997 GOSUB Icode_get_arg ! returns Arg$, Arg, and Missing_arg
2998 IF Missing_arg OR LEN(Arg$)=0 THEN
2999 Error_string$="Missing CONST constant name"
3000 GOSUB Icode_err
3001 ELSE
3002 Constant_name$=Arg$
3003 Enable_const=1 ! CONST value may be a CONST
3004 GOSUB Icode_get_arg
3005 IF Missing_arg OR LEN(Arg$)<>0 OR Arg<Min_32_int OR Arg>Max_32_int THEN
3006 Error_string$="Missing or invalid CONST constant value"
3007 GOSUB Icode_err
3008 ELSE
3009 Const_last=Const_last+1
3010 Const_name$(Const_last)=Constant_name$
3011 Const_val(Const_last)=Arg
3012 IF Enable_list THEN List$(Old_list_last)[6;9]=IVAL$((Arg),16)
3013 END IF
3014 END IF
3015 CASE "ERR_ABRT_COUNT","ERR_DISP_LINES","LBL_TBL_SIZE","FORLBL_TBL_SIZE"
3016 GOSUB Icode_get_arg ! This is a dummy get arg
3017 CASE "DEF_END"
3018 Tbl_loop_done=1
3019 CASE ELSE
3020 CALL Icode_inst_str(Opcode$,Inst_info$)
3021 IF Inst_info$<>"-1" OR Opcode$="EL_COMPLETO" OR Opcode$="ASM_OFF" THEN
3022 Tbl_loop_done=1
3023 GOSUB Icode_back_line
3024 ELSE
3025 IF POS(Opcode$,",")<>0 THEN
3026 Error_string$="Unexpected comma - '"&Opcode$[1,MIN(20,LEN(Opcode$))]&"'"
3027 ELSE
3028 Error_string$="Undefined pseudo-op - '"&Opcode$[1,MIN(20,LEN(Opcode$))]&"'"
3029 END IF
3030 Enable_list=0
3031 GOSUB Icode_fatal_err
3032 END IF
3033 END SELECT
3034 IF Error_string$="" AND Line$<>"" AND NOT Tbl_loop_done THEN
3035 Error_string$="Extraneous argument - '"&Line$[1,MIN(20,LEN(Line$))]&"'"
3036 GOSUB Icode_err
3037 END IF
3038 Here:!
3039 Error_string$=""
3040 UNTIL Tbl_loop_done
3041 !
3042 ! This is the main assembly loop
3043 !
3044 Icode_asm_loop:!
3045 Asm_loop_done=0
3046 REPEAT
3047 Error_string$=""
3048 !
3049 GOSUB Icode_next_line
3050 !
3051 IF Line$="EL_COMPLETO" THEN
3052 Asm_loop_done=1
3053 ELSE
3054 !
3055 IF Info_info=2 THEN GOSUB Icode_insrt_nop
3056 !
3057 IF Line$[1;1]="." THEN
3058 Error_string$="Not expecting continuation line"
3059 GOSUB Icode_err
3060 ELSE
3061 GOSUB Icode_check_lbl ! check for line label
3062 GOSUB Icode_get_opcod ! returns Opcode$
3063 GOSUB Icode_init_inst ! init ptrs for listing and errs
3064 !
3065 ! Get information about instruction. Opcode and parameters.
3066 !
3067 CALL Icode_inst_str(Opcode$,Inst_info$)
3068 Opcode_num=VAL(Inst_info$)
3069 !
3070 IF Opcode_num=-1 THEN
3071 IF Opcode$="ASM_OFF" THEN
3072 IF Info_info=2 THEN GOSUB Icode_info_isrt
3073 GOSUB Icode_asm_off
3074 GOSUB Icode_end_inst
3075 IF Error_string$="" AND Line$<>"" THEN
3076 Error_string$="Extraneous argument - '"&Line$[1,MIN(20,LEN(Line$))]&"'"
3077 GOSUB Icode_err
3078 END IF
3079 ELSE
3080 Error_string$="Undefined Opcode - '"&Opcode$[1,MIN(20,LEN(Opcode$))]&"'"
3081 GOSUB Icode_err
3082 END IF
3083 END IF
3084 !
3085 IF Opcode_num<>-1 THEN
3086 Add_object=Opcode_num ! add opcode to object array
3087 GOSUB Icode_add_obj
3088 !
3089 ! Put address of opcode and source line # into Info$(*).
3090 !
3091 IF Info_info=2 THEN GOSUB Icode_info_isrt
3092 !
3093 IF Error_string$="" THEN
3094 Inst_info_ptr=POS(Inst_info$," ") ! skip opcode field
3095 IF Inst_info_ptr<>0 THEN
3096 REPEAT
3097 Inst_info_ptr=Inst_info_ptr+1 ! look at next parm char
3098 SELECT Inst_info$[Inst_info_ptr;1]
3099 CASE "L" ! Label
3100 GOSUB Icode_get_label
3101 CASE "P"
3102 GOSUB Icode_get_param ! 16 bit immediate integer
3103 CASE "B" ! CONST or VAR
3104 GOSUB Icode_get_block ! DEFBLK_xxxx
3105 CASE "V"
3106 GOSUB Icode_get_var
3107 CASE "I" ! 32 bit immediate integer
3108 GOSUB Icode_get_int ! or CONST
3109 CASE "S" ! 'String'
3110 GOSUB Icode_get_str
3111 CASE "F" ! Floating point
3112 GOSUB Icode_get_float
3113 CASE "M" ! 16 bit immediate integer
3114 GOSUB Icode_get_immed
3115 CASE "R" ! Instruction has a repeating
3116 GOSUB Icode_rpt_str ! field.
3117 CASE "@" ! Instruction has more than one
3118 GOSUB Icode_mlty_inst ! form depending on last field.
3119 END SELECT
3120 UNTIL Inst_info_ptr=LEN(Inst_info$)
3121 !
3122 IF Error_string$="" AND Line$<>"" THEN
3123 Error_string$="Extraneous argument - '"&Line$[1,MIN(20,LEN(Line$))]&"'"
3124 GOSUB Icode_err
3125 END IF
3126 END IF
3127 END IF
3128 GOSUB Icode_end_inst
3129 END IF ! If Opcode_num<>-1
3130 END IF
3131 END IF
3132 UNTIL Asm_loop_done
3133 !
3134 ! See if there are any unresolved forward references.
3135 !
3136 GOSUB Icode_forlbl_ck
3137 !
3138 Object_last=Object_last+1 ! HP-IB module needs extra word in prog block
3139 !
3140 GOSUB Icode_fill_info ! Fill Info$(*) with tons of stuff
3141 GOSUB Icode_asm_exit ! Final clean up and exit
3142 !
3143 ! ************ Assembler GOSUB Subroutines ***********************
3144 !
3145 Icode_subs:!
3146 IF 0 THEN
3147 !
3148 ! This subroutine is used to repeat a section of the instruction info
3149 ! string. The substring between the parameter code 'R' and the next
3150 ! '!' is repeated <count> times. <count> is specified by the last
3151 ! 16 bit value places in the object array.
3152 !
3153 Icode_rpt_str:!
3154 Repeat_count=Object(Object_last)
3155 IF Repeat_count<0 THEN
3156 Error_string$="Variable reference in immediate parameter field"
3157 GOSUB Icode_err
3158 ELSE
3159 Num_parms=POS(Inst_info$[Inst_info_ptr+1],"!")-1
3160 Repeat_str$=Inst_info$[Inst_info_ptr+1;Num_parms]
3161 Inst_info$=Inst_info$[1,Inst_info_ptr]&RPT$(Repeat_str$,Repeat_count)&Inst_info$[Inst_info_ptr+Num_parms+2]
3162 END IF
3163 RETURN
3164 !
3165 ! This subroutine is used to select a section of the instruction
3166 ! parameter string. When the first '@' is found, the last value
3167 ! added to Object(*) is used as a select value. The select value
3168 ! is used to select a section of the instruction parameter string.
3169 ! The section to be used is delimited by '@<select_value>' and
3170 ! the next '@' or end of string.
3171 !
3172 Icode_mlty_inst:!
3173 Rel_ptr=POS(Inst_info$[Inst_info_ptr],VAL$(Object(Object_last)))
3174 IF Rel_ptr=0 THEN
3175 Error_string$="Invalid f_ready_ram <monitor> field"
3176 GOSUB Icode_err
3177 ELSE
3178 Inst_info$=Inst_info$[Inst_info_ptr+Rel_ptr-1]
3179 Inst_info_ptr=1
3180 Rel_ptr=POS(Inst_info$,"@")
3181 IF Rel_ptr<>0 THEN Inst_info$=Inst_info$[1,Rel_ptr-1]
3182 END IF
3183 RETURN
3184 !
3185 ! This subroutine is used to insert information about the current
3186 ! instruction into Info$(*). The current opcode number and
3187 ! opcode Source(*) address are inserted into Info$(*). This is
3188 ! used by the debugger. This subroutine is only called if
3189 ! Info_info=2
3190 !
3191 Icode_info_isrt:!
3192 ON ERROR GOTO Icode_isrt_err
3193 OUTPUT Temp$ USING "#,W,W";Old_object_last+1,Old_source_last
3194 Info$(Info_inst_base+Inst_cnt DIV 10)[((Inst_cnt MOD 10)*4)+1;4]=Temp$
3195 Inst_cnt=Inst_cnt+1
3196 !
3197 IF 0 THEN
3198 Icode_isrt_err:!
3199 Error_string$="Info$ array not large enough"
3200 GOSUB Icode_fatal_err
3201 END IF
3202 !
3203 OFF ERROR
3204 RETURN
3205 !
3206 ! This subroutine is used to insert a c_nop before each user
3207 ! instruction. The debugger needs this. This subroutine should
3208 ! only be called if Info_info=2.
3209 !
3210 Icode_insrt_nop:!
3211 IF Enable_list THEN
3212 List_last=List_last+1
3213 IF List_last>=List_size THEN
3214 Error_string$="Listing table overflow"
3215 GOSUB Icode_fatal_err
3216 ELSE
3217 List$(List_last)=RPT$(" ",15)&RPT$(" ",15)&"<c_nop>"
3218 END IF
3219 END IF
3220 GOSUB Icode_init_inst
3221 Add_object=61 ! insert c_nop
3222 GOSUB Icode_add_obj
3223 RETURN
3224 !
3225 ! This instruction is used to init listing and error pointers
3226 ! to a new instruction state.
3227 !
3228 Icode_init_inst:!
3229 INTEGER Use_left_field,Add_stars
3230 Use_left_field=1
3231 Add_stars=0
3232 List_ptr=List_last
3233 Old_object_last=Object_last
3234 Old_source_last=Source_last
3235 Old_list_last=List_last
3236 Old_forlbl_last=Forlbl_last
3237 Error_string$=""
3238 RETURN
3239 !
3240 ! This subroutine is used to clean up the List_last pointer after
3241 ! an instruction has been assembled. List_ptr is used by the
3242 ! Icode_add_obj subroutine to insert parameter values into the
3243 ! listing. The Icode_next_line subroutine uses List_last.
3244 !
3245 Icode_end_inst:!
3246 IF Enable_list THEN
3247 IF Use_left_field THEN
3248 IF List_ptr-1>List_last THEN List_last=List_ptr-1
3249 ELSE
3250 IF List_ptr>List_last THEN List_last=List_ptr
3251 END IF
3252 END IF
3253 RETURN
3254 !
3255 ! Input parameter: INTEGER Add_object, INTEGER Add_stars
3256 !
3257 ! This subroutine is used to add a opcode or parameter value to
3258 ! the object array. This routine also puts this value into the
3259 ! listing. If Add_stars is set, then '****' is put into the listing
3260 ! instead of the Add_object value.
3261 !
3262 Icode_add_obj:!
3263 Object_last=Object_last+1
3264 IF Object_last>=Object_size THEN
3265 Error_string$="Object(*) array overflow"
3266 GOSUB Icode_fatal_err
3267 END IF
3268 Object(Object_last)=Add_object
3269 IF Enable_list THEN
3270 IF List_ptr>=List_size THEN
3271 Error_string$="Listing table overflow"
3272 GOSUB Icode_fatal_err
3273 List_last=List_size-2
3274 ELSE
3275 IF Use_left_field THEN
3276 List$(List_ptr)[1;4]=IVAL$(Object_last,16)
3277 IF Add_stars THEN
3278 List$(List_ptr)[5;5]=" ****"
3279 ELSE
3280 List$(List_ptr)[5;5]=" "&IVAL$(Add_object,16)
3281 END IF
3282 Use_left_field=0
3283 ELSE
3284 IF Add_stars THEN
3285 List$(List_ptr)[10;5]=",****"
3286 ELSE
3287 List$(List_ptr)[10;5]=","&IVAL$(Add_object,16)
3288 END IF
3289 List_ptr=List_ptr+1
3290 Use_left_field=1
3291 END IF
3292 END IF
3293 END IF
3294 RETURN
3295 !
3296 ! This subroutine is called when an error occurs initialization.
3297 !
3298 Icode_init_err:!
3299 OUTPUT CRT
3300 FOR I=MAX(0,Source_last-Err_disp_lines) TO MIN(Source_last,Source_size-1)
3301 OUTPUT CRT;Source$(I)
3302 NEXT I
3303 GOSUB Icode_fatal_err
3304 RETURN
3305 !
3306 ! This subroutine is called when an error causes the assembler
3307 ! to quit assembling.
3308 !
3309 Icode_fatal_err:!
3310 Error_count=Error_count+1
3311 Enable_list=Enable_list_arg
3312 IF Enable_list THEN
3313 ON ERROR GOTO Icode_err_skip
3314 List_last=List_last+1
3315 IF List_last<List_size-1 THEN
3316 List$(List_last)="***** FATAL ERROR: "&Error_string$&" *****"
3317 ELSE
3318 List_last=List_size-2
3319 List$(MAX(0,List_last))="***** FATAL ERROR: "&Error_string$&" *****"
3320 END IF
3321 OFF ERROR
3322 END IF
3323 Icode_err_skip:Enable_list=0
3324 OFF ERROR
3325 OUTPUT CRT;"***** FATAL ERROR: "&Error_string$;" *****"
3326 GOTO Icode_asm_exit
3327 RETURN
3328 !
3329 ! This routine is called when routine error occurs.
3330 !
3331 Icode_err:!
3332 Error_count=Error_count+1
3333 !
3334 Object_last=Old_object_last ! reset Object(*) ptr
3335 Forlbl_last=Old_forlbl_last ! reset forward reference ptr
3336 !
3337 Use_left_field=1
3338 Add_object=-1 ! overwrite opcode with -1
3339 GOSUB Icode_add_obj
3340 !
3341 Inst_info_ptr=LEN(Inst_info$) ! don't get any more parms
3342 !
3343 IF Enable_list THEN ! clean up listing
3344 List$(Old_list_last)[6,15]="FFFF "
3345 FOR I=Old_list_last+1 TO List_last
3346 List$(I)[1;15]=RPT$(" ",15)
3347 NEXT I
3348 List_last=List_last+1
3349 List$(List_last)=RPT$(" ",15)&"***** ERROR: "&Error_string$&" *****"
3350 END IF
3351 !
3352 ! Print out section of source code on CRT
3353 !
3354 OUTPUT CRT
3355 FOR I=MAX(Old_source_last-Err_disp_lines,0) TO MIN(Source_last,Source_size-1)
3356 OUTPUT CRT;Source$(I)
3357 NEXT I
3358 OUTPUT CRT;"***** ERROR: ";Error_string$;" *****"
3359 !
3360 IF Error_count>Err_abrt_count THEN ! See if there are too many errors
3361 Error_string$="ICODE program has many problems"
3362 GOSUB Icode_fatal_err
3363 ELSE
3364 GOSUB Icode_next_inst
3365 END IF
3366 RETURN
3367 !
3368 ! This subroutine is used to find the next line with a new
3369 ! instruction on it.
3370 !
3371 Icode_next_inst:!
3372 REPEAT
3373 GOSUB Icode_next_line
3374 UNTIL Line$[1,1]<>"."
3375 GOSUB Icode_back_line
3376 RETURN
3377 !
3378 ! This subroutine is used by the pre-pass to skip labels.
3379 ! Labels are looked at in the main assembly loop.
3380 !
3381 Icode_skip_lbl:!
3382 Line_ptr=POS(Line$[1,17],":")
3383 IF Line_ptr<>0 THEN Line$=TRIM$(Line$[Line_ptr+1])
3384 RETURN
3385 !
3386 ! This subroutine is used to see if the current line has a label
3387 ! on it. If it does, then it is added to the label table. Then
3388 ! the forward reference table is searched. Each instance of a
3389 ! forward reference to the newly found label is then resolved.
3390 !
3391 Icode_check_lbl:! check for label in line$
3392 REPEAT
3393 Line_ptr=POS(Line$[1,17],":")
3394 IF Line_ptr<>0 THEN ! looks like we have a label
3395 !
3396 Label$=Line$[1,Line_ptr-1]
3397 Line$=TRIM$(Line$[Line_ptr+1])
3398 !
3399 Lbl_last=Lbl_last+1
3400 IF Lbl_last<Lbl_tbl_size THEN
3401 Lbl_name$(Lbl_last)=Label$
3402 !
3403 ! If Info_info=2 then the label must point to the c_nop
3404 ! that was inserted before this instruction.
3405 !
3406 IF Info_info=2 THEN
3407 Lbl_loc(Lbl_last)=Object_last
3408 Lbl_src_loc(Lbl_last)=Source_last
3409 ELSE
3410 Lbl_loc(Lbl_last)=Object_last+1
3411 END IF
3412 ELSE
3413 Error_string$="Label table overflow"
3414 GOSUB Icode_err
3415 RETURN
3416 END IF
3417 !
3418 ! Now, resolve all unresolved references to this label
3419 !
3420 REPEAT
3421 Forlbl_pos=FNIcode_search(Forlbl_name$(*),Forlbl_last,Label$)
3422 IF Forlbl_pos<>-1 THEN
3423 !
3424 ! Found forward reference to this label. Resolve it.
3425 !
3426 Int_hi=0 ! hi word must be zero
3427 Int_lo=Lbl_loc(Lbl_last) ! use same addr as put in lbl table
3428 Object(Forlbl_loc(Forlbl_pos))=Int_hi ! Addr hi
3429 Object(Forlbl_loc(Forlbl_pos)+1)=Int_lo ! Addr lo
3430 !
3431 ! Move last element in forward reference list into this pos
3432 !
3433 Forlbl_name$(Forlbl_pos)=Forlbl_name$(Forlbl_last)
3434 Forlbl_loc(Forlbl_pos)=Forlbl_loc(Forlbl_last)
3435 !
3436 IF Enable_list THEN ! Must also fill in listing.
3437 IF Forlbl_list_lft(Forlbl_pos) THEN
3438 List$(Forlbl_list_pos(Forlbl_pos))[6;9]=IVAL$(Int_hi,16)&","&IVAL$(Int_lo,16)
3439 ELSE
3440 List$(Forlbl_list_pos(Forlbl_pos))[10;5]=","&IVAL$(Int_hi,16)
3441 List$(Forlbl_list_pos(Forlbl_pos)+1)[6;5]=IVAL$(Int_lo,16)
3442 END IF
3443 Forlbl_list_lft(Forlbl_pos)=Forlbl_list_lft(Forlbl_last)
3444 Forlbl_list_pos(Forlbl_pos)=Forlbl_list_pos(Forlbl_last)
3445 END IF
3446 Forlbl_last=Forlbl_last-1 ! One less forward reference now
3447 END IF
3448 UNTIL Forlbl_pos=-1
3449 END IF
3450 !
3451 ! If label was only thing on line, then we still need to check for
3452 ! a label on the next line.
3453 IF Line$="" THEN
3454 IF Enable_list THEN List$(List_last)[1;4]=IVAL$(Object_last+1,16)
3455 GOSUB Icode_next_line
3456 Line_ptr=POS(Line$[1,17],":")
3457 END IF
3458 UNTIL Line$<>"" AND Line$<>"EL_COMPLETO" AND Line_ptr=0
3459 RETURN
3460 !
3461 ! This subroutine is used to get Opcode$ out of the current input
3462 ! line.
3463 !
3464 Icode_get_opcod:!
3465 Line_ptr=POS(Line$," ")
3466 IF Line_ptr=0 THEN
3467 Opcode$=Line$[1,MIN(20,LEN(Line$))]
3468 Line$=""
3469 ELSE
3470 Opcode$=Line$[1,MIN(Line_ptr-1,20)]
3471 Line$=TRIM$(Line$[Line_ptr+1])
3472 END IF
3473 RETURN
3474 !
3475 ! This subroutine is used when the next parameter in the current
3476 ! instruction is an ICODE address (c_goto label_name). Note that
3477 ! must be a string. i.e. not absolute jumps.
3478 !
3479 Icode_get_label:!
3480 Enable_const=0 ! Label field may not be a CONST
3481 GOSUB Icode_get_arg
3482 IF Arg$="" THEN
3483 Error_string$="Missing label specification"
3484 GOSUB Icode_err
3485 ELSE
3486 !
3487 ! Search label table
3488 !
3489 Lbl_pos=FNIcode_search(Lbl_name$(*),Lbl_last,Arg$)
3490 IF Lbl_pos<>-1 THEN ! found it
3491 Add_object=0
3492 GOSUB Icode_add_obj
3493 Add_object=Lbl_loc(Lbl_pos)
3494 GOSUB Icode_add_obj
3495 ELSE
3496 Forlbl_last=Forlbl_last+1 ! insert in forward reference table
3497 Forlbl_name$(Forlbl_last)=Arg$
3498 Forlbl_loc(Forlbl_last)=Object_last+1
3499 IF Enable_list THEN
3500 Forlbl_list_pos(Forlbl_last)=List_ptr
3501 Forlbl_list_lft(Forlbl_last)=Use_left_field
3502 END IF
3503 Add_stars=1 ! put stars in listing until this
3504 Add_object=0 ! reference is resolved.
3505 GOSUB Icode_add_obj
3506 Add_object=0
3507 GOSUB Icode_add_obj
3508 Add_stars=0
3509 END IF
3510 END IF
3511 RETURN
3512 !
3513 ! Input: Enable_const
3514 ! Output: Arg$, REAL Arg, INTEGER Missing_arg
3515 !
3516 ! This routine is used to get the next parameter from the Source$(*)
3517 ! array. The next parameter may be on the current line or on a
3518 ! continuation line. The next parameter may be terminated by a
3519 ! space, comma or an end-of-line. If the parameter is itself a
3520 ! numerical value, either decimal or hex ($<hex_num>), then Arg is
3521 ! set to the value and Arg$="". If the parameter isn't a numerical
3522 ! value then Arg is undefined and Arg$ is set the the parameter
3523 ! string. If Enable_const is active, then the CONST table is searched
3524 ! to see if Arg$ is defined.
3525 !
3526 Icode_get_arg: ! returns Arg$, Arg and Missing_arg
3527 Missing_arg=0
3528 WHILE Line$=""
3529 GOSUB Get_cont_line ! returns Line$ and Missing_arg
3530 END WHILE
3531 IF Missing_arg THEN
3532 Arg$=""
3533 Arg=-1
3534 ELSE
3535 Line_ptr=POS(Line$,",") ! Is there a comma delimiter
3536 IF Line_ptr=0 THEN ! Nope
3537 Line_ptr=POS(Line$," ")
3538 IF Line_ptr=0 THEN
3539 Arg$=Line$
3540 Line$=""
3541 ELSE
3542 Arg$=Line$[1,MIN(16,Line_ptr-1)]
3543 Line$=TRIM$(Line$[Line_ptr+1])
3544 END IF
3545 ELSE ! Yup
3546 Int_temp=POS(Line$," ") ! Now see if there is a space between
3547 ! the end of the param and the comma.
3548 IF Int_temp<>0 THEN Line_ptr=MIN(Int_temp,Line_ptr) ! Yes
3549 Arg$=TRIM$(Line$[1,MIN(16,Line_ptr-1)])
3550 IF Arg$="" THEN
3551 Missing_arg=1
3552 ELSE
3553 IF Line$[Line_ptr;1]="," THEN ! Remove Arg$ from Line$
3554 Line$=TRIM$(Line$[Line_ptr+1])
3555 ELSE
3556 Line$=TRIM$(Line$[Line_ptr+1])
3557 IF Line$[1,1]="," THEN Line$=TRIM$(Line$[2])
3558 END IF
3559 END IF
3560 END IF
3561 ! See if Arg$ has a
3562 CALL Icode_eval_str(Arg$,Arg,Missing_arg) ! numerical value.
3563 IF Arg$<>"" AND Enable_const THEN
3564 Const_pos=FNIcode_search(Const_name$(*),Const_last,Arg$)
3565 IF Const_pos<>-1 THEN
3566 Arg=Const_val(Const_pos)
3567 Arg$=""
3568 END IF
3569 END IF
3570 END IF
3571 RETURN
3572 !
3573 ! Output: Line$, Missing_arg
3574 !
3575 ! This subroutine is used to get a continuation line from the Source$(*)
3576 ! array. If the next line isn't a continuation line (first non space
3577 ! char on line must be '.'), then Missing_arg is set true.
3578 !
3579 Get_cont_line:!
3580 INTEGER Done_cont_line
3581 Done_cont_line=0
3582 REPEAT
3583 GOSUB Icode_next_line ! returns Line$ and Skipped_lines
3584 IF Line$[1,1]<>"." OR Skipped_lines>0 THEN
3585 Missing_arg=1
3586 GOSUB Icode_back_line
3587 Done_cont_line=1
3588 ELSE
3589 Line$=TRIM$(Line$[2])
3590 IF LEN(Line$)>=1 THEN Done_cont_line=1
3591 END IF
3592 UNTIL Done_cont_line
3593 RETURN
3594 !
3595 ! This subroutine is used to move back one line in the Source$(*)
3596 ! array and the List$(*) array.
3597 !
3598 Icode_back_line:!
3599 Source_last=Source_last-1
3600 IF Enable_list THEN
3601 List$(List_last)=""
3602 List_last=List_last-1
3603 END IF
3604 RETURN
3605 !
3606 ! Output: Line$ and Skipped_lines
3607 !
3608 ! This subroutine is used to get the next source line. It check
3609 ! to see when the end of the Source$(*) array has been found. If
3610 ! so, then Line$="EL_COMPLETO".
3611 !
3612 Icode_next_line:!
3613 INTEGER Skipped_lines
3614 Skipped_lines=-1
3615 REPEAT
3616 Skipped_lines=Skipped_lines+1
3617 Source_last=Source_last+1
3618 IF Source_last>=Source_size THEN
3619 Line$="EL_COMPLETO"
3620 ELSE
3621 Line$=Source$(Source_last)
3622 END IF
3623 ! Insert line into List$(*)
3624 IF Enable_list THEN
3625 List_last=List_last+1
3626 IF List_last>=List_size THEN
3627 List_last=List_size-2
3628 Error_string$="Listing table overflow"
3629 GOSUB Icode_fatal_err
3630 END IF
3631 List_line_len=LEN(List$(List_last))
3632 ON ERROR GOTO Icode_lstr_smal ! List$ elements may be too small
3633 IF List_line_len=0 THEN
3634 List$(List_last)=RPT$(" ",15)&Line$
3635 ELSE
3636 IF List_line_len<=15 THEN List$(List_last)=List$(List_last)&RPT$(" ",15-List_line_len)&Line$
3637 END IF
3638 OFF ERROR
3639 END IF
3640 !
3641 ! Strip off comments. This assumes no '!' inside string parameter.
3642 ! Also, convert everything to upper case.
3643 !
3644 Line_ptr=POS(Line$,"!")
3645 IF Line_ptr<>0 THEN
3646 Line$=UPC$(TRIM$(Line$[1,Line_ptr-1]))
3647 ELSE
3648 Line$=UPC$(TRIM$(Line$))
3649 END IF
3650 UNTIL LEN(Line$)<>0
3651 ! If an error occurs during the assignment of
3652 IF 0 THEN ! Line$ to List$( ), then a jump is made to
3653 Icode_lstr_smal:OFF ERROR ! this section of code.
3654 Error_string$="List$(*) lines need to be longer"
3655 GOSUB Icode_fatal_err
3656 END IF
3657 RETURN
3658 !
3659 Icode_asm_off: ! This routine is used to put semi-unassembled
3660 INTEGER Arg_count ! data into the program. The first field after
3661 INTEGER Current_arg ! ASM_OFF is the count and must be immediate,
3662 Enable_const=1 ! or CONST The next <count> fields must be
3663 GOSUB Icode_get_arg ! immediate, CONST, VAR.
3664 IF Missing_arg THEN
3665 Error_string$="Expecting ASM_OFF parameter count"
3666 GOSUB Icode_err
3667 RETURN
3668 END IF
3669 IF Arg$<>"" THEN
3670 Error_string$="ASM_OFF parameter count must be immediate"
3671 GOSUB Icode_err
3672 RETURN
3673 END IF
3674 IF Arg<1 OR Arg>100 THEN
3675 Error_string$="Invalid ASM_OFF parameter count field"
3676 GOSUB Icode_err
3677 RETURN
3678 END IF
3679 Arg_count=Arg
3680 FOR Current_arg=1 TO Arg_count
3681 Enable_const=1
3682 GOSUB Icode_get_arg
3683 IF Missing_arg THEN
3684 Error_string$="Expecting ASM_OFF parameter"
3685 GOSUB Icode_err
3686 RETURN
3687 END IF
3688 IF Arg$<>"" THEN ! and VARs may also be in the data stream.
3689 IF Arg$[1;1]="@" THEN
3690 Var_pos=FNIcode_search(Var_name$(*),Var_last,Arg$[2])
3691 IF Var_pos<>-1 THEN
3692 Arg=-(Var_num(Var_pos)+16384)
3693 ELSE
3694 Error_string$="Indirect variable undefined - '"&Arg$[2]&"'"
3695 GOSUB Icode_err
3696 RETURN
3697 END IF
3698 ELSE
3699 Var_pos=FNIcode_search(Var_name$(*),Var_last,Arg$)
3700 IF Var_pos<>-1 THEN
3701 Arg=-Var_num(Var_pos)
3702 ELSE
3703 Error_string$="Undefined symbol - '"&Arg$&"'"
3704 GOSUB Icode_err
3705 RETURN
3706 END IF
3707 END IF
3708 END IF
3709 IF Arg>Max_16_int OR Arg<Min_16_int THEN
3710 Error_string$="Invalid ASM_OFF parameter value - '"&VAL$(Arg)&"'"
3711 GOSUB Icode_err
3712 RETURN
3713 END IF
3714 Add_object=Arg
3715 GOSUB Icode_add_obj
3716 NEXT Current_arg
3717 RETURN
3718 !
3719 ! This subroutine is used to assemble a 32 bit integer parameter from
3720 ! from the source code. The parameter must be a CONST reference or
3721 ! an immediate in line value.
3722 !
3723 Icode_get_int:!
3724 Enable_const=1
3725 GOSUB Icode_get_arg
3726 IF Missing_arg THEN
3727 Error_string$="Missing 32 bit integer parameter"
3728 GOSUB Icode_err
3729 RETURN
3730 END IF
3731 IF Arg$<>"" THEN
3732 Error_string$="Undefined CONST - '"&Arg$&"'"
3733 GOSUB Icode_err
3734 RETURN
3735 END IF
3736 IF Arg>Max_32_int OR Arg<Min_32_int THEN
3737 Error_string$="Invaid integer parameter - '"&VAL$(Arg)&"'"
3738 GOSUB Icode_err
3739 RETURN
3740 END IF
3741 CALL Lib_32_to_16(Arg,Int_hi,Int_lo)
3742 Add_object=Int_hi
3743 GOSUB Icode_add_obj
3744 Add_object=Int_lo
3745 GOSUB Icode_add_obj
3746 RETURN
3747 !
3748 ! This subroutine is used to assemble a 16 bit integer parameter from
3749 ! from the source code. The parameter must be a CONST reference or
3750 ! an immediate in line value.
3751 !
3752 Icode_get_immed:!
3753 Enable_const=1
3754 GOSUB Icode_get_arg
3755 IF Missing_arg THEN
3756 Error_string$="Missing immediate data parameter"
3757 GOSUB Icode_err
3758 RETURN
3759 END IF
3760 IF Arg$<>"" OR Arg>Max_16_int OR Arg<Min_16_int THEN
3761 IF Arg$<>"" THEN
3762 Error_string$="Invalid immediate parameter - '"&Arg$[1,MIN(20,LEN(Arg$))]&"'"
3763 ELSE
3764 Error_string$="Invalid immediate parameter - '"&VAL$(Arg)&"'"
3765 END IF
3766 GOSUB Icode_err
3767 RETURN
3768 END IF
3769 Add_object=Arg
3770 GOSUB Icode_add_obj
3771 RETURN
3772 !
3773 ! This subroutine is used to assemble an immediate floating point
3774 ! number from the source code. Number may also be a CONST
3775 !
3776 Icode_get_float:!
3777 INTEGER I1,I2,I3,I4
3778 Enable_const=1
3779 GOSUB Icode_get_arg
3780 IF Missing_arg THEN
3781 Error_string$="Missing floating point parameter"
3782 GOSUB Icode_err
3783 RETURN
3784 END IF
3785 IF Arg$<>"" THEN
3786 Error_string$="Undefined floating point CONST - '"&Arg$&"'"
3787 GOSUB Icode_err
3788 RETURN
3789 END IF
3790 CALL Lib_float_to_64(Arg,I1,I2,I3,I4)
3791 Add_object=I1
3792 GOSUB Icode_add_obj
3793 Add_object=I2
3794 GOSUB Icode_add_obj
3795 Add_object=I3
3796 GOSUB Icode_add_obj
3797 Add_object=I4
3798 GOSUB Icode_add_obj
3799 RETURN
3800 !
3801 ! This routine is used to assemble a string parameter. This string
3802 ! must be between single quotes. ICODE instructions that call for
3803 ! a string parameter also call for a string length word. The
3804 ! assembler will count the length of the string and insert the string
3805 ! length field for the user.
3806 !
3807 Icode_get_str:!
3808 INTEGER Str_len
3809 Missing_arg=0
3810 WHILE Line$=""
3811 GOSUB Get_cont_line
3812 END WHILE
3813 IF Missing_arg THEN
3814 Error_string$="Missing string parameter"
3815 GOSUB Icode_err
3816 RETURN
3817 END IF
3818 IF Line$[1;1]<>"'" THEN
3819 Error_string$="Missing first ' in string parameter"
3820 GOSUB Icode_err
3821 ELSE
3822 Line$=Line$[2]
3823 Str_len=POS(Line$,"'")
3824 IF Str_len=0 THEN
3825 Error_string$="Missing second ' in string parameter"
3826 GOSUB Icode_err
3827 ELSE
3828 Str_len=Str_len-1
3829 Arg$=Line$[1,Str_len]
3830 Line$=Line$[Str_len+2]
3831 IF Str_len MOD 2=1 THEN
3832 Arg$=Arg$&" " ! string should fall on word boundary
3833 Str_len=Str_len+1
3834 END IF
3835 Add_object=Str_len
3836 GOSUB Icode_add_obj
3837 FOR I=1 TO Str_len STEP 2
3838 Add_object=256*NUM(Arg$[I])+NUM(Arg$[I+1])
3839 GOSUB Icode_add_obj
3840 NEXT I
3841 END IF
3842 END IF
3843 RETURN
3844 !
3845 ! This subroutine is used to assemble a 'general' parameter.
3846 ! General means that it can be immediate, CONST or VAR.
3847 !
3848 Icode_get_param:!
3849 Enable_const=1
3850 GOSUB Icode_get_arg
3851 IF Missing_arg THEN
3852 Error_string$="Missing parameter"
3853 GOSUB Icode_err
3854 RETURN
3855 END IF
3856 IF Arg$<>"" THEN
3857 IF Arg$[1;1]="@" THEN
3858 Var_pos=FNIcode_search(Var_name$(*),Var_last,Arg$[2])
3859 IF Var_pos=-1 THEN
3860 Error_string$="Undefined indirect variable - '"&Arg$[2]&"'"
3861 GOSUB Icode_err
3862 RETURN
3863 END IF
3864 Arg=-(Var_num(Var_pos)+16384)
3865 ELSE
3866 Var_pos=FNIcode_search(Var_name$(*),Var_last,Arg$)
3867 IF Var_pos<>-1 THEN
3868 Arg=-Var_num(Var_pos)
3869 ELSE
3870 Error_string$="Undefined parameter symbol - '"&Arg$&"'"
3871 GOSUB Icode_err
3872 RETURN
3873 END IF
3874 END IF
3875 END IF ! IF 0 THEN
3876 IF Arg>Max_16_int OR Arg<Min_16_int THEN
3877 Error_string$="Invalid parameter value - '"&VAL$(Arg)&"'"
3878 GOSUB Icode_err
3879 RETURN
3880 END IF
3881 Add_object=Arg
3882 GOSUB Icode_add_obj
3883 RETURN
3884 !
3885 ! This subroutine is used to assemble a block id parameter.
3886 ! The block may be DEFBLK_VAR, DEFBLK_CON, DEFBLK_SP, DEFBLK_MAIN
3887 ! or DEFBLK_EXT.
3888 !
3889 Icode_get_block:!
3890 INTEGER Blk_id_arg,Blk_index
3891 Enable_const=0
3892 GOSUB Icode_get_arg
3893 IF Arg$="" THEN
3894 Error_string$="Illegal immediate block specification"
3895 GOSUB Icode_err
3896 ELSE
3897 IF Arg$[1;1]="^" THEN
3898 Blk_index=FNIcode_search(Blkext_name$(*),Blkext_last,Arg$[2])
3899 IF Blk_index=-1 THEN
3900 IF FNIcode_search(Blkvar_name$(*),Blkvar_last,Arg$[2])<>-1 OR FNIcode_search(Blkcon_name$(*),Blkcon_last,Arg$[2])<>-1 THEN
3901 Error_string$="'"&Arg$[2]&"' is not of auto allocate class"
3902 GOSUB Icode_err
3903 ELSE
3904 Error_string$="Undefined auto allocate block - '"&Arg$[2]&"'"
3905 GOSUB Icode_err
3906 END IF
3907 ELSE
3908 IF Blkext_hsize(Blk_index)=0 THEN
3909 Error_string$="No header allocated for '"&Arg$[2]&"'"
3910 GOSUB Icode_err
3911 ELSE
3912 Blk_id_arg=-(Blkext_id(Blk_index)+1)
3913 END IF
3914 END IF
3915 ELSE
3916 Blk_index=FNIcode_search(Blkext_name$(*),Blkext_last,Arg$)
3917 IF Blk_index<>-1 THEN
3918 Blk_id_arg=-Blkext_id(Blk_index)
3919 ELSE
3920 Blk_index=FNIcode_search(Blkvar_name$(*),Blkvar_last,Arg$)
3921 IF Blk_index<>-1 THEN
3922 Blk_id_arg=-Blkvar_id(Blk_index)
3923 ELSE
3924 Blk_index=FNIcode_search(Blkcon_name$(*),Blkcon_last,Arg$)
3925 IF Blk_index<>-1 THEN
3926 Blk_id_arg=Blkcon_id(Blk_index)
3927 ELSE
3928 Error_string$="Undefined block - '"&Arg$&"'"
3929 GOSUB Icode_err
3930 RETURN
3931 END IF
3932 END IF
3933 END IF
3934 END IF
3935 END IF
3936 Add_object=Blk_id_arg
3937 GOSUB Icode_add_obj
3938 RETURN
3939 !
3940 ! This subroutine is used to assemble a variable reference parameter.
3941 ! A DEFBLK_VAR parameter may also be used in this field.
3942 !
3943 Icode_get_var:!
3944 Enable_const=0
3945 GOSUB Icode_get_arg
3946 IF Arg$<>"" THEN
3947 IF Arg$[1;1]="@" THEN ! Is this an indirect variable
3948 Var_pos=FNIcode_search(Var_name$(*),Var_last,Arg$[2])
3949 IF Var_pos=-1 THEN
3950 Error_string$="Undefined indirect variable - '"&Arg$[2]&"'"
3951 GOSUB Icode_err
3952 ELSE
3953 Arg=-(Var_num(Var_pos)+16384)
3954 END IF
3955 ELSE
3956 Var_pos=FNIcode_search(Var_name$(*),Var_last,Arg$)
3957 IF Var_pos<>-1 THEN
3958 Arg=-Var_num(Var_pos)
3959 ELSE
3960 IF Arg$[1;1]="^" THEN ! Header block
3961 Blkext_pos=FNIcode_search(Blkext_name$(*),Blkext_last,Arg$[2])
3962 IF Blkext_pos<>-1 THEN
3963 IF Blkext_hsize(Blkext_pos)>0 THEN
3964 Arg=Blkext_id(Blkext_pos)+1
3965 ELSE
3966 Error_string$="No header block allocated for '"&Arg$[2]&"'"
3967 GOSUB Icode_err
3968 END IF
3969 ELSE
3970 Error_string$="'"&Arg$[2]&"' not of auto allocate class"
3971 GOSUB Icode_err
3972 END IF
3973 ELSE
3974 Blkext_pos=FNIcode_search(Blkext_name$(*),Blkext_last,Arg$)
3975 IF Blkext_pos<>-1 THEN
3976 Arg=-Blkext_id(Blkext_pos)
3977 ELSE
3978 Blkvar_pos=FNIcode_search(Blkvar_name$(*),Blkvar_last,Arg$)
3979 IF Blkvar_pos<>-1 THEN
3980 Arg=-Blkvar_id(Blkvar_pos)
3981 ELSE
3982 Error_string$="Undefined variable - '"&Arg$&"'"
3983 GOSUB Icode_err
3984 END IF
3985 END IF
3986 END IF
3987 END IF
3988 END IF
3989 END IF
3990 Add_object=Arg
3991 GOSUB Icode_add_obj
3992 RETURN
3993 !
3994 ! This subroutine is used to allocate all the internal tables
3995 ! needed by the assembler.
3996 !
3997 Icode_alloc_tbl:!
3998 Lbl_last=-1
3999 ALLOCATE Lbl_name$(0:MAX(Lbl_tbl_size-1,0))[16],INTEGER Lbl_loc(0:MAX(Lbl_tbl_size-1,0))
4000 IF Info_info=2 THEN ALLOCATE INTEGER Lbl_src_loc(0:MAX(Lbl_tbl_size-1,0))
4001 Var_last=-1
4002 ALLOCATE Var_name$(0:MAX(Var_tbl_size-1,0))[16],INTEGER Var_num(0:MAX(Var_tbl_size-1,0))
4003 Forlbl_last=-1
4004 ALLOCATE Forlbl_name$(0:MAX(Forlbl_tbl_size-1,0))[16],INTEGER Forlbl_loc(0:MAX(Forlbl_tbl_size-1,0))
4005 IF Enable_list THEN ALLOCATE INTEGER Forlbl_list_pos(0:MAX(Forlbl_tbl_size-1,0)),INTEGER Forlbl_list_lft(0:MAX(Forlbl_tbl_size-1,0))
4006 Blkvar_last=-1
4007 ALLOCATE Blkvar_name$(0:MAX(Blkvar_tbl_size-1,0))[16],INTEGER Blkvar_id(0:MAX(Blkvar_tbl_size-1,0))
4008 Blkext_last=-1
4009 ALLOCATE Blkext_name$(0:MAX(Blkext_tbl_size-1,0))[16],INTEGER Blkext_id(0:MAX(Blkext_tbl_size-1,0))
4010 ALLOCATE INTEGER Blkext_type(0:MAX(Blkext_tbl_size-1,0))
4011 ALLOCATE Blkext_hsize(0:MAX(Blkext_tbl_size-1,0)),Blkext_size(0:MAX(Blkext_tbl_size-1,0))
4012 Blkcon_last=-1
4013 ALLOCATE Blkcon_name$(0:MAX(Blkcon_tbl_size-1,0))[16],INTEGER Blkcon_id(0:MAX(Blkcon_tbl_size-1,0))
4014 Const_last=-1
4015 ALLOCATE Const_name$(0:MAX(Const_tbl_size-1,0))[16],Const_val(0:MAX(Const_tbl_size-1,0))
4016 RETURN
4017 !
4018 ! This subroutine is used to do some checks on Info$(*) to make sure
4019 ! that it is of the correct size.
4020 !
4021 Icode_chk_info:!
4022 Info_hdr_size=6
4023 IF Info_info>0 THEN
4024 IF Info_size<Info_hdr_size THEN
4025 Error_string$="Info$ array < "&VAL$(Info_hdr_size)&" elements"
4026 GOSUB Icode_init_err
4027 END IF
4028 IF BASE(Info$,1)<>0 THEN
4029 Error_string$="Info$(*) index must start at zero"
4030 GOSUB Icode_init_err
4031 END IF
4032 ON ERROR GOTO Icode_info_smal ! Each line must be 40 chars long
4033 FOR I=1 TO Info_hdr_size
4034 Info$(I)=RPT$(" ",40)
4035 NEXT I
4036 OFF ERROR
4037 IF 0 THEN
4038 Icode_info_smal:OFF ERROR
4039 Error_string$="Info$(*) string elements < 40 chars"
4040 GOSUB Icode_init_err
4041 END IF
4042 END IF
4043 RETURN
4044 !
4045 Icode_fill_info:!
4046!
4047! This subroutine is used to fill the Info$(*) array after all
4048! source code has been assembled will lots of little things
4049! that the debugger, downloader, etc... need to know.
4050!
4051! Info$(*) format:
4052!
4053! char->0 1 2 3 4
4054! line 1234567890123456789012345678901234567890
4055! 0 < a >< b >< c >< d >< e >
4056! 1 < i >< j >< k >< l >
4057! 2 < q >< r >< s >< t >
4058! 3 < x >< y >< z >
4059! 4 < F >< G >< H >
4060! 5 < I >< J >
4061! .
4062! k < Inst_info table >
4063! .
4064! .
4065! i < Blkext table >
4066! .
4067! .
4068! q < blkvar table >
4069! .
4070! .
4071! x < Blkcon table >
4072! .
4073! .
4074! F < Var table >
4075! .
4076! .
4077! I < Lbl table >
4078! .
4079! .
4080! z < Debugger history queue space >
4081! .
4082! a: Info_info
4083! b: ICODE program id
4084! c: Info$(*) header size (6)
4085! d: Info_size
4086! e: # of vars reserved. For VAR, DEFBLK_VAR, etc...
4087!
4088! i: Start of Blkext table in Info$(*)
4089! j: # of Blkext table lines in Info$(*)
4090! k: Object_size
4091! l: Source_size
4092!
4093! q: Start of Blkvar table in Info$(*)
4094! r: # of Blkvar table lines in Info$(*)
4095! s: Start of Instruction table in Info$(*)
4096! t: # of Instructions in Info$(*). NOT # of instruction lines.
4097!
4098! x: Start of Blkcon table in Info$(*)
4099! y: # of Blkcon table lines in Info$(*)
4100! z: Start of 3 lines in Info$(*) reserved for debugger history queue
4101!
4102! F: Start of var table in Info$(*)
4103! G: # of var table lines in Info$(*)
4104! H: Object(*) address of last set break point. Used by debugger.
4105!
4106! I: Start of label table in Info$(*)
4107! J: # of label table lines in Info$(*)
4108!
4109! Inst_info table: Each line may have information about a maximum of 10
4110! assembled instructions. Information about a single
4111! instruction consists of 4 bytes. These bytes are in
4112! binary format with the first 2 bytes indicating the
4113! object address and the second 2 bytes indicating the
4114! source address.
4115!
4116! Blkext table: Each line has information about one DEFBLK_SP,DEFBLK_MAIN
4117! or DEFBLK_EXT user defined block. Chars 1 through 16 are
4118! the block name, char 17 is a mode byte, chars 18 through
4119! 22 hold the variable number, chars 23 through 28 hold
4120! the block size, chars 29 through 34 hold the header block
4121! size, and chars 35 through 39 hold the block id. The
4122! mode byte indicates the block type and whether or not
4123! the downloader should allocate this block at download
4124! time. Mode codes are as follows:
4125! 0 - undefined yet
4126! 1 - MAIN auto allocate block
4127! 2 - SP auto allocate block
4128! 3 - MAIN user allocate block
4129! 4 - SP user allocate block
4130!
4131! Blkvar table: Each line has information about one DEFBLK_VAR block.
4132! Characters 1 through 16 hold the block name and chars
4133! 17 through 21 hold the variable number that contains the
4134! block id.
4135!
4136! Blkcon table: Each line has information about one DEFBLK_CON block.
4137! Characters 1 through 16 hold the block name and chars
4138! 17 through 21 hold the block id.
4139!
4140! Var table: Each line has information about one VARiable. Characters
4141! 1 through 16 hold the variable name and chars 17 through
4142! 21 hold the variable number.
4143!
4144! Lbl table: Each line has information about one label. Characters
4145! 1 through 16 hold the label name and chars 17 through 21
4146! hold the label source address.
4147!
4148! Debugger history queue space: These 3 lines are used as storage space
4149! by the debugger. The first line contains
4150! 2 fields. Chars 1 through 5 hold the
4151! Hist_fifo_ptr and chars 6 through 10 hold
4152! Hist_fifo_wrap. The second line contains
4153! the ICODE history object address list.
4154! This list can hold up to 20 two byte
4155! binary entries. The third line contains
4156! the ICODE history opcode list. This list
4157! can also hold up to 20 two byte binary
4158! entries. This list is used to hold the
4159! ICODE history queue. See IHQ? HP-IB
4160! command.
4161!
4162!
4163 IF Info_info<>0 THEN
4164 !
4165 ! Find out how many lines need to be in Info$(*)
4166 !
4167 IF Info_info=1 THEN Lines_needed=Blkext_last+1+Info_hdr_size
4168 !
4169 IF Info_info=2 THEN
4170 Info_inst_cnt=Inst_cnt DIV 10
4171 IF Inst_cnt MOD 10<>0 THEN Info_inst_cnt=Info_inst_cnt+1
4172 Lines_needed=MAX(Blkext_last,0)+MAX(Blkvar_last,0)+MAX(Blkcon_last,0)+MAX(Var_last,0)+MAX(Lbl_last,0)+MAX(Info_hdr_size,0)+6+Info_inst_cnt
4173 Lines_needed=Lines_needed+3 ! Debugger needs this space
4174 END IF ! to keep the history list
4175 !
4176 IF Lines_needed>Info_size THEN
4177 Error_string$="Info$ array not large enough"
4178 GOSUB Icode_fatal_err
4179 END IF
4180 !
4181 REDIM Info$(0:Lines_needed-1)
4182 !
4183 ! Get indexes into Info$(*) where each table will go
4184 !
4185 Blkext_infostrt=Info_hdr_size+Info_inst_cnt
4186 Blkvar_infostrt=Blkext_infostrt+Blkext_last+1
4187 Blkcon_infostrt=Blkvar_infostrt+Blkvar_last+1
4188 Var_infostrt=Blkcon_infostrt+Blkcon_last+1
4189 Lbl_infostrt=Var_infostrt+Var_last+1
4190 !
4191 ! Start filling in Info$(*) with info.
4192 !
4193 IF Info_info=2 THEN
4194 Dbg_infostrt=Lbl_infostrt+Lbl_last+1 !Reserve 3 lines for hist
4195 ! table used by debugger.
4196 Info$(Dbg_infostrt)[1,5]=VAL$(-1) ! Init Hist_fifo_ptr
4197 Info$(Dbg_infostrt)[6,10]=VAL$(0) ! Init Hist_fifo_wrap
4198 Info$(Dbg_infostrt+1)=RPT$(" ",40)
4199 Info$(Dbg_infostrt+2)=RPT$(" ",40)
4200 END IF
4201 !
4202 Info$(0)[1,5]=VAL$(Info_info)
4203 Info$(0)[6,10]=VAL$(-1)
4204 Info$(0)[11,15]=VAL$(Info_hdr_size)
4205 Info$(0)[16,20]=VAL$(Lines_needed)
4206 Info$(0)[21,25]=VAL$(Vars_allocated)
4207 !
4208 IF Blkext_last=-1 THEN
4209 Info$(1)[1,5]=VAL$(0)
4210 ELSE
4211 Info$(1)[1,5]=VAL$(Blkext_infostrt)
4212 END IF
4213 Info$(1)[6,10]=VAL$(Blkext_last+1)
4214 Info$(1)[11,15]=VAL$(Object_last+1)
4215 Info$(1)[16,20]=VAL$(Source_last)
4216 !
4217 IF Info_info=1 THEN
4218 FOR I=2 TO 5
4219 Info$(I)[1,5]=VAL$(0)
4220 Info$(I)[6,10]=VAL$(0)
4221 NEXT I
4222 ELSE
4223 Info$(2)[1,5]=VAL$(Blkvar_infostrt)
4224 Info$(2)[6,10]=VAL$(Blkvar_last+1)
4225 Info$(2)[11,15]=VAL$(Info_inst_base)
4226 Info$(2)[16,20]=VAL$(Inst_cnt)
4227 Info$(3)[1,5]=VAL$(Blkcon_infostrt)
4228 Info$(3)[6,10]=VAL$(Blkcon_last+1)
4229 Info$(3)[11,15]=VAL$(Dbg_infostrt) ! used by debugger
4230 Info$(4)[1,5]=VAL$(Var_infostrt)
4231 Info$(4)[6,10]=VAL$(Var_last+1)
4232 Info$(4)[11,15]=VAL$(-1) ! used by debugger to
4233 Info$(5)[1,5]=VAL$(Lbl_infostrt)
4234 Info$(5)[6,10]=VAL$(Lbl_last+1)
4235 Info$(5)[11;1]=VAL$(0) ! Disp_vars_hex = 0
4236 Info$(5)[12;1]=VAL$(0) ! disp_blks_hex = 0
4237 END IF
4238 !
4239 ! Fill in externally allocated block table
4240 !
4241 Blkext_ptr=-1
4242 FOR I=Blkext_infostrt TO Blkext_infostrt+Blkext_last
4243 Blkext_ptr=Blkext_ptr+1
4244 Info$(I)[1,16]=Blkext_name$(Blkext_ptr)
4245 Info$(I)[17;1]=VAL$(Blkext_type(Blkext_ptr))
4246 Info$(I)[18,22]=VAL$(Blkext_id(Blkext_ptr))
4247 Info$(I)[23,28]=VAL$(Blkext_size(Blkext_ptr))
4248 Info$(I)[29,34]=VAL$(Blkext_hsize(Blkext_ptr))
4249 NEXT I
4250 !
4251 IF Info_info=2 THEN
4252 !
4253 ! Fill in DEFBLK_VAR table
4254 !
4255 Blkvar_ptr=-1
4256 FOR I=Blkvar_infostrt TO Blkvar_infostrt+Blkvar_last
4257 Blkvar_ptr=Blkvar_ptr+1
4258 Info$(I)[1,16]=Blkvar_name$(Blkvar_ptr)
4259 Info$(I)[17,21]=VAL$(Blkvar_id(Blkvar_ptr))
4260 NEXT I
4261 !
4262 ! Fill in DEFBLK_CON table
4263 !
4264 Blkcon_ptr=-1
4265 FOR I=Blkcon_infostrt TO Blkcon_infostrt+Blkcon_last
4266 Blkcon_ptr=Blkcon_ptr+1
4267 Info$(I)[1,16]=Blkcon_name$(Blkcon_ptr)
4268 Info$(I)[17,21]=VAL$(Blkcon_id(Blkcon_ptr))
4269 NEXT I
4270 !
4271 ! Fill in variable table
4272 !
4273 Var_ptr=-1
4274 FOR I=Var_infostrt TO Var_infostrt+Var_last
4275 Var_ptr=Var_ptr+1
4276 Info$(I)[1,16]=Var_name$(Var_ptr)
4277 Info$(I)[17,21]=VAL$(Var_num(Var_ptr))
4278 NEXT I
4279 !
4280 ! Fill in label table
4281 !
4282 Lbl_ptr=-1
4283 FOR I=Lbl_infostrt TO Lbl_infostrt+Lbl_last
4284 Lbl_ptr=Lbl_ptr+1
4285 Info$(I)[1,16]=Lbl_name$(Lbl_ptr)
4286 Info$(I)[17,21]=VAL$(Lbl_loc(Lbl_ptr))
4287 Info$(I)[22,26]=VAL$(Lbl_src_loc(Lbl_ptr))
4288 NEXT I
4289 END IF ! If info_info=2 then
4290 END IF ! If Info_info<>0 then
4291 RETURN
4292 !
4293 Icode_forlbl_ck: ! See if there are any unresolved forward references
4294 IF Forlbl_last>-1 THEN
4295 FOR I=0 TO Forlbl_last
4296 Error_string$="ERROR: Undefined label - '"&Forlbl_name$(I)&"'"
4297 OUTPUT CRT;Error_string$
4298 Error_count=Error_count+1
4299 IF Enable_list THEN
4300 List_last=List_last+1
4301 List$(MAX(0,MIN(List_last,List_size-1)))=RPT$(" ",15)&"***** "&Error_string$&" *****"
4302 END IF
4303 NEXT I
4304 END IF
4305 RETURN
4306 !
4307 Icode_asm_exit: ! This routine is used to exit the assembler
4308 Disp_line$="ICODE assembly complete. "
4309 IF Error_count=0 THEN
4310 Disp_line$=Disp_line$&"No errors. "&VAL$(Source_last)&" source lines. "&VAL$(Object_last+1)&" object words."
4311 ELSE
4312 BEEP
4313 IF Error_count=1 THEN
4314 Disp_line$=Disp_line$&VAL$(Error_count)&" error."
4315 ELSE
4316 Disp_line$=Disp_line$&VAL$(Error_count)&" errors."
4317 IF Error_count>20 THEN Disp_line$=Disp_line$&" ICODE program needs work"
4318 END IF
4319 END IF
4320 DISP Disp_line$
4321 IF Enable_list THEN
4322 List_last=List_last+1
4323 List$(MIN(List_last,List_size-1))=Disp_line$
4324 END IF
4325 REDIM List$(0:MAX(0,MIN(List_last,List_size-1)))
4326 IF Error_count=0 THEN
4327 REDIM Source$(0:MAX(Source_last-1,0))
4328 REDIM Object(0:MAX(Object_last,0))
4329 END IF
4330 !
4331 IF Error_count<>0 THEN
4332 ON ERROR GOTO Icode_who_cares
4333 REDIM Info$(0:0)
4334 Info$(0)="9"
4335 Icode_who_cares:IF 0 THEN A=1
4336 OFF ERROR
4337 END IF
4338 !
4339 RETURN Error_count
4340 END IF ! GOSUBS IF 0 THEN
4341 !
4342 FNEND ! Icode_assemble
4343 !
4344 Icode_search:DEF FNIcode_search(Search_array$(*),Array_last,Search_key$)
4345!
4346! This function is used by the assembler to search a table and return
4347! an index into that table indicating where the search key was found.
4348! <Search_array$> is the array to be searched. <Array_last> is the last
4349! element in <Search_array$> that should be checked. <Search_key$> is
4350! what should be found in <Search_array$>. If <Search_key$> is found
4351! in <Search_array$> then the index into <Search_array$> is returned
4352! in the function result, else -1 is returned.
4353!
4354 INTEGER I,Int_array_last
4355 Int_array_last=Array_last
4356 IF Int_array_last>=0 THEN
4357 FOR I=0 TO Int_array_last
4358 IF Search_key$=Search_array$(I) THEN RETURN I
4359 NEXT I
4360 END IF
4361 RETURN -1
4362 FNEND
4363 !
4364 Icode_inst_str:SUB Icode_inst_str(Opcode$,Inst_info$)
4365!
4366! This function is used by the assembler to translate an opcode mnemonic
4367! (did you know that mnemonically is a word?) into an instruction
4368! information string. The instruction information string contains
4369! the opcode number and a list of code which tell the assembler what
4370! parameters must follow. If the opcode mnemonic (who was the first
4371! person to spell mnemonic?) is undefined, then "-1" is returned.
4372! See the main assembly loop in the assembler for details on what the
4373! parameter codes mean.
4374!
4375 SELECT Opcode$[1;2]
4376 CASE "C_"
4377 SELECT Opcode$[3]
4378 CASE "BEQ"
4379 Inst_info$="57 LPP"
4380 CASE "BGE"
4381 Inst_info$="59 LPP"
4382 CASE "BGT"
4383 Inst_info$="60 LPP"
4384 CASE "BITSET"
4385 Inst_info$="54 LPP"
4386 CASE "BLE"
4387 Inst_info$="56 LPP"
4388 CASE "BLT"
4389 Inst_info$="55 LPP"
4390 CASE "BNE"
4391 Inst_info$="58 LPP"
4392 CASE "END"
4393 Inst_info$="48"
4394 CASE "GOSUB"
4395 Inst_info$="50 L"
4396 CASE "GOTO"
4397 Inst_info$="49 L"
4398 CASE "NOP"
4399 Inst_info$="61"
4400 CASE "RTS"
4401 Inst_info$="51"
4402 CASE "SP_BEQ"
4403 Inst_info$="52 LP"
4404 CASE "SP_BNE"
4405 Inst_info$="53 LP"
4406 CASE ELSE
4407 Inst_info$="-1"
4408 END SELECT
4409 CASE "F_"
4410 SELECT Opcode$[3]
4411 CASE "ASSERT_TRIG"
4412 Inst_info$="22"
4413 CASE "BLK_MC68000"
4414 Inst_info$="32 BPMRBP!"
4415 CASE "COPY_BLOCK"
4416 Inst_info$="14 BB"
4417 CASE "EXEC"
4418 Inst_info$="134 P"
4419 CASE "FAST_AVG_ADD"
4420 Inst_info$="126 BPBPPP"
4421 CASE "FAST_AVG_DIV"
4422 Inst_info$="127 BPBPPP"
4423 CASE "FAST_AVG_INIT"
4424 Inst_info$="124 BPPPPP"
4425 CASE "FLOAT_ADD"
4426 Inst_info$="86 BPBPBPP"
4427 CASE "FLOAT_AVG"
4428 Inst_info$="132 BPBPPP"
4429 CASE "FLOAT_CCONST"
4430 Inst_info$="107 BPPFF"
4431 CASE "FLOAT_CDIV"
4432 Inst_info$="101 BPBPBPP"
4433 CASE "FLOAT_CMULT"
4434 Inst_info$="98 BPBPBPP"
4435 CASE "FLOAT_CONJ"
4436 Inst_info$="116 BPBPP"
4437 CASE "FLOAT_CONST"
4438 Inst_info$="104 BPPF"
4439 CASE "FLOAT_EXTREMAL"
4440 Inst_info$="120 BPBPP"
4441 CASE "FLOAT_DINTRLVE"
4442 Inst_info$="45 BPBPBPP"
4443 CASE "FLOAT_DIV"
4444 Inst_info$="95 BPBPBPP"
4445 CASE "FLOAT_INTRLVE"
4446 Inst_info$="83 BPBPBPP"
4447 CASE "FLOAT_LOG10"
4448 Inst_info$="125 BPBPP"
4449 CASE "FLOAT_MULT"
4450 Inst_info$="92 BPBPBPP"
4451 CASE "FLOAT_PHASE"
4452 Inst_info$="119 BPBPP"
4453 CASE "FLOAT_SQRT"
4454 Inst_info$="122 BPBPP"
4455 CASE "FLOAT_SUB"
4456 Inst_info$="89 BPBPBPP"
4457 CASE "FLOAT_TO_INT"
4458 Inst_info$="113 BPBPP"
4459 CASE "FLOAT_TO_SHORT"
4460 Inst_info$="112 BPBPP"
4461 CASE "FLOAT_WINGEN"
4462 Inst_info$="138 BPPMRF!"
4463 CASE "FLOAT_XYPOW"
4464 Inst_info$="128 BPBPBPP"
4465 CASE "GET_ASCII"
4466 Inst_info$="27 PMRV!"
4467 CASE "GET_GBL_STA","GET_GLB_STA"
4468 Inst_info$="30 V"
4469 CASE "GET_HDW_STATUS"
4470 Inst_info$="29 PV"
4471 CASE "GET_SIG"
4472 Inst_info$="46 V"
4473 CASE "GET_SRQ_MASK"
4474 Inst_info$="63 V"
4475 CASE "GET_STA"
4476 Inst_info$="15 V"
4477 CASE "GET_STATUS"
4478 Inst_info$="28 PV"
4479 CASE "GET_STC"
4480 Inst_info$="16 V"
4481 CASE "GLB_COMMAND"
4482 Inst_info$="24 PS"
4483 CASE "GLB_CONTROL"
4484 Inst_info$="26 V"
4485 CASE "HPIB_COMMAND"
4486 Inst_info$="17 S"
4487 CASE "INPUT_DATA"
4488 Inst_info$="1 PBPP"
4489 CASE "INT_TO_FLOAT"
4490 Inst_info$="111 BPBPP"
4491 CASE "INT_TO_SHORT"
4492 Inst_info$="110 BPBPP"
4493 CASE "KEEP_READY_RAM"
4494 Inst_info$="66"
4495 CASE "LOAD_PROG"
4496 Inst_info$="42 BP"
4497 CASE "LOAD_SP_ALGS"
4498 Inst_info$="47 P"
4499 CASE "MC68000"
4500 Inst_info$="31 IMRBP!"
4501 CASE "MOD_COMMAND"
4502 Inst_info$="23 PS"
4503 CASE "MOD_CONTROL"
4504 Inst_info$="25 PV"
4505 CASE "MOVE_BLOCK"
4506 Inst_info$="13 BPBPP"
4507 CASE "OFF_INT"
4508 Inst_info$="38"
4509 CASE "ON_IRQ"
4510 Inst_info$="35 L"
4511 CASE "ON_SHUTDOWN"
4512 Inst_info$="37 L"
4513 CASE "ON_SP"
4514 Inst_info$="36 L"
4515 CASE "ON_SRQ"
4516 Inst_info$="34 L"
4517 CASE "OUTPUT_DATA"
4518 Inst_info$="2 PBPP"
4519 CASE "PAUSE"
4520 Inst_info$="133"
4521 CASE "POLL_MODULE"
4522 Inst_info$="39 PV"
4523 CASE "READ_DISC"
4524 Inst_info$="5 BPPPPPPPV"
4525 CASE "READ_ROM"
4526 Inst_info$="136 PV"
4527 CASE "READ_SP_STAT"
4528 Inst_info$="118 V"
4529 CASE "READY_DISC"
4530 Inst_info$="7 PPPPPBPBPV"
4531 CASE "READY_RAM"
4532 Inst_info$="8 M@0BPPPMRP!@1BPBPV"
4533 CASE "RECEIVE_DATA"
4534 Inst_info$="3 BPP"
4535 CASE "RELEASE_BUS"
4536 Inst_info$="41 P"
4537 CASE "REQUEST_BUS"
4538 Inst_info$="40"
4539 CASE "SAMPLE"
4540 Inst_info$="137 BPBPPPP"
4541 CASE "SEND_DATA"
4542 Inst_info$="4 BPP"
4543 CASE "SET_EXP_DEF"
4544 Inst_info$="129 PPPP"
4545 CASE "SET_SRQ_MASK"
4546 Inst_info$="64 P"
4547 CASE "SET_WORK_ID"
4548 Inst_info$="139 B"
4549 CASE "SHORT_ADD"
4550 Inst_info$="84 BPBPBPP"
4551 CASE "SHORT_CCONST"
4552 Inst_info$="105 BPPPPP"
4553 CASE "SHORT_CDIV"
4554 Inst_info$="99 BPBPBPP"
4555 CASE "SHORT_CMULT"
4556 Inst_info$="96 BPBPBPP"
4557 CASE "SHORT_CONJ"
4558 Inst_info$="114 BPBPP"
4559 CASE "SHORT_CONST"
4560 Inst_info$="102 BPPPP"
4561 CASE "SHORT_DINTRLVE"
4562 Inst_info$="43 BPBPBPP"
4563 CASE "SHORT_DIV"
4564 Inst_info$="93 BPBPBPP"
4565 CASE "SHORT_INTRLVE"
4566 Inst_info$="81 BPBPBPP"
4567 CASE "SHORT_MULT"
4568 Inst_info$="90 BPBPBPP"
4569 CASE "SHORT_NORM"
4570 Inst_info$="135 BPP"
4571 CASE "SHORT_SUB"
4572 Inst_info$="87 BPBPBPP"
4573 CASE "SHORT_TO_FLOAT"
4574 Inst_info$="109 BPBPP"
4575 CASE "SHORT_TO_INT"
4576 Inst_info$="108 BPBPP"
4577 CASE "SIG_PROC"
4578 Inst_info$="0 PMRM!MRBP!"
4579 CASE "SIGNAL"
4580 Inst_info$="18 P"
4581 CASE "STORE_PROG"
4582 Inst_info$="62 BPPP"
4583 CASE "SYNC"
4584 Inst_info$="33"
4585 CASE "SYNC_TIME"
4586 Inst_info$="130 P"
4587 CASE "THRUPUT"
4588 Inst_info$="9 PP"
4589 CASE "TRIG_SEQ"
4590 Inst_info$="10"
4591 CASE "TRIG_SEQ_TIME"
4592 Inst_info$="121 P"
4593 CASE "UNASSERT_TRIG"
4594 Inst_info$="21"
4595 CASE "UNDEFINED"
4596 Inst_info$="44"
4597 CASE "WAIT_FOR_SIG"
4598 Inst_info$="19 V"
4599 CASE "WAIT_TO_SIG"
4600 Inst_info$="65 P"
4601 CASE "WAIT_SRQ"
4602 Inst_info$="20"
4603 CASE "WRITE_DISC"
4604 Inst_info$="6 BPPPPPPPV"
4605 CASE "WRITE_ROM"
4606 Inst_info$="123 PP"
4607 CASE "WRITE_SP_CNTL"
4608 Inst_info$="117 P"
4609 CASE "XFER_TO_HOST"
4610 Inst_info$="11 PP"
4611 CASE "XFER_TO_MOD"
4612 Inst_info$="12 PP"
4613 CASE ELSE
4614 Inst_info$="-1"
4615 END SELECT
4616 CASE "V_"
4617 SELECT Opcode$[3]
4618 CASE "ADD"
4619 Inst_info$="71 PPV"
4620 CASE "AND"
4621 Inst_info$="68 PPV"
4622 CASE "CEQUATE"
4623 Inst_info$="75 IV"
4624 CASE "DIV"
4625 Inst_info$="74 PPV"
4626 CASE "GET16_INDEXED"
4627 Inst_info$="77 BPV"
4628 CASE "GET32_INDEXED"
4629 Inst_info$="78 BPV"
4630 CASE "MODULO"
4631 Inst_info$="70 PPV"
4632 CASE "MULT"
4633 Inst_info$="73 PPV"
4634 CASE "NOT"
4635 Inst_info$="67 PV"
4636 CASE "OR"
4637 Inst_info$="69 PPV"
4638 CASE "PUT16_INDEXED"
4639 Inst_info$="79 BPV"
4640 CASE "PUT32_INDEXED"
4641 Inst_info$="80 BPV"
4642 CASE "SUB"
4643 Inst_info$="72 PPV"
4644 CASE "VEQUATE"
4645 Inst_info$="76 VV"
4646 CASE ELSE
4647 Inst_info$="-1"
4648 END SELECT
4649 CASE ELSE
4650 Inst_info$="-1"
4651 END SELECT
4652 SUBEND
4653 !
4654 Icode_eval_str:SUB Icode_eval_str(Str$,Str_val,Str_error)
4655!
4656! This subprogram is used to evaluate a string into a numerical quantity.
4657! <Str$> is the input string and its numerical value (if there is one) is
4658! returned in <Str_val>. This will work on decimal and hex numbers. Hex
4659! numbers must be preceeded by a '$'. If <Str$> can not be converted
4660! into a number then <Str_error> is set to 1. <Str_error> is also set
4661! to 1 if <Str$>="".
4662!
4663 Str_error=0
4664 ON ERROR GOTO Icode_no_value
4665 IF Str$="" THEN
4666 Str_error=1
4667 ELSE
4668 IF Str$[1;1]="$" THEN
4669 Str_val=DVAL(Str$[2],16)
4670 Str$=""
4671 ELSE
4672 Str_val=VAL(Str$)
4673 Str$=""
4674 END IF
4675 END IF
4676 IF 0 THEN
4677 Icode_no_value:Str_val=-1
4678 END IF
4679 OFF ERROR
4680 SUBEND
4681 !
4682 Icode_dld:DEF FNIcode_dld(INTEGER Object(*),INTEGER Enable_info,Info$(*))
4683!
4684! This function is used to allocate an ICODE program block, allocate
4685! some types of data blocks, and download the ICODE program into its
4686! program block. <Object(*)> is the assembled ICODE program.
4687! <Enable_info> is a flag which enables the downloader to search <Info$>
4688! for unallocated blocks. If <Enable_info> is non-zero, then <Info$> is
4689! searched for all DEFBLK_SP and DEFBLK_MAIN block types. These blocks
4690! are then allocated. Also, DEFBLK_EXT block types that have been
4691! flagged by 'FNIcode_def_ext' to be allocated by the downloader are
4692! allocated. To find out the block id of any block, 'FNIcode_ext_id'
4693! may be used after the ICODE program has been downloaded. If
4694! <Enable_info> is zero, then no blocks are allocated (except the ICODE
4695! program block). Returned in the function result is the block id of
4696! the ICODE program. If an error occurs, then an error message is
4697! displayed and a -1 is returned as the function result.
4698!
4699 DIM Line$[40],Error_string$[100],Temp$[20]
4700 Object_size=SIZE(Object,1)
4701 IF NOT FNIcode_info_ok(Info$(*),Error_string$) THEN GOTO Icode_dld_err
4702 !
4703 IF Enable_info THEN
4704 ON ERROR GOTO Icode_info_bad
4705 Blkext_strt=VAL(Info$(1)[1,5])
4706 Blkext_cnt=VAL(Info$(1)[6,10])
4707 FOR I=Blkext_strt TO Blkext_strt+Blkext_cnt-1
4708 Line$=Info$(I)
4709 Block_type=VAL(Line$[17;1])
4710 IF Block_type=0 THEN
4711 Error_string$="Block '"&TRIM$(Line$[1,16])&"' not allocated"
4712 GOTO Icode_dld_err
4713 RETURN -1
4714 ELSE
4715 Var_number=VAL(Line$[18,22])
4716 Block_size=VAL(Line$[23,28])
4717 Hblock_size=VAL(Line$[29,34])
4718 IF Var_number<0 OR Var_number>32767 THEN GOTO Icode_info_bad
4719 IF Block_size<0 THEN GOTO Icode_info_bad
4720 IF Hblock_size<0 THEN Icode_info_bad
4721 IF Block_type=1 OR Block_type=2 THEN
4722 OFF ERROR
4723 IF Block_type=1 THEN
4724 Temp$=FNHw_cmd_rsp$("NEW "&VAL$(Block_size)&","&VAL$(Hblock_size)&";NEW?",3)
4725 ELSE
4726 Temp$=FNHw_cmd_rsp$("SNEW "&VAL$(Block_size)&","&VAL$(Hblock_size)&";NEW?",3)
4727 END IF
4728 IF FNHw_io_error THEN GOTO Icode_hw_io_err
4729 ON ERROR GOTO Icode_info_bad
4730 Block_id=VAL(Temp$)
4731 IF Block_id=-1 THEN GOTO Icode_id_bad
4732 IF Block_id>32767 THEN GOTO Icode_info_bad
4733 Info$(I)[35,39]=VAL$(Block_id)
4734 ELSE
4735 Block_id=VAL(Info$(I)[35,39])
4736 END IF
4737 Var_base=Var_number*2
4738 ON ERROR GOTO Icode_obj_bad
4739 Object(Var_base)=0
4740 Object(Var_base+1)=Block_id
4741 IF Hblock_size>0 THEN
4742 Object(Var_base+2)=0
4743 Object(Var_base+3)=Block_id+1
4744 END IF
4745 END IF
4746 NEXT I
4747 END IF
4748 !
4749 OFF ERROR
4750 Temp$=FNHw_cmd_rsp$("NEW "&VAL$(SIZE(Object,1))&";NEW?",3)
4751 IF FNHw_io_error THEN GOTO Icode_hw_io_err
4752 Prog_id=VAL(Temp$)
4753 IF Prog_id=-1 THEN
4754 Error_string$="Can not allocate program block"
4755 GOTO Icode_dld_err
4756 END IF
4757 !
4758 Hw_write_blk(Prog_id,Object(*),5)
4759 IF FNHw_io_error THEN GOTO Icode_hw_io_err
4760 !
4761 IF Enable_info THEN
4762 Info$(0)[6,10]=VAL$(Prog_id)
4763 END IF
4764 !
4765 RETURN Prog_id
4766 !
4767 IF 0 THEN
4768 Icode_obj_bad:!
4769 Error_string$="Object(*) access error"
4770 GOTO Icode_dld_err
4771 Icode_id_bad:!
4772 Error_string$="Could not allocate block data block"
4773 GOTO Icode_dld_err
4774 Icode_hw_io_err:!
4775 Error_string$="Hardware I/O timeout error"
4776 GOTO Icode_dld_err
4777 Icode_info_bad:!
4778 Error_string$="Info$ array format error"
4779 GOTO Icode_dld_err
4780 Icode_dld_err:OFF ERROR
4781 Icode_exec_err("Icode_dld: "&Error_string$)
4782 RETURN -1
4783 END IF
4784 FNEND
4785 !
4786 Icode_ext_id:DEF FNIcode_ext_id(Block_name$,Info$(*))
4787!
4788! This function is used to get the id of an ICODE defined block. Since
4789! auto allocate blocks are not allocated until download time, this function
4790! will not return valid data until the ICODE program has been downloaded.
4791! The block name is specified by <Block_name$> and the block id is returned
4792! in the function result. If there is an error (block not allocated yet,
4793! etc), then -1 will be returned.
4794!
4795 DIM Error_string$[100]
4796 IF FNIcode_info_ok(Info$(*),Error_string$) THEN
4797 Info_pos=VAL(Info$(1)[1,5])
4798 Info_max=Info_pos+VAL(Info$(1)[6,10])-1
4799 Block_name$=UPC$(TRIM$(Block_name$))
4800 WHILE Info_pos<=Info_max
4801 IF Block_name$[1;1]="^" THEN
4802 IF Block_name$[2]=TRIM$(Info$(Info_pos)[1,16]) THEN
4803 IF VAL(Info$(Info_pos)[29,34])>0 THEN
4804 Auto_id=VAL(Info$(Info_pos)[35,39])
4805 ELSE
4806 Icode_exec_err("Icode_auto_id: No header block allocated")
4807 RETURN -1
4808 END IF
4809 END IF
4810 ELSE
4811 IF Block_name$=TRIM$(Info$(Info_pos)[1,16]) THEN
4812 Auto_id=VAL(Info$(Info_pos)[35,39])
4813 RETURN Auto_id
4814 END IF
4815 END IF
4816 Info_pos=Info_pos+1
4817 END WHILE
4818 ELSE
4819 Icode_exec_err("Icode_auto_id: "&Error_string$)
4820 RETURN -1
4821 END IF
4822 RETURN -1
4823 FNEND
4824 !
4825 Icode_info_ok:DEF FNIcode_info_ok(Info$(*),Error_string$)
4826!
4827! This function is used (not by the assembler) to see if the Info$ array
4828! is of the correct format. This routine is here because every ICODE
4829! file subprogram that accesses <Info$> needs to make sure that it does
4830! not bomb out because the user didn't pass in the correct array.
4831! Returned in the function result is a 1 if <Info$> seems ok. If a
4832! problem is found with <Info$> then <Error_string$> is used to return
4833! an error string.
4834!
4835 DIM Line$[40]
4836 !
4837 Error_string$=""
4838 !
4839 IF BASE(Info$,1)<>0 THEN ! Check index
4840 Error_string$="Info$ index must start at zero"
4841 RETURN 0
4842 END IF
4843 !
4844 ON ERROR GOTO Icode_str_smal
4845 Line$[1;40]=Info$(0) ! make sure 40 chars wide
4846 Info$(0)=RPT$(" ",40)
4847 Info$(0)=Line$
4848 !
4849 ! Check info_info field
4850 !
4851 ON ERROR GOTO Icode_info_bad
4852 Info_info=VAL(Line$[1,5])
4853 IF Info_info<0 OR Info_info>2 THEN GOTO Icode_info_bad
4854 !
4855 Header_size_chk=VAL(Info$(0)[11,15]) ! get header size
4856 !
4857 ! Now see if size make sense.
4858 !
4859 Total_size=VAL(Info$(0)[16,20])
4860 IF SIZE(Info$,1)<Header_size_chk OR SIZE(Info$,1)<Total_size THEN
4861 Error_string$="Info$ format error - Info$ too small"
4862 RETURN 0
4863 END IF
4864 !
4865 RETURN 1
4866 !
4867 IF 0 THEN
4868 Icode_info_bad:Error_string$="Info$ format error"
4869 RETURN 0
4870 Icode_str_smal:Error_string$="Info$ format error - < 40 chars"
4871 RETURN 0
4872 END IF
4873 FNEND
4874 !
4875 Icode_exec_err:SUB Icode_exec_err(Error_string$)
4876!
4877! This function is used to display an error message on the screen.
4878! The screen is cleared, the error message is displayed, this routine
4879! then waits 3 seconds and returns.
4880!
4881 BEEP
4882 OUTPUT CRT;" "
4883 OUTPUT CRT
4884 OUTPUT CRT;"*** ";Error_string$;" ***"
4885 OUTPUT CRT
4886 WAIT 3
4887 SUBEND
4888 !
4889 Icode_def_ext:DEF FNIcode_def_ext(Block_name$,Use_main_ram,Block_size,Hblock_size,Block_id,Info$(*))
4890!
4891! This function is used to bind a DEFBLK_EXT block name with a block id.
4892! The block to be bound is specified by <Block_name$>. If the block is
4893! an HP3565S HP-IB module MAIN data RAM block, then <Use_main_ram> should
4894! be non-zero. If the block is to reside in SP data RAM, then
4895! <Use_main_ram> should be zero. <Info$(*)> is the information array
4896! that was filled with all sorts of information from the assembler. There
4897! are two modes this function can be used in. If <Block_id> is <= 0
4898! then mode 1 is used. In mode 1, <Block_size> and <Hblock_size> define
4899! the sizes of the data block and header data block. These blocks will
4900! be allocated for the user by the downloader (FNIcode_dld).
4901! If <block_id> > 0 then mode 2 is used. In mode 2, the user has already
4902! allocated the block and is just telling the downloader what the
4903! block id is. In mode 2, <Block_size> and <Hblock_size> must also
4904! contain the size of the data block and header block. In either
4905! case, the function result will be the block id of block specified.
4906! If an error occurs during the execution of this function, then an
4907! error message is displayed, and a -1 is returned as the function
4908! result. Note that this function should be used after the program is
4909! is assembled and before the program is downloaded.
4910!
4911 DIM Line$[40],Error_string$[40]
4912 INTEGER Found_match
4913 IF LEN(Block_name$)>16 THEN
4914 Icode_exec_err("Icode_def_ext: Block_name$ parameter string too long")
4915 RETURN -1
4916 END IF
4917 IF Block_size<0 THEN
4918 Icode_exec_err("Icode_def_ext: Invalid Block_size parameter")
4919 RETURN -1
4920 END IF
4921 IF Hblock_size<0 THEN
4922 Icode_exec_err("Icode_def_ext: Invalid header block size parameter")
4923 RETURN -1
4924 END IF
4925 IF Block_id<0 THEN
4926 Icode_exec_err("Icode_def_ext: Invalid Block_id parameter")
4927 RETURN -1
4928 END IF
4929 IF FNIcode_info_ok(Info$(*),Error_string$) THEN
4930 Block_name$=UPC$(TRIM$(Block_name$))
4931 Info_pos=VAL(Info$(1)[1,5])
4932 Info_max=Info_pos+VAL(Info$(1)[6,10])
4933 Found_match=0
4934 WHILE Info_pos<Info_max AND NOT Found_match
4935 IF Block_name$=TRIM$(Info$(Info_pos)[1,16]) THEN
4936 Found_match=1
4937 IF Block_id=0 THEN
4938 IF Use_main_ram THEN
4939 Temp$=FNHw_cmd_rsp$("NEW "&VAL$(Block_size)&","&VAL$(Hblock_size)&";NEW?",3)
4940 ELSE
4941 Temp$=FNHw_cmd_rsp$("SNEW "&VAL$(Block_size)&","&VAL$(Hblock_size)&";NEW?",3)
4942 END IF ! Use_main_ram
4943 IF FNHw_io_error THEN
4944 Icode_exec_err("Icode_def_ext: I/O error on block allocation")
4945 RETURN -1
4946 ELSE
4947 Block_id=VAL(Temp$)
4948 IF Block_id=-1 THEN
4949 Icode_exec_err("Icode_def_ext: HP-IB module won't allocate block")
4950 RETURN -1
4951 END IF
4952 Line$=Info$(Info_pos)
4953 IF Use_main_ram THEN
4954 Line$[17;1]="3"
4955 ELSE
4956 Line$[17;1]="4"
4957 END IF
4958 IF Line$[17;1]="1" OR Line$[17;1]="2" THEN
4959 Icode_exec_err("Icode_def_ext: Can't redefine auto allocate blocks")
4960 RETURN -1
4961 END IF
4962 END IF
4963 ELSE
4964 Line$=Info$(Info_pos)
4965 IF Line$[17;1]="1" OR Line$[17;1]="2" THEN
4966 Icode_exec_err("Icode_def_ext: Can't redefine auto allocate blocks")
4967 RETURN -1
4968 ELSE
4969 IF Use_main_ram THEN
4970 Line$[17;1]="3"
4971 ELSE
4972 Line$[17;1]="4"
4973 END IF
4974 END IF
4975 END IF ! IF Block_id<=0
4976 Line$[23,28]=VAL$(Block_size)
4977 Line$[29,34]=VAL$(Hblock_size)
4978 Line$[35,39]=VAL$(Block_id)
4979 Info$(Info_pos)=Line$
4980 END IF
4981 Info_pos=Info_pos+1
4982 END WHILE
4983 IF NOT Found_match THEN
4984 Icode_exec_err("Icode_def_ext: Undefined Block_name - '"&Block_name$&"'")
4985 RETURN -1
4986 END IF
4987 ELSE
4988 Icode_exec_err("Icode_def_ext: "&Error_string$)
4989 RETURN -1
4990 END IF
4991 RETURN Block_id
4992 FNEND ! Icode_def_ext
4993 !
4994 Icode_inpt_num:SUB Icode_inpt_num(Prompt_string$,INTEGER Inpt_num,Null_flag,Error_flag,OPTIONAL Inpt_str$)
4995!
4996! This subprogram is used by the debugger to enter an integer number.
4997! The user is prompted with the string parameter Prompt_string$. If the
4998! user does not enter a string (just hit return), then Null_flag is set
4999! true. If an error occurs during input, then Error_flag is set true.
5000! If the string entered by the user is not a valid decimal or hex number,
5001! and the OPTIONAL parameter Inpt_str$ is present, then Inpt_str$ is
5002! returns with the user input string.
5003!
5004 DIM Temp$[100]
5005 Error_flag=0
5006 Null_flag=0
5007 IF NPAR=5 THEN Inpt_str$=""
5008 DISP Prompt_string$;
5009 LINPUT "",Temp$
5010 Temp$=TRIM$(Temp$)
5011 IF Temp$="" THEN
5012 Null_flag=1
5013 ELSE
5014 ON ERROR GOTO Icode_dbg_oops
5015 IF Temp$[1,1]="$" THEN
5016 Inpt_num=DVAL(Temp$[2],16)
5017 ELSE
5018 Inpt_num=VAL(Temp$)
5019 END IF
5020 IF 0 THEN
5021 Icode_dbg_oops:!
5022 IF NPAR=5 THEN
5023 Inpt_str$=UPC$(TRIM$(Temp$))
5024 Error_flag=1
5025 ELSE
5026 Error_flag=1
5027 Inpt_num=0
5028 BEEP
5029 DISP "***** Invalid numerical entry *****"
5030 WAIT 3
5031 END IF
5032 END IF
5033 OFF ERROR
5034 END IF
5035 SUBEND
5036 !
5037 Icode_inpt_str:SUB Icode_inpt_str(Prompt_string$,Inpt_str$)
5038!
5039! This subprogram is used to prompt the user and enter a string from the
5040! user. The user is prompted with Prompt_string$ and the caller is
5041! returned Inpt_str$.
5042!
5043 DISP Prompt_string$;
5044 LINPUT "",Inpt_str$
5045 Inpt_str$=UPC$(TRIM$(Inpt_str$))
5046 SUBEND
5047 !
5048 Icode_asc_str:DEF FNIcode_asc_str$(INTEGER Sixteen_bit_num)
5049!
5050! This function is used to convert a 16 bit integer into two characters.
5051! The Hi and Lo order bits are each converted into their ascii
5052! ascii representation. An ascii representation of a control or non
5053! printable character is replaces with a '.'.
5054!
5055 DIM Temp$[2]
5056 INTEGER Hi,Lo
5057 Hi=Sixteen_bit_num DIV 256
5058 Lo=Sixteen_bit_num MOD 256
5059 IF Hi>=32 AND Hi<=126 THEN
5060 Temp$=CHR$(Hi)
5061 ELSE
5062 Temp$="."
5063 END IF
5064 IF Lo>=32 AND Lo<=126 THEN
5065 Temp$[2]=CHR$(Lo)
5066 ELSE
5067 Temp$[2]="."
5068 END IF
5069 RETURN Temp$
5070 FNEND
5071 Lib_lib:SUB Lib_lib
5072 !************************************************************************
5073 !* This routine contains all the commons used in the all the library
5074 !* routines. It is needed by the application loader to handle commons.
5075 !************************************************************************
5076 COM /Lib_c1_lbl_info/ Input_labels$(1:63)[20],Source_labels$(1:63)[20]
5077 COM /Lib_c1_overload/ INTEGER Ovld_buffer(1:63)
5078 COM /Lib_c1_blk_ids/ REAL Icode_id,Input_buffer_id,Module_list_id,Ovld_buffer_id
5079 COM /Lib_c1_inp_info/ REAL Num_inputs,INTEGER Block_size,Max_tdly_label$[20]
5080 COM /Lib_c1_src_info/ REAL Num_sources,Cal_src_label$[20]
5081 COM /Lib_c1_icode_cd/ Source$(0:100)[80],INTEGER Object(0:100)
5082 COM /Lib_c1_icode_fo/ Info$(0:20)[40]
5083 COM /Lib_c1_dft_coef/ REAL Dft_coef_real(0:255,1:20),Dft_coef_imag(0:255,1:20)
5084 COM /Lib_c1_cal_con/ REAL Calcon_real(1:63,1:20),Calcon_imag(1:63,1:20)
5085 COM /Lib_c1_harm_dat/ REAL Cal_harmonics(-1:20),INTEGER Num_harmonics,REAL Phase_ramp,Hz_per_harmonic
5086 COM /Lib_c1_first/ INTEGER Runned_yet
5087 COM /Lib_c1_cal_data/ REAL Error_mag(1:63,-1:20),Error_phase(1:63,-1:20),Mag_deriv(1:63,-1:20),Phase_deriv(1:63,-1:20),Freq(-1:20)
5088 COM /Lib_c1_error/ INTEGER Errored,No_c1_cal
5089 !
5090 SUBEXIT
5091 SUBEND
5092!
5093 Lib_float_to_64:SUB Lib_float_to_64(Float,INTEGER I1,I2,I3,I4)
5094 !
5095 !Converts an IEEE 64-bit floating point number
5096 ! into its 4 16-bit integers. Used by the Icode Assembler
5097 !
5098 ASSIGN @Buff TO BUFFER [8];FORMAT OFF !8 bytes / fp word
5099 OUTPUT @Buff;Float
5100 ENTER @Buff;I1,I2,I3,I4
5101 SUBEND
5102 !
5103 ! PAGE ->
5104 !********************************************************************
5105 Lib_fft_coefs:SUB Lib_fft_coefs(INTEGER Coef_table(*))
5106 !
5107 ! This routine generates a 1/2 sine and 1/2 cos table in the
5108 !array Coef_table, for use by the default FFT algorithm supplied
5109 !in HP35651A ROM.
5110 !
5111 IF SIZE(Coef_table,1)<>4096 THEN CALL User_stop("Error in Lib_fft_coefs--FFT Coefficient array must be 4096 elements long")
5112 ON ERROR GOTO No_coef_file
5113 ASSIGN @Cfile TO FNLib_full_path$("FFT_COEFS");FORMAT OFF
5114 ENTER @Cfile;Coef_table(*)
5115 SUBEXIT
5116 No_coef_file:!
5117 DISP "Generating FFT coefficients (could not find file), be patient"
5118 OFF ERROR
5119 RAD
5120 Angle=2*PI/4096
5121 FOR I=0 TO 4095 STEP 2
5122 J=I/2
5123 Coef_table(I)=32767*COS(J*Angle)
5124 Coef_table(I+1)=32767*SIN(J*Angle)
5125 NEXT I
5126 DISP ""
5127 SUBEND
5128 !
5129 ! PAGE ->
5130 !********************************************************************
5131 Lib_sizeof:DEF FNLib_sizeof(INTEGER Array(*))
5132 !
5133 !This routine returns the total number of an elements in an integer
5134 ! array. (Depends on SIZE and RANK)
5135 !
5136 Num_elements=1
5137 FOR I=1 TO RANK(Array)
5138 Num_elements=Num_elements*SIZE(Array,I)
5139 NEXT I
5140 RETURN Num_elements
5141 FNEND
5142 !
5143 ! PAGE ->
5144 !********************************************************************
5145 Lib_fsizeof:DEF FNLib_fsizeof(Array(*))
5146 !
5147 !This routine returns the total number of an elements in a floating point
5148 ! array. (Depends on SIZE and RANK)
5149 !
5150 Num_elements=1
5151 FOR I=1 TO RANK(Array)
5152 Num_elements=Num_elements*SIZE(Array,I)
5153 NEXT I
5154 RETURN Num_elements
5155 FNEND
5156 !
5157 ! PAGE ->
5158 !********************************************************************
5159 Lib_full_path:DEF FNLib_full_path$(Filename$)
5160 ! This function tries to return the full path name of a file.
5161 ! Tries the filename itself first, then tries several combinations
5162 ! of prefixes and suffixes. The end user will probably want to change
5163 ! these to path names suitable for his/her location.
5164 !
5165 DIM Try_path$[160]
5166 !
5167 DIM Prefix$(0:1)[80]
5168 DIM Suffix$(0:6)[80]
5169 !
5170 !change the next lines to appropriate prefixes
5171 Prefix$(0)="" !the most likely prefix?
5172 Prefix$(1)="" !yet another prefix
5173 !
5174 Suffix$(0)=""
5175 Suffix$(1)=":,702,0"
5176 Suffix$(2)=":,702,1"
5177 Suffix$(3)=":,703,0"
5178 Suffix$(4)=":,703,1"
5179 Suffix$(5)=":INTERNAL,4,0"
5180 Suffix$(6)=":INTERNAL,4,0"
5181 !
5182 FOR J=0 TO 6
5183 FOR I=0 TO 1
5184 Try_path$=Prefix$(I)&Filename$&Suffix$(J)
5185 ASSIGN @File TO Try_path$;RETURN Error_code
5186 SELECT Error_code
5187 CASE 0,58 !No error, Improper File Type: We found it
5188 RETURN Try_path$
5189 CASE 52,56,62,72,76,80,82,93 !Errors to ignore
5190 CASE ELSE
5191 User_error("***In Lib_full_path$: "&VAL$(Error_code)&" ***")
5192 RETURN ""
5193 END SELECT
5194 NEXT I
5195 NEXT J
5196 User_error("***Lib_full_path$: "&Filename$&" not found ***")
5197 RETURN ""
5198 FNEND
5199 !
5200 ! PAGE ->
5201 !************************************************************************
5202 Lib_32_to_16:SUB Lib_32_to_16(Val32bit,INTEGER Ihigh,Ilow)
5203 !
5204 ! Converts the floating point value in Val32bit (in range -2^31 to
5205 ! 2^31 - 1 ) to 2 integers: Ihigh with the upper 16 bits and Ilow
5206 ! with the lower 16 bits of the 2's complement representation.
5207 !
5208 Float_temp=Val32bit
5209 Neg=0
5210 IF Float_temp=0 THEN
5211 Neg=1
5212 Float_temp=-Float_temp
5213 Float_temp=Float_temp-1
5214 END IF
5215 Ihigh=INT(Float_temp/65536)
5216 Float_temp=Float_temp-Ihigh*65536
5217 IF Float_temp>32767 THEN
5218 Ilow=INT(Float_temp-32768)
5219 Ilow=BINEOR(Ilow,-32768)
5220 ELSE
5221 Ilow=Float_temp
5222 END IF
5223 IF Neg=1 THEN
5224 Ihigh=BINCMP(Ihigh)
5225 Ilow=BINCMP(Ilow)
5226 END IF
5227 SUBEND
5228 !
5229 !***********************************************************************
5230 ! PAGE ->
5231 User_error:SUB User_error(Aline$)
5232 !This subprogram reports errors to the user using the DISP line,
5233 !beeps, waits 3 sec, and exits.
5234 BEEP 100,.1
5235 DISP Aline$
5236 WAIT 3
5237 DISP
5238 SUBEND
5239 !-------------------------------------------------------------------
5240 User_stop:SUB User_stop(Aline$)
5241 !This subprogram reports fatal program errors and PAUSEs the program.
5242 !The STEP key can be used to get back to the calling context.
5243 BEEP 100,.5
5244 DISP Aline$
5245 PAUSE
5246 DISP
5247 SUBEND
5248 !-------------------------------------------------------------------