-
Notifications
You must be signed in to change notification settings - Fork 0
/
spitsys.mar
1861 lines (1860 loc) · 59.6 KB
/
spitsys.mar
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
.TITLE SPITSYS OSINT Modules [Except I/O]
;
; COPYRIGHT (c) 1981 under BERNE and UNIVERSAL COPYRIGHT
; LAW by DEWAR INFORMATION SYSTEMS CORPORATION.
;
; The software described in this document is proprietary
; to DEWAR INFORMATION SYSTEMS CORPORATION and furnished
; to the purchaser under a license for use on a single
; computer system and can be copied (with the inclusion
; of DEWAR INFORMATION SYSTEMS CORPORATIONS's copyright
; notice) only for use in such system.
;
;
; This software is the property of:
;
; Steven G. Duff
; c/o Dewar Information Systems Corp.
; 221 West Lake Street
; Oak Park, Illinois 60302
; (312) 524-1644
;
.PAGE
.SBTTL SPITSYS - Definitions
;
.LIBRARY "SYS$LIBRARY:LIB"
.LIBRARY "SPITMACS"
;
IDENT SPITSYS,B,7
;
$CHFDEF ;Mechanism Argument Vector Offsets
$CLIDEF ;Define CLI Offsets.
$IACDEF ;Image Activator Flags
$IHDDEF ;Image Header Offsets
$IHADEF ;Image Activator Offsets
$JPIDEF ;Define JPI Codes
$RMSDEF ;RMS definitions
$SECDEF ;Section map offsets
$SSDEF ;System Exception Definitions
.PAGE
.SBTTL SPITSYS - Revision History
;
; V35-B7 10-AUG-1981 [SGD]:
; o Fixed stack size computation in SYSXI_RELOAD
; o Changed SYSXI_RELOAD to use file to create/map private sections
; rather than read data in directly.
;
; V35-B6 08-AUG-1981 [SGD]:
; o Enhancement to SYSBX to handle new semantics of /OUTPUT=...
; o Modification of SYSXI_RELOAD and SYSXI_CRCCODE to handle /CRC & /NOCRC
;
; V35-B5 30-JUL-1981 [SGD]:
; o Put startup line &ERRTEXT logic in SYSXI_RELOAD so that command
; line gets copied in on a return from EXIT(...)
;
; V35-B4 18-JUL-1981 [SGD]:
; o Incorporated access check in SYSEX$ on returned reference pointer
; in R1 (if R0 indicates success). This helps insure that an
; access violation is caught before it makes its way back into
; SYSEX proper, where no execption handler exists.
;
; V35-B3 18-JUN-1981 [SGD]:
; o Altered logic in SYSPP to clear SPITGO's option bits before giving
; the options to SPITBOL.
;
; V35-B2 25-MAY-1981 [SGD]:
; o Fixed minor problem in SYSID - [...] was around account string which
; seems ridiculous.
; o Inserted SYSEX, SYSLD and SYSUL
;
; V35-B1 18-APR-1981 [SGD]:
; o New modules SYSXI and SYSIDENT
; o SYSEJ handling of Execution Suppressed and No Output File endruns
; changed as VMS does not print informational messages on $EXIT service.
; SYSID now uses logical name SYS$SITENAME as the site name
;
; V35-A1 13-FEB-1981 [SGD]:
; o Revised SYSEM to use standard message file.
; o Deleted SPITGO register save area , and set SYSEJ to use $EXIT
; instead. Changed SYSBX to default &CODE at startup to one.
; o Removed SYSCHK as no longer used (see SPITGO)
;
; V35-002 14-JUN-1980 [SGD]:
; o Incorporated logic to put initial startup command line string
; into &ERRTEXT. (";" made legal as command line terminator - see SPITGO).
.PAGE
.SBTTL SPITSYS - Preamble
;
; This package contains all the VAX/VMS MACRO SPITBOL OSINT (including
; the error message handler), except those dealing directly with I/O.
; It includes...
;
; SYSAX - Called just after execution of program begins
; SYSBX - Called just before execution of the program begins
; SYSDC - Check date for trial version
; SYSDM - Dump core
; SYSDT - Get current DATE/TIME for DATE()
; SYSEJ - End of job processing
; SYSEM - Get text of error message
; SYSEX - Call external function
; SYSHS - HOST() Function
; SYSID - Provide ID strings for banner
; SYSIDENT- Return version strings (4 chars) in R0/R1
; SYSINV - Invalid jump handler
; SYSLD - Load external function (LOAD(...))
; SYSMM - Get more address space for dynamic
; SYSMX - Get MXLEN value
; SYSPP - Get startup print parameters
; SYSTM - Get execution time so far
; SYSTT - Toggle trace switch
; SYSUL - Unload external function (UNLOAD(...))
; SYSXI - EXIT() Function
;
; Those routines with a two letter SYS** suffix are 'official'
; MACRO SPITBOL OSINT routines. A longer suffix is indicative of
; an OSINT routine which is peculiar to the VAX/VMS version of
; MACRO SPITBOL only.
;
.PAGE
.SBTTL SYSAX: After Program Execution (No-Op)
;
; This module is called by SPITBOL after to executing the program.
; At the present time, there is nothing for this module to do,
; so it just returns.
;
PROGSECT
;
; Calling Sequence:
;
; JSB SYSAX
;
SYSAX::
RSB ;That's easy!
.PAGE
.SBTTL SYSBX: Before Program Execution
;
; This module is called by SPITBOL prior to executing the program,
; but after it has been interpreted.
;
; This module does the following:
;
; o Assuming the command line is not null, an SCBLK is allocated
; in dynamic and the startup command line copied into it. Then
; &ERRTEXT (R$ETX) is pointed to it.
; o Sets default value of &CODE to one to avoid silly message at
; image rundown from VMS when returned code is zero.
; o Closes and re-opens new SYSOUT channel if /NOOUTPUT or
; /OUTPUT=... specified at startup. New name is one given, or NL:
; if /NOOUTPUT requested.
;
PROGSECT
;
; Calling Sequence:
;
; JSB SYSBX
;
SYSBX::
PUSHR #^M<R6,R7,R8,R9,R10> ;Save volatile regs. for exit.
MOVL PARSE_GCBLK+CLI$Q_RQDESC,R6 ;Get command line length.
BEQL 100$ ;Forget it if null.
JSB ALOCS ;Else allocate SCBLK for it.
MOVC3 R8,- ;Copy in characters
@PARSE_GCBLK+CLI$Q_RQDESC+4,4*SCHAR(R9)
MOVL R9,R$ETX ;And Point &ERRTEXT at it.
;
; Merge Here After R$ETX (&ERRTEXT) set properly.
;
100$: POPR #^M<R6,R7,R8,R9,R10> ;Restore 'em.
MOVL #1,KVCOD ;Set default &CODE
;
; Check for /OUTPUT=...
;
TSTL SPITGO_OUTLEN ;Check for /OUTPUT=... specified
BEQLU 200$ ;Continue if not
$CLOSE FAB=FAB_SYSOUT ;Else close old channel
PUSHR #^M<R2,R3,R4,R5> ;Save registers across move
MOVC5 SPITGO_OUTLEN,SPITGO_OUTNAM- ;Move in new name string
,#0,#RSA_SYSOUT-FNM_SYSOUT,FNM_SYSOUT
POPR #^M<R2,R3,R4,R5> ;Restore
MOVB SPITGO_OUTLEN,FAB_SYSOUT+FAB$B_FNS ;Set length
JSB SET_SYSPP ;Set options (routine in SPITGO)
PUSHR #^M<R6,R7,R8,R9,R10> ;Save registers across call
CLRL R8 ;Not TERMINAL association
JSB PRPAR ;Make SPITBOL read 'em (in SPITBOL)
POPR #^M<R6,R7,R8,R9,R10> ;Save registers across call
;
; Merge to return
;
200$: RSB ;Off we go...
.PAGE
.SBTTL SYSDC: Date Check for Trial Versions (No-Op)
;
; This module is called to perform a date check for a trial
; copy of Spitbol against an 'expiration date'.
;
; NOTE: This module simply returns at present
;
PROGSECT
;
; Calling Sequence:
;
; JSB SYSDC
; (Return Iff Date Ok)
;
SYSDC::
RSB ;Legal User - Go Ahead
.PAGE
.SBTTL SYSDM: Dump Memory (No-Op)
;
; Spitbol calls this module as a result of encountering a
; call to DUMP(N) with N >= 3. The intended purpose is to give
; a memory dump for debugging purposes. The debugger can
; be linked in if desired, so this routine is a no-op.
;
PROGSECT
;
; Calling Sequence:
;
; JSB SYSDM
;
SYSDM::
RSB ;Back we go.
.PAGE
.SBTTL SYSDT: DATE() Function
;
; The SYSDT Module is called from Spitbol as a result of encountering
; a user call to DATE(). This module returns a pseudo-scblk in the
; form:
;
; "DD-MMM-YYYY HH:MM:SS.CC"
;
WORKSECT
;
; Pseudo-SCBLK for Date String
;
SYSDT_SCBLK: .LONG 0
.LONG 0
SYSDT_STRST: .ASCII "DD-MMM-YYYY HH:MM:SS.CC"
SYSDT_STRND: .ALIGN LONG,0
SYSDT_STRLN= SYSDT_STRND-SYSDT_STRST
;
PROGSECT
;
; Calling Sequence:
;
; JSB SYSDT
; (XL/R10) - Pseudo-SCBLK containing date string
;
SYSDT::
MOVL #SYSDT_STRLN,SYSDT_SCBLK ;Set Descriptor Length
MOVAL SYSDT_STRST,SYSDT_SCBLK+4 ;Set Descr. Char. Ptr.
$ASCTIM_S TIMBUF=SYSDT_SCBLK ;Fill In String
MOVL #SYSDT_STRLN,SYSDT_SCBLK+4 ;Set SCBLK Length
MOVAL SYSDT_SCBLK,R10 ;Point to SCBLK
RSB ;Back to Spitbol
.PAGE
.SBTTL SYSEJ: End of Run Processing
;
; This module is called by SPITBOL to terminate the run.
;
PROGSECT
;
; Calling Sequence:
;
; (WA/R6) - Value of Abend Keyword
; (WB/R7) - Value of Code Keyword
; (XL/R10) - Ptr. to FCBLK Chain or 0 if None
; JSB SYSEJ
; (No Return - Back to VMS)
;
SYSEJ::
MOVL R7,R0 ;Set &CODE As Return Code
CMPL R0,#998 ;Is This "NO SYSOUT" Error?
BNEQ 200$ ;Branch If Not
MOVL #SPITBOL_NOSYSOUT,R0 ;Put real error num in R0
BRB 300$ ;And out
;
; Not 998. Perhaps 999?
;
200$: CMPL R0,#999 ;Is This "EXEC. SUPP" Error?
BNEQ 300$ ;Branch To Exit If Not
PUSHL #SPITBOL_EXSUP ;Stack arg for LIB$SIGNAL
CALLS #1,LIB$SIGNAL ;Note the informational message
MOVL #1,R0 ;Indicate success and merge
;
; Merge Here To Exit With Return Code In R0
;
300$: $EXIT_S R0
.PAGE
.SBTTL SYSEM: Get Text of Error Message
;
; This module is called by the interpreter (only) to get the
; text of one of the error messages. The messages are defined
; externally in a .MSG file.
;
CONSSECT
;
; Define the parameters for GETMSG options
;
SYSEM_TEXT = ^X01 ;Tell GETMSG to return text
SYSEM_IDENT = ^X02 ;Tell GETMSG to return identification
SYSEM_SEVERITY = ^X04 ;Tell GETMSG to return severity indicator
SYSEM_COMPONENT = ^X08 ;Tell GETMSG to return component name
SYSEM_FLAGS = SYSEM_TEXT
SYSEM_MSGLEN = 80 ;Maximum error message length
;
WORKSECT
;
; SCBLK for returned message text
;
SYSEM_MSG:: .LONG 0,0
.BLKB SYSEM_MSGLEN
;
; Descriptor for message area
;
.ALIGN LONG
SYSEM_MSGDESCR::.LONG SYSEM_MSGLEN
.LONG SYSEM_MSG+8
.PAGE
PROGSECT
;
; Calling Sequence:
;
; (WA/R6) - Message ID
; JSB SYSEM
; (XR/R9) - Pointer To SCBLK for Message
; or Null SCBLK If No Message
;
SYSEM::
CLRL SYSEM_MSG+4 ;Assume null string
TSTL R6 ;Check error number
BLSS 100$ ;Null if below zero
CMPL R6,#SPITBOL_MAXMSG ;Check against upper limit
BGTR 100$ ;Null if above
ASHL #3,R6,R0 ;Get message offset
ADDL2 #SPITBOL_ERR000,R0 ;Bias to first code
$GETMSG_S R0,SYSEM_MSG+4,- ;Get the text
SYSEM_MSGDESCR,#SYSEM_FLAGS,<>
;
; Merge here to exit
;
100$: MOVAL SYSEM_MSG,R9 ;Point to SCBLK with text
RSB ;Return
.PAGE
.SBTTL SYSEX: Call LOADed Function
SAVESECT
;
; These are scratch locations that are in the SAVE section,
; since LOADed functions are not preserved across an EXIT(-n)
;
SYSEX_ICBLK:: .LONG 0,0 ;Pseudo ICBLK
SYSEX_RCBLK:: .LONG 0,0,0,0,0 ;Biggest RCBLK possible (REAL*16)
.PAGE
PROGSECT
; SYSEX is called to pass control to an external function
; previously loaded with a call to SYSLD.
;
; Upon return from the function, the low bit of R0 should be
; 1 or 0 to indicate success or failure respectively. R1
; is ignored for failure returns. For success, R1 should be
; a reference pointer to an object which depends on the
; result type declared in the call to LOAD.
;
; o For strings, R1 should point to a string descriptor. The
; class/type component of the descriptor is ignored, that is,
; all strings are assumed to be fixed length, and the maximum
; length is 65535.
;
; o For integers and reals, R1 should be a reference pointer to
; the value
;
; o For other types (unconverted result), R1 should point to
; a standard block which has correct format including the
; type word. This is copied into dynamic by Spitbol upon
; return.
;
; Calling Sequence:
;
; (XS/SP) - Pointer to stacked arguments [last at 0(SP)]
; (XL/R10) - Pointer to EFBLK for external function
; (WA/R6) - Number of stacked arguments
; JSB SYSEX - Call to executed LOADed function
; .LONG LOC - Return thread for failure exit
; (XS/SP) - Popped past arguments
; (XR/R9) - Pointer to returned result
; (WC/R8) - Destroyed (for string returns)
;
SYSEX::
CALLG 4(SP),SYSEX$ ;Call appendage to call loaded function
BLBC R0,SYSEX_FAIL ;Fail if status no good
MOVL #EFRSL,R11 ;Get index of result type in R11
CASEL (R10)[R11],#0,#3 ;Case on result type expected
100$: .WORD SYSEX_UNCONV-100$ ;Unconverted
.WORD SYSEX_STRING-100$ ;String
.WORD SYSEX_INTEGER-100$ ;Integer
.WORD SYSEX_REAL-100$ ;Real
;
; This case is for unconverted results. R1 points to the result
; block, which has to be in exactly the correct format. We
; just copy R1 into R9 and merge to return.
;
SYSEX_UNCONV::
MOVL R1,R9 ;Copy result pointer
BRW SYSEX_DONE ;Merge to exit
.PAGE
;
; This case is for returning strings. R1 points to a string
; descriptor. We copy it into dynamic and set the type word.
; A pointer to this block is the returned value. Note that
; it is possible that the garbage collector will be invoked,
; so the stack and XL (R10) must be 'correct'. Beware also,
; WC is destroyed.
;
SYSEX_STRING::
PUSHR #^M<R1,R6> ;Save arg count and descriptor ref.
MOVZWL (R1),R6 ;Get length of string
JSB ALOCS ;Allocate an SCBLK
POPR #^M<R1,R6> ;Restore regs
PUSHR #^M<R1,R2,R3,R4,R5> ;Save registers across MOVC
MOVC3 R8,@4(R1),8(R9) ;Move characters into SCBLK frame
POPR #^M<R1,R2,R3,R4,R5> ;Restore regs
BRW SYSEX_DONE ;Exit with SCBLK ptr. in XR/R9
;
; Come here to return an integer. R1 is a reference pointer to
; the longword integer value to be returned. For this we
; build a pseudo-ICBLK (sans type word) in local store and return
; a pointer to it. SPITBOL will copy it into dynamic upon return
;
SYSEX_INTEGER::
MOVL (R1),SYSEX_ICBLK+4 ;Copy in integer value
MOVAL SYSEX_ICBLK,R9 ;Point result at it
BRB SYSEX_DONE ;Merge to exit
;
; Here to return a real. The strategy is the same as for an integer,
; however a MOVC is done so that these routines can be independent
; of the length of real numbers.
;
SYSEX_REAL::
PUSHR #^M<R1,R2,R3,R4,R5> ;Save registers across MOVC
MOVC3 #4*CFP$R,(R1)- ;Copy in the real
,SYSEX_RCBLK+4
POPR #^M<R1,R2,R3,R4,R5> ;Restore regs.
MOVAL SYSEX_RCBLK,R9 ;Point to it
;
; Merge here with result pointer in R9 to return to interpreter.
;
SYSEX_DONE::
MOVL (SP)+,R11 ;Hang on to return vector
MOVAL (SP)[R6],SP ;Pop off passed argument junk
JMP 4(R11) ;Return (past error thread)
;
; Here for failure exit.
;
SYSEX_FAIL::
MOVL (SP)+,R11 ;Get return vector in scratch reg
MOVAL (SP)[R6],SP ;Pop off passed argument junk
JMP @(R11) ;Jump through failure thread.
.PAGE
.SBTTL SYSEX$: Setup and CALL External Function
;
; This routine creates an environment for calling the external
; function. This involves several duties.
;
; First the stack is built for the external function. This involves two
; distinct passes. During pass 1, the actual values are stuffed
; on the stack. Integers and reals are copied from their
; respective blocks, and strings have a descriptor built.
; Other objects (if they can get through) are simply pointed to
; directly by a reference pointer during pass 2, so no value
; is stacked for them during pass 1.
; During pass 2, references to these values are stacked;
; these form the actual arguments passed to the procedure.
; Note that integers and reals are protected, string contents
; and other objects are not.
;
; After building the stack, the SYSEX$_EXCEP condition handler
; is inserted in the call frame to catch any no-nos not handled
; by the external image. (Recovery is attempted by forcing
; function failure.)
;
; Then the image is called. After it returns, SYSEX$ returns
; to SYSEX where the returned value and success/failure is
; handled.
;
PROGSECT
;
; Calling Sequence:
;
; (WA/R6) - Argument count to function
; CALLS R6,SYSEX$
; (R0) - Low bit set/clear to indicate success/failure
; (R1) - Points to object returned if success
;
SYSEX$::.WORD ^M<R2,R3,R4,R5,R6,R7,R8,R9,R10>
.PAGE
;
; Pass 1 - Build values on stack
;
; R0 - Pointer to current entry argument block
; R1 - Saved SP at start of pass 1 - for pass 2 (not changed)
; R11 - Argument/loop counter
; SP - Pointer to current stacked value
; AP - Entry stack pointer (not changed)
;
MOVL SP,R1 ;Save start of values for pass 2
MOVL #-1,R11 ;Initialize loop count
;
; Loop here to stack entry arg. values
;
50$: AOBLSS R6,R11,60$ ;Bump loop counter and test
BRW 400$ ;Branch - loop finished
;
; Here to continue pass 1 loop for another iteration
;
60$: MOVL (AP)[R11],R0 ;Get pointer to block
CMPL (R0),#B$ICL ;Check for integer
BNEQU 100$ ;Try another type if not
MOVL 4(R0),-(SP) ;Stack block value
BRW 300$ ;Merge to loop
;
; Not integer - try real number type
;
100$: CMPL (R0),#B$RCL ;Is it real number?
BNEQU 200$ ;Try another type if not
SUBL2 #4*CFP$R,SP ;Give room for number
PUSHR #^M<R0,R1,R2,R3,R4,R5> ;Hold registers across MOVC
MOVC3 #4*CFP$R,4(R0),24(SP) ;Move in number (works for any type)
POPR #^M<R0,R1,R2,R3,R4,R5> ;Restore regs.
BRW 300$ ;Merge to loop
;
; Not real - try string
;
200$: CMPL (R0),#B$SCL ;Is it string?
BNEQU 300$ ;Branch if not (ignore it)
MOVAL 8(R0),-(SP) ;Push address part of descriptor
MOVL 4(R0),-(SP) ;Push length part
;
; Merge here to continue loop
;
300$: BRW 50$ ;Branch back for another shot
.PAGE
;
; Here when entry argument pass 1 complete. Stack the argument
; count and current stack pointer, and then fix the pointers for
; pass 2.
;
;
; R0 - Pointer to current block under consideration.
; R1 - Pointer to current value (stacked in pass 1)
; R11 - Loop index
; SP - Pointer to stacked reference pointer
; AP - Entry stack pointer (not changed)
;
400$: MOVL #-1,R11 ;Initialize loop count
;
; Loop here to stack entry arg. values
;
450$: AOBLSS R6,R11,460$ ;Bump loop counter and test
BRW 1000$ ;Branch - loop finished
;
; Here to continue pass 2 loop for another iteration
;
460$: MOVL (AP)[R11],R0 ;Get pointer to block
CMPL (R0),#B$ICL ;Check for integer
BNEQU 500$ ;Try another type if not
SUBL2 #4,R1 ;Point to start of integer value
BRB 700$ ;Merge to loop
;
; Not integer - try real number type
;
500$: CMPL (R0),#B$RCL ;Is it real number?
BNEQU 600$ ;Try another type if not
SUBL2 #4*CFP$R,R1 ;Point to start of value
BRB 700$ ;Merge to loop
;
; Not real - try string
;
600$: CMPL (R0),#B$SCL ;Is it string?
BNEQU 800$ ;Branch if not
SUBL2 #8,R1 ;Point to descriptor start
;
; Merge here to stuff reference pointer to standard object.
;
700$: MOVAL (R1),-(SP) ;Stuff reference pointer
BRB 900$ ;Branch to continue loop
;
; Here when we have something other than standard number/string.
; Just stuff a reference pointer directly to it.
;
800$: MOVAL (R0),-(SP) ;Stuff pointer
;
; Merge here to continue pass 2 loop
;
900$: BRW 450$ ;Jump to continue loop
.PAGE
;
; Here when pass 2 finished. Get entry point and call function
;
1000$: MOVL @4*EFCOD(R10),R0 ;Point to image header data
MOVZWL IHD$W_ACTIVOFF(R0),R1 ;Offset to activation vectors
MOVAB IHA$L_TFRADR1(R0)[R1],R1;Address of transfer vectors
MOVL (R1),R0 ;Try the first vector
BGTR 1100$ ;Got it if not in sysspace
MOVL 4(R1),R0 ;Else try the second
BGTR 1100$ ;Good if not in system space
MOVL 8(R1),R0 ;Else use the third
;
; Here when transfer address in R0 to call routine
; Routine should return with status in R0 and value ptr. in R1 (if
; low bit of R0 set).
;
1100$: MOVAL SYSEX$_EXCEP,(FP) ;Set cond. handler to catch returns
CALLS R6,(R0) ;Call it
BLBC R0,1200$ ;No access check if failed
TSTL (R1) ;Else force exception if given crud
;
; Merge here to return when we are reasonably certain that R1 is OK
;
1200$: RET ;Return to finish up.
.PAGE
.SBTTL SYSEX$_EXCEP: Condition Handler for External Functions
;
; The following code is a condition handler established prior to
; entering a loaded function. It's primary purpose is to
; catch unexpected (unhandled) conditions from the loaded function,
; and attempt to recover by simulating a failure
;
; In all cases, an unwind is performed to get back to SYSLD.
;
SYSEX$_EXCEP::.WORD 0
MOVL 4(AP),R0 ;Get address of signal arg. vector
CMPL 4(R0),#SS$_UNWIND ;Are we unwinding through?
BNEQ 50$ ;Press on if not
MOVL #SS$_RESIGNAL,R0 ;Else allow unwind to continue
RET ;...and return
;
; Here if not unwinding
;
50$: SUBL3 #2,@4(AP),R1 ;Get number of args to stack
MOVL R1,R0 ;Save it
;
; Loop here to push all the signal argument vector stuff we are
; given back on to the stack for this LIB$SIGNAL (re-)call
;
60$: PUSHL @4(AP)[R1] ;Push next argument in vector
SOBGTR R1,60$ ;Move up in vector and do again
SUBL3 #1,@4(AP),R1 ;Get saved PC arg. vector ptr. index
CLRL -(SP) ;No FAO args
PUSHL #SPITBOL_LOADUNEXTRY ;Set message to signal
PUSHL @4(AP)[R1] ;Indicate PC at failure
PUSHL #1 ;One FAO arg.
PUSHL #SPITBOL_LOADUNEXCOND ;Give unexpected condition noise
ADDL2 #5,R0 ;Add in fixed argument count
CALLS R0,LIB$SIGNAL ;Signal it
MOVL #CHF$L_MCH_SAVR0/4,R0 ;Get index of saved R0 in mech. vec.
CLRL @8(AP)[R0] ;Set saved R0 to indicate failure
$UNWIND_S ;Unwind back to SYSEX
RET ;BACK!
.PAGE
.SBTTL SYSHS: HOST() Function
;
; This module is called when Spitbol encounters a call to HOST(a,b,c).
; The single standarized entry is when all three arguments are null.
; In this case, HOST() returns a string of the form:
;
; VAX:VMS:sitename-from-sysid:username:[accountname]
;
; At present, no other entries are defined, and will cause errors.
;
WORKSECT
;
; Request Area For JPI Get Username
;
SYSHS_JPUNM: .WORD 12 ;Max. Return Length
.WORD JPI$_USERNAME ;Request Username Code
.LONG 0 ;Buffer Address - Filled In Later
.LONG SYSHS_UNMLN ;Return Length Count There
.LONG 0 ;End Of Request List
;
; Request Area For JPI Get Account Name
;
SYSHS_JPANM: .WORD 8 ;Max. Return Length
.WORD JPI$_ACCOUNT ;Request Accountname Code
.LONG 0 ;Buffer Address - Filled In Later
.LONG SYSHS_ANMLN ;No Return Length Count
.LONG 0 ;End Of Request List
;
; SCBLK Skeleton To Be Returned For Null Args Entry
;
SYSHS_SCBLK: .LONG 0 ;Dummy Type
.LONG 0 ;Length (Filled In Later)
.BLKB 128 ;SCBLK Data (Filled In Dynamically)
;
; Return areas for GETJPI calls
;
SYSHS_UNMLN: .LONG 0 ;# Characters in Username (From JPI)
SYSHS_ANMLN: .LONG 0 ;Length Of Account Name String
.PAGE
;
; Calling Sequence:
;
; (WA/R6) - Argument a
; (XL/R10) - Argument b
; (XR/R9) - Argument c
; JSB SYSHS
; .LONG Erroneous Args
; .LONG Execution Error
; .LONG SCBLK Pointer in XL or 0 if not available
; .LONG Return Nullstring
; .LONG Return Result in XR
; .LONG Cause Statement Failure
;
SYSHS::
CMPL R6,#NULLS ;Check For Arg 1 Null
BEQL 100$ ;Branch If So
BRW 1000$ ;Else Try Special Operation
;
; Here When First Arg Known Null
;
100$: CMPL R10,#NULLS ;Check For Arg 2 Null
BEQL 200$ ;Branch If So
BRW 9999$ ;Error If 1st Arg Null and 2nd Not
;
; Here When 1st and 2nd Args Known Null
;
200$: CMPL R9,#NULLS ;Check For Arg 3 Null
BEQL 300$ ;Branch If So
BRW 9999$ ;Error If 1st & 2nd Args Null & 3rd Not
;
; Here When All Three Args Null.
;
300$: PUSHR #^M<R9,R10> ;Save Regs across call
JSB SYSID ;Make sure SYSID has been called
POPR #^M<R9,R10> ;Ignore returns
PUSHR #^M<R2,R3,R4,R5> ;Save Registers Across MOVs
MOVAL SYSHS_SCBLK+8,R3 ;Point To Start Of Data Area
MOVC3 #SYSID$K_CPIDN,- ;Move In Machine ID
SYSID_CPIDN,(R3)
MOVB #^A":",(R3)+ ;Move In ":"
MOVC3 #SYSID$K_OSIDN,- ;Move In Operating System ID
SYSID_OSIDN,(R3)
MOVB #^A":",(R3)+ ;Move In ":"
MOVC3 #SYSID$K_SITEID,- ;Move In Site Ident
SYSID_SITEID,(R3)
MOVB #^A":",(R3)+ ;Move In ":"
MOVL R3,SYSHS_JPUNM+4 ;Set Place For Username String Return
$GETJPI_S ITMLST=SYSHS_JPUNM ;Move In Username Str. (.LE. 12 Chars)
ADDL2 SYSHS_UNMLN,R3 ;Point Past It
;
; Loop Here To Back Over Trailing Blanks In Username String
;
400$: CMPB -(R3),#^A" " ;Is Preceeding Char A Blank?
BEQLU 400$ ;Yes. Continue Backwards Loop.
INCL R3 ;Space Over Good Character
MOVB #^A":",(R3)+ ;Close Off Username String
MOVL R3,SYSHS_JPANM+4 ;Set Account Name Pointer
$GETJPI_S ITMLST=SYSHS_JPANM ;Request String
ADDL2 SYSHS_ANMLN,R3 ;Point Past It
;
; Loop Here To Trim Blanks From Account Name
;
500$: CMPB #^A" ",-(R3) ;Check Previous Character For Blank
BEQLU 500$ ;Loop If A Blank
INCL R3 ;Point Past It
CLRL (R3) ;Make Sure SCBLK is zero padded
SUBL3 #SYSHS_SCBLK+8,R3,- ;Stuff Actual Length In SCBLK
SYSHS_SCBLK+4
POPR #^M<R2,R3,R4,R5> ;Restore Saved Registers
MOVAL SYSHS_SCBLK,R10 ;Point XL At SCBLK
BRW 9997$ ;Exit With Result In XL
.PAGE
;
; Here If Arg1 Not Null. At Present, There Are No Such Defined
; Entries, So SYSHS Registers An Argument Error Here.
;
1000$: BRW 9999$ ;Exit Signalling Arg. Error
;
; Here For Statement Failure Exit
;
9994$: ADDL2 #4,(SP) ;Bias To Next Return Thread
;
; Here For Return Result In XR
;
9995$: ADDL2 #4,(SP) ;Bias To Next Return Thread
;
; Here For Return Null
;
9996$: ADDL2 #4,(SP) ;Bias To Next Return Thread
;
; Here For SCBLK Pointer In XL
;
9997$: ADDL2 #4,(SP) ;Bias To Next Return Thread
;
; Here For Execution Error
;
9998$: ADDL2 #4,(SP) ;Bias To Next Return Thread
;
; Here For Erroneous Argument Error
;
9999$: MOVL (SP)+,R11 ;Get Return Thread Pointer From Stack
JMP @(R11)+ ;Jump Through It
.PAGE
.SBTTL SYSID: Return ID Titles
;
; This module returns two header SCBLKS to Spitbol. The first is
; appended by SPITBOL to the basic header line, and the second is
; used as the second header line. For a site-id, the VMS logical
; name SYS$SITENAME is translated and if it is defined, the text
; is used.
;
CONSSECT
;
; $ASCTIM String Descriptor
;
DATIM_DESCR: .LONG SYSID$K_DATIM ;Field Length
.LONG SYSID_DATIM ;String Data Address
;
; Sitename Descriptors
;
SYSID_SITESYM:: .ASCID /SYS$SITENAME/ ;Logical name w/ site id
.ALIGN LONG,0
SYSID_SITEDESCR::.LONG SYSID$K_SITEID ;Descriptor for $TRNLOG
.LONG SYSID_SITEID
.PAGE
WORKSECT
;
; Return length of sitename string from TRNLOG
;
SYSID_SITELEN:: .LONG 0 ;Length of translated string
;
; Template for SCBLK #1
;
SYSID_SCBLK1:: .LONG 0 ;SCBLK Pointer need not be set
.LONG SCB1_END-<SYSID_SCBLK1+8> ;SCBLK Length Need Be.
SYSID_VERSN:: .ASCII "(vvvv-mmmm) " ;Major/Minor version data
SYSID_DATIM:: .ASCII "dd-mmm-yyyy hh:mm" ;Filled in by $ASCTIM above.
SYSID$K_DATIM==.-SYSID_DATIM
SCB1_END: .ALIGN LONG,0 ;Pad out SCBLK
;
; Template for SCBLK #2
;
SYSID_SCBLK2:: .LONG 0 ;SCBLK Pointer set by SPITBOL
.LONG SCB2_END-<SYSID_SCBLK2+8> ;Length for SCBLK #2
SYSID_CPIDN:: .ASCII "VAX" ;Machine ID
SYSID$K_CPIDN==.-SYSID_CPIDN
.ASCII " - "
SYSID_OSIDN:: .ASCII "VMS" ;Operating System
SYSID$K_OSIDN==.-SYSID_OSIDN
.ASCII " "
SYSID_SITEID:: .ASCII "* SYS$SITENAME? *" ;Site Name
.BYTE ^A" "[28-<.-SYSID_SITEID>] ;Max is 28 Chars.
SYSID$K_SITEID==.-SYSID_SITEID
.ASCII " "
SYSID_FILID:: .BYTE ^A" "[40] ;Input File - Set in SPITGO
SYSID$K_FILID==.-SYSID_FILID
SCB2_END: .ALIGN LONG,0 ;Pad out SCBLK
.PAGE
PROGSECT
;
; Calling Sequence:
;
; JSB SYSID
; (XR/R9) - Pointer to 1st SCBLK
; (XL/R10) - Pointer to 2nd SCBLK
;
SYSID::
$ASCTIM_S TIMBUF=DATIM_DESCR ;Fill in date and time data
JSB SYSIDENT ;Get version data
MOVL R0,SYSID_VERSN+1 ;Stuff it
MOVL R1,SYSID_VERSN+6 ;Stuff minor version too
PUSHR #^M<R2,R3,R4,R5> ;Don't Lose Registers
MOVZBL NAM_SYSIN+NAM$B_RSL,R2 ;Get Length Of Result Name String
MOVC5 R2,RSA_SYSIN,#^A" ",#SYSID$K_FILID,SYSID_FILID
$TRNLOG_S LOGNAM=SYSID_SITESYM- ;Try to get translation of site
,RSLBUF=SYSID_SITEDESCR,RSLLEN=SYSID_SITELEN
BLBC R0,100$ ;Do nothing if it didn't work
MOVL SYSID_SITELEN,R3 ;Get returned length
SUBL3 R3,#SYSID$K_SITEID,R2 ;Compute length to pad
MOVC5 #0,0,#^A" ",R2- ;Blank out rest of site name
,L^SYSID_SITEID(R3)
;
; Here after sitename set.
;
100$: POPR #^M<R2,R3,R4,R5>
MOVAB SYSID_SCBLK1,R9 ;Point to first SCBLK
MOVAB SYSID_SCBLK2,R10 ;Point to second SCBLK
RSB ;Hi-Ho Hi-Ho its off to compile we go.
.PAGE
.SBTTL SYSIDENT: Return system version data
;
; This routine returns two four character (printable) strings in
; R0 & R1. The characters (low to high) represent the version level
; of the four principal components of the system - SPITGO, SPITSYS,
; SPITIOSYS and SPITBOL. R0 contains the major id values,
; R1 contains the minor ids.
;
PROGSECT
;
; Calling Sequence:
;
; JSB SYSIDENT Call to get ident longwords
; (R0) Major id's
; (R1) Minor id's
;
SYSIDENT::
MOVL #<<<IDENT_SPITBOL@8>!IDENT_SPITIOSYS>@8!-
IDENT_SPITSYS>@8!IDENT_SPITGO,R0
MOVL #<<<MINOR_SPITBOL@8>!MINOR_SPITIOSYS>@8!-
MINOR_SPITSYS>@8!MINOR_SPITGO,R1
RSB ;Back we go
.PAGE
.SBTTL SYSINV: Handle INVALID Return
;
; As part of the definition of Minimal, it is allowable to omit
; a label destination on a PPM (JSR Exit Address Parameter) if
; the Minimal subroutine could never take that return in the context
; where it is called. The translation to MACRO-32 inserts the
; label INVALID$ as the destination, which is this module. It is
; natural to assume that this code would never be executed, but
; if it is entered, it calls the error section with WA (The error
; code) set to zero. This indicates an unplesant system error.
;
PROGSECT
;
; Calling Sequence:
;
; JMP INVALID$ Can't happen
;
SYSINV:: ;Dummy label
INVALID$::
CLRL R6 ;Error Code is >>ZERO!<<
JMP ERROR$ ;To the Error Routine
.PAGE
.SBTTL SYSLD: Load External Function
;
; SYSLD is called in response to a LOAD(...) call in the interpreter.
; It dynamically loads a linked image in the next available
; low memory page. A page for the image description is allocated
; first to give the image activator a place to tell us about
; the image. Then the image activator is called to "P0MERGE" the
; image into ours. Note that few checks are made, specifically,
; no checks are made to insure that we are not overmapping
; something important (like the interpreter).
;
; The image must be complete (that is, have a defined xfer
; address), so that SYSEX can get into it. The call interface
; is documented in SYSEX.
;
; Code which is loaded should be PIC, and contain no self-referencing
; absolute addresses (as might be allowed when linking a sharable
; library). If this is not done, then a precise determination
; of the load address is possible, in which event the above can
; be safely disregarded. This does, however, make LOADed functions
; sensitive to the order of LOADing. (See SYSLD_BASE below).
;
; One particular caution is to avoid inadvertently linking the
; VMS RTL into low address space. To prevent this, link the
; image against SPITBOL's symbol table, which already contains
; the RTL.
;
; The second argument (library name) is used as the name of the image
; to merge in. The defaults are as usual with a default type of .EXE.
.PAGE
SAVESECT
;
; SYSLD_BASE is the first available address for LOADing. It is
; maintained as new code is loaded to reflect the new base of
; available space. LOAD_BASE is defined at link time; the
; purpose for it is to leave room for the VMS Run-Time Sharable
; image section which positions itself at %X200 (despite all
; attempts to persuade it otherwise.)
;
SYSLD_BASE:: .LONG LOAD_BASE
;
; DEFDESCR contains the default descriptor area for the image activator.
; The only specified default is the type (.EXE). Note well that a zero
; length default string will cause an inexplicable access violation.
;
SYSLD_DEFDESCR:: .ASCID /.EXE/
.ALIGN LONG,0
;
; FILEDESCR is where the descriptor for the LOAD library (file) name is
; placed.
;
SYSLD_FILEDESCR:: .LONG 0,0
;
; This is a descriptor that creates the header buffer for the activator.
; The activator places the image header and activation data in
; the buffer thus created. The first three longwords point
; respectively to the address in this buffer of the image header,
; the image file descriptor and the address of the FAB for most
; recent open (zero if no FAB available).
;
SYSLD_HDRDESCR:: .LONG 0,0
;
; This is used to pass the available virtual range for the image to
; be loaded to the activator.
;
SYSLD_MAPADR:: .LONG 0,^X1FFFFFFF
;
; The image bounds are returned here by the activator