home *** CD-ROM | disk | FTP | other *** search
/ kermit.columbia.edu / kermit.columbia.edu.tar / kermit.columbia.edu / test / pdp11 / krtrme.mac < prev    next >
Text File  |  1996-10-17  |  58KB  |  1,976 lines
  1.     .title    krtrme    rms i/o for KERMIT-11
  2.     .ident    /V04.64/
  3.     .library    /LB:[1,1]RMSMAC.MLB/
  4.  
  5.  
  6. ; /E64/    05-May-96  John Santos
  7. ;
  8. ;    From K11RMS.MAC.  Name changed to avoid conflict with RT11 module.
  9. ;    Moved RSTS/E versions of GETNXT, GETCR0, TGETCR here from KRTPAK
  10. ;    Move messages to top.
  11. ;    Add buffer for help file.
  12. ;    grab the clock rate (ticks/second) from gtim$ in second
  13. ;    Made packet buffer size = $ALLSIZ
  14. ;    Remove unused code.  Return file size on open/create
  15. ;    Make rewind reset buffer pointers so it can be used for packet
  16. ;    resizing.
  17. ;    This appears to have never handled date xab's correctly.  The
  18. ;    fab's are all initialized to point to date xab's, but before
  19. ;    opening any file, the xab pointers are changed to point to the
  20. ;    protection xab.  The prot XAB should be daisy chained to the end
  21. ;    of the xab list.
  22.  
  23. ;    Brian Nelson  30-Nov-83  09:53:49
  24. ;
  25. ;    Copyright (C) 1983   Change Software, Inc.
  26. ;
  27. ; Edited by:
  28. ; RBD01 - Bob Denny 03-Mar-84    See KRTCMD for edit trails
  29. ;
  30. ;
  31. ;    *******************************************************
  32. ;    *  NOTES REGARDING DECnet (DAP) REMOTE FILE SUPPORT)  *
  33. ;    *******************************************************
  34. ;
  35. ; The code here contains some magic for DECnet (DAP) remote file
  36. ; access.  I have not been able to find documentation on the DAP
  37. ; support that is present in RMS-11 (V2).  My current understanding
  38. ; of this, through experimentation, is as follows:
  39. ;
  40. ;    1. $PARSE fails with RMS status ER$UIN when given a file
  41. ;       specification containing a node name, but seems to
  42. ;       merge the input string and defaults into the expanded
  43. ;       string buffer anyway.  It also sets the file specification
  44. ;       mask.  I have assumed that the ER$UIN error is encountered
  45. ;       in $PARSE after the merging of the default and input
  46. ;       filespec information, and reflects the "fact" that RMS-11
  47. ;       (V2) DOES NOT SUPPORT WILDCARDING ON REMOTE FILE ACCESS.
  48. ;
  49. ;    2. Therefore, lookup() has been modified to return the
  50. ;       expanded string if its second calling parameter (index)
  51. ;       is zero (1st call) and there is either a node name or a
  52. ;       quoted literal in the spec, no wildcards and the error
  53. ;       is ER$UIN.
  54. ;
  55. ;    3. fparse() has been modified to accept if the error is ER$UIN,
  56. ;       and if there are no wildcards and there is a node name present.
  57. ;       The FB$FID bit is cleared, however, so that the original
  58. ;       file spec string and the defaults will be used by $OPEN.
  59. ;
  60. ;    4. The "SY:" defaulting is not necessary, and in fact causes
  61. ;       remote accesses to fail on VMS systems, where "SY:" has
  62. ;       no conventional meaning.
  63. ;
  64. ;    5. The other routines which use $parse have been similarly
  65. ;       modified to use the expanded string once only.
  66. ;
  67. ;    6. Finally, the NAMCVT routine in KRTM41 was changed to handle
  68. ;       quoted sections in strings and node names.  This was the
  69. ;       hardest part of the DAP adaptation.
  70. ;
  71. ; I have to believe that $parse and friends act this way because remote
  72. ; wildcarding got "left out" at the last minute because of scheduling
  73. ; problems in the RMS group.  The code I have added here should permit
  74. ; remote wildcarding when it is turned on by the RMS folks.
  75. ;
  76. ; Bob Denny    03-Mar-84
  77. ;
  78. ;
  79. ;
  80. ; Please note that RSTS rms11 requires a real default device. I thus
  81. ; have to put my origional default for SY: back in for RSTS only. We
  82. ; will determine this at tkb time by defining a global called FU$DEF
  83. ; to be <> 0 in KRTE80.MAC  and = 0 in KRTM41.MAC.
  84. ;
  85. ;
  86. ; Brian Nelson  16-Mar-84  17:34:19
  87. ;
  88. ; BDN 17-Feb-87  08:57:48  Re-do the allocation of record buffers so
  89. ;               can GBLDEF the size during TKB. This will
  90. ;               allow the I/D space Kermit to handle much
  91. ;               larger ascii records.
  92.  
  93.  
  94. ;    define macros and things we want for KERMIT-11
  95.  
  96.     .if ndf, krtinc
  97.     .ift
  98.  
  99.  
  100.     .if ndf, KRTINC
  101.     .ift
  102.     .include    /IN:KRTMAC.MAC/
  103.     .endc
  104.  
  105.     .endc
  106.     .iif ndf, krtinc, .error ; INCLUDE for IN:KRTMAC.MAC failed
  107.  
  108.  
  109. ;    This is KRTRMS.MAC,  the RMS11 version 2 i/o interface for
  110. ;    Kermit on RSTS version 8, RSX11M+ v2.1 and RSX11M v4.1. It
  111. ;    is,  without a doubt,  the worst part of Kermit due RMS11,
  112. ;    but it's strong points are  future uses and the RSX / RSTS
  113. ;    transportability.  An example of "future uses" is DECnet
  114. ;    remote file access (DAP) support now present.
  115. ;
  116. ;
  117. ;    close ( %val channel_number )
  118. ;    create( %loc filename, %val channel_number ,%val type )
  119. ;    getc  ( %val channel_number )
  120. ;    getrec( %loc buffer  , %val channel_number ,%val buffer_size )
  121. ;        { returns RSZ in R1}
  122. ;    lookup( %loc in_filespec, %loc out_filename )
  123. ;    open  ( %loc filename, %val channel_number ,%val type )
  124. ;    putc  ( %val char    , %val channel_number )
  125. ;    putrec( %loc buffer  , %val record_size    ,%val channel_number )
  126.  
  127.  
  128.     cr    =    15
  129.     lf    =    12
  130.     ff    =    14
  131.     soh    =    1
  132. ;
  133. ; This isn't defined globally. (??)
  134. ;
  135.     nb$nod    =    400    ; Node in file or default string (FNB in NAM)
  136.  
  137.     .enabl    gbl
  138.  
  139.     .sbttl    messages
  140.     .psect  $pdata
  141.     .even
  142.                     ; Make this <> 0 if you can't do CALFIP
  143. fu$dir::.word    0            ; style wildcarding on your non-standard
  144.                     ; RSTS system.  Could cause side effects
  145.                     ; with remote decnet nodes.
  146. tlogda:    .word    0,0            ; /46/ Returned data
  147. ln$mk1::.word    0
  148. rme.01:    .asciz    "Failure to allocate record buffers"<cr><lf>
  149. rme.02:    .asciz    "Failure to allocate command recall buffers"<cr><lf>
  150. rme.03:    .asciz    "Breakpoint trap, "    ; A message
  151. rme.04:    .asciz    " PC: "            ; A header
  152. rme.05:    .asciz    "  PSW: "        ; ...
  153. rme.06:    .byte    CR,LF
  154.     .ascii    /Probable cause: Either RMSRES or an RMS satellite/<CR><LF>
  155.     .asciz    /resident library is not installed on this system./<CR><LF>
  156. rme.07:    .asciz    "Exiting due to control C interupt"<cr><lf>  ; /43/
  157.     .even
  158.  
  159.     .psect    $code    ,ro,i,lcl,rel,con
  160.     .psect    rmssup    ,rw,d,lcl,rel,con
  161.  
  162.  
  163.     .mcall    fabof$
  164.     .mcall    rabof$
  165.     .mcall    xabof$
  166.     .mcall    ifaof$
  167.  
  168.     fabof$    RMS$L
  169.     rabof$    RMS$L
  170.     xabof$    RMS$L
  171.     ifaof$    RMS$L
  172.  
  173.  
  174.     .mcall    fab$b    ,fab$e    ,rab$b    ,rab$e
  175.     .mcall    xab$b    ,xab$e
  176.     .mcall    nam$b    ,nam$e
  177.     .mcall    $initif    ,org$
  178.     .mcall    pool$b    ,pool$e    ,p$bdb    ,p$fab
  179.     .mcall    p$rabx    ,p$idx    ,p$buf
  180.  
  181.     .mcall    $compar    ,$fetch    ,$store    ,$rewin
  182.     .mcall    $close    ,$creat    ,$erase    ,$open
  183.     .mcall    $connec    ,$delet    ,$discon,$find
  184.     .mcall    $get    ,$put    ,$updat    ,$flush
  185.     .mcall    $read    ,$write    ,$off    ,$set
  186.     .mcall    $testbits
  187.  
  188.  
  189.     org$    SEQ,<CRE,DEL,GET,PUT>
  190.  
  191.     .psect    rmssup    ,rw,d,lcl,rel,con ; ORG$ macro needs .save/.restore
  192.  
  193.  
  194.     .if ne    ,0            ; Decide whether or not to use
  195.     .ift                ; dynamic space allocation by
  196.                     ; task extension or to use
  197. rmsbuf:    pool$b                ; static pools
  198.     p$rab    6            ; plenty of record streams
  199.     p$bdb    6            ; same goes for block buffers
  200.     p$fab    4            ; up to 3 fabs (needed for search)
  201.     p$buf    3072.            ; for 2 files and directory i/o
  202.     pool$e                ; end of static pool
  203.  
  204.     .iff                ; use task extension for space
  205.                     ; routine modifed from GSA example
  206.     .mcall    gsa$            ; from RMS v2.0 distribution.
  207.     gsa$    gsa            ; set our GSA address
  208.     .globl    gsa            ; it may be global
  209.  
  210.     .endc                ; to decide on pool allocation
  211.  
  212.     .psect    rmssup    ,rw,d,lcl,rel,con ; GSA$ macro needs .save/.restore
  213.  
  214.  
  215.  
  216.     .sbttl    rms file access blocks
  217.  
  218.     facc    =    fb$get ! fb$put
  219.  
  220. fab1:    fab$b
  221.     f$alq    0            ; initial allocation of 10 blocks
  222.     f$fac    facc            ; allowed i/o operations
  223.     f$fna    nam1            ; name of the file
  224.     f$fns    0            ; length of the filename
  225.     f$fop    fb$sup            ; supercede old versions
  226.     f$lch    lun1            ; channel number to use
  227.     f$org    fb$seq            ; seq
  228.     f$rat    fb$cr            ; implied carriage control
  229.     f$rfm    fb$var            ; variable length records
  230.     f$xab    datxb1            ; Date info
  231.     fab$e
  232. fab1en:
  233.  
  234. fab2:    fab$b
  235.     f$alq    0            ; initial allocation of 10 blocks
  236.     f$fac    facc            ; allowed i/o operations
  237.     f$fna    nam2            ; name of the file
  238.     f$fns    0            ; length of the filename
  239.     f$fop    fb$sup            ; supercede old versions
  240.     f$lch    lun2            ; channel number to use
  241.     f$org    fb$seq            ; seq
  242.     f$rat    fb$cr            ; implied carriage control
  243.     f$rfm    fb$var            ; variable length records
  244.     f$xab    datxb2            ; Date info
  245.     fab$e
  246. fab2en:
  247.  
  248.  
  249. fab3:    fab$b
  250.     f$alq    0            ; initial allocation of 10 blocks
  251.     f$fac    facc            ; allowed i/o operations
  252.     f$fna    nam3            ; name of the file
  253.     f$fns    0            ; length of the filename
  254.     f$fop    fb$sup            ; supercede old versions
  255.     f$lch    lun3            ; channel number to use
  256.     f$org    fb$seq            ; seq
  257.     f$rat    fb$cr            ; implied carriage control
  258.     f$rfm    fb$var            ; variable length records
  259.     f$xab    datxb3            ; Date info
  260.     fab$e
  261. fab3en:
  262.  
  263.  
  264. fab4:    fab$b
  265.     f$alq    0            ; initial allocation of 10 blocks
  266.     f$fac    facc            ; allowed i/o operations
  267.     f$fna    nam4            ; name of the file
  268.     f$fns    0            ; length of the filename
  269.     f$fop    fb$sup            ; supercede old versions
  270.     f$lch    lun4            ; channel number to use
  271.     f$org    fb$seq            ; seq
  272.     f$rat    fb$cr            ; implied carriage control
  273.     f$rfm    fb$var            ; variable length records
  274.     f$xab    datxb4            ; Date info
  275.     fab$e
  276.  
  277.     .globl    MAXSIZ
  278.  
  279.  
  280.     .psect    rmssup    ,rw,d,lcl,rel,con
  281.  
  282. sydisk::.ascii    /SY:/
  283. sylen    ==    . - sydisk
  284.     .even
  285. sydska    ==    sydisk
  286. sydskl    ==    sylen
  287.  
  288. ;                                ;RBD01--
  289. ;    pointers to buffer and fabs
  290. ;
  291. ;    While none of this is really needed since all this info is
  292. ;    available in the FAB and RAB, I find it cleaner to do it
  293. ;    this way and thus avoid having to look at the RMS control
  294. ;    structures.
  295.  
  296. fablst::.word    0    ,fab1    ,fab2    ,fab3    ,fab4
  297. namlst::.word    0    ,nam1    ,nam2    ,nam3    ,nam4
  298. namlen::.word    0    ,0    ,0    ,0    ,0
  299. rablst::.word    0    ,rab1    ,rab2    ,rab3    ,rab4
  300. buflst::.word    ttbuf    ,buf1    ,buf2    ,buf3    ,buf4
  301. bufdef:    .word    ttbuf    ,buf1    ,buf2    ,buf3    ,buf4
  302. bufsiz:    .word    TTBSIZ    ,MAXSIZ    ,MAXSIZ    ,MAXSIZ    ,MAXSIZ
  303. bigbuf:    .word    bufx    ,bufx    ,bufx    ,bufx    ,bufx
  304. date.a::.word    0    ,0    ,0    ,0    ,0    ; /BBS/ date attribute
  305. filtyp::.word    TERMINAL,TEXT    ,TEXT    ,TEXT    ,TEXT
  306. bufp::    .word    0    ,0    ,0    ,0    ,0
  307. bufs::    .word    0    ,0    ,0    ,0    ,0
  308. mode::    .word    1    ,0    ,0    ,0    ,0
  309. prot.a::.word    0    ,0    ,0    ,0    ,0    ; /BBS/ prot attribute
  310. sizof:: .word    0    ,0    ,0    ,0    ,0    ; size of file, blocks
  311. sizofh::.word    0    ,0    ,0    ,0    ,0    ; /E64/ high-word size
  312. time.a::.word    0    ,0    ,0    ,0    ,0    ; /BBS/ time attribute
  313. blknum::.word    0    ,0    ,0    ,0    ,0
  314. itsopen:.word    0    ,0    ,0    ,0    ,0
  315.  
  316.     FILSIZ    ==    40.
  317.     BINLSIZ    ==    40*4
  318.  
  319. prewrk::.blkb    200.            ; /E64/ prewind work buffer
  320. defdir::.blkb    FILSIZ+2        ; default directory for send and rec
  321. dkname::.blkb    FILSIZ+2        ; default directory for send and rec
  322. srcnam::.blkb    FILSIZ+2        ; original send filespec
  323. filnam::.blkb    FILSIZ+2        ; output from directory lookup routine
  324. asname::.blkb    FILSIZ+2        ; for SEND file [as] file
  325. indnam::.blkb    40.            ; /62/ current take or init file name
  326. ininam::.blkb    40.            ; /62/ init file name for show file
  327. logfil::.blkb    40.
  328. $cmdbu::.blkb    120
  329. $argbu::.blkb    120
  330. bintyp::.word    10$
  331. 10$:    .rept    BINLSIZE
  332.     .byte    0
  333.     .endr
  334. status::.word    0            ; this is Kermit-11's error status reg
  335. totp.r::.word    10$
  336. 10$:    .rept    34
  337.     .word    0,0
  338.     .endr
  339. totp.s::.word    10$
  340. 10$:    .rept    34
  341.     .word    0,0
  342.     .endr
  343.  
  344. ;    this sets the default for creating text files
  345.  
  346. df$rat::.word    fb$cr
  347. df$rfm::.word    fb$var
  348. en$siz::.word    0            ; for RT11 compatibilty
  349.  
  350. namln1    =    namlen+2
  351. namln2    =    namlen+4
  352. namln3    =    namlen+6
  353. namln4    =    namlen+10
  354.  
  355. nam1:    .rept    100
  356.     .byte    0
  357.     .endr
  358.  
  359. nam2:    .rept    100
  360.     .byte    0
  361.     .endr
  362.  
  363. nam3:    .rept    100
  364.     .byte    0
  365.     .endr
  366.  
  367. nam4:    .rept    100
  368.     .byte    0
  369.     .endr
  370.     .even
  371.  
  372.  
  373. packet::.blkb    $ALLSIZ            ; /E64/ From RT-11 version
  374. ;packet::.blkb    MAXLNG+100        ; /51/ Moved.
  375.     .even
  376.  
  377. top:    .LIMIT
  378.  
  379.     TTBSIZ    ==    40
  380. ttbuf::    .blkb    TTBSIZ+2
  381.  
  382. buf1:    .iif df, MAXSIZ, .blkb MAXSIZ+2    ; /56/ Dynamic or static setup?
  383. buf2:    .iif df, MAXSIZ, .blkb MAXSIZ+2    ; /56/ ...
  384. buf3:    .iif df, MAXSIZ, .blkb MAXSIZ+2    ; /56/ ....
  385. buf4:    .iif df, MAXSIZ, .blkb MAXSIZ+2    ; /56/ .....
  386.  
  387. bufx:    .blkb    1002            ; one large buffer to share
  388.  
  389.  
  390. lun1    =    1
  391. lun2    =    2
  392. lun3    =    3
  393. lun4    =    4
  394. maxlun    =    lun4
  395.  
  396.  
  397.  
  398.     .sbttl    rms record access blocks
  399.  
  400. rab1:    rab$b                ; define record access block
  401.     r$fab    fab1            ; associate a fab with this rab
  402.     r$rac    rb$seq            ; access by keys
  403.     r$rbf    buf1            ; where to return the data
  404.     r$ubf    buf1            ; where to return the data
  405.     rab$e                ; end of record access block
  406.  
  407. rab2:    rab$b                ; define record access block
  408.     r$fab    fab2            ; associate a fab with this rab
  409.     r$rac    rb$seq            ; access by keys
  410.     r$rbf    buf2            ; where to return the data
  411.     r$ubf    buf2            ; where to return the data
  412.     rab$e                ; end of record access block
  413.  
  414. rab3:    rab$b                ; define record access block
  415.     r$fab    fab3            ; associate a fab with this rab
  416.     r$rac    rb$seq            ; access by keys
  417.     r$rbf    buf3            ; where to return the data
  418.     r$ubf    buf3            ; where to return the data
  419.     rab$e                ; end of record access block
  420.  
  421. rab4:    rab$b                ; define record access block
  422.     r$fab    fab4            ; associate a fab with this rab
  423.     r$rac    rb$seq            ; access by keys
  424.     r$rbf    buf4            ; where to return the data
  425.     r$ubf    buf4            ; where to return the data
  426.     rab$e                ; end of record access block
  427.  
  428.  
  429.  
  430. proxab:    xab$b    XB$PRO            ; file protection xab
  431.     x$nxt    0            ; no more links
  432.     x$pro    60.            ; normal protection of <60>
  433.     xab$e                ; end of file protection xab
  434.  
  435. datxb1:    xab$b    XB$DAT
  436.     x$nxt    0
  437.     xab$e
  438. datxb2:    xab$b    XB$DAT
  439.     x$nxt    0
  440.     xab$e
  441. datxb3:    xab$b    XB$DAT
  442.     x$nxt    0
  443.     xab$e
  444. datxb4:    xab$b    XB$DAT
  445.     x$nxt    0
  446.     xab$e
  447.  
  448.     .psect    $code
  449.  
  450.  
  451.     .sbttl    Set up SST table to catch RMSRES missing
  452.  
  453.     .mcall    SVTK$S,EXST$S,EXTK$S    ; This code added /53/
  454.     .mcall    GTSK$S
  455.  
  456. ;    Dynamic record buffer allocation and dynamic recall buffer
  457. ;    allocation added /56/
  458.  
  459.  
  460.     .save                ; Save current PSECT
  461.     .psect    RMSSUP    ,D        ; Switch to a data psect
  462.     .even                ; Insure this
  463. tbl:    .word    0,0,norms        ; Missing RMS gives a BPT trap
  464.     .even
  465.     .restore            ; Pop old psect
  466.     .enabl    lsb
  467.  
  468.  
  469. Rmsini::mov    #MAXSIZ    ,r3        ; Allocate record buffers
  470.     mov    r3    ,O$MRS+fab1    ; Since we are allocating
  471.     mov    r3    ,O$MRS+fab2    ; the RMS record buffers at
  472.     mov    r3    ,O$MRS+fab3    ; run time we will can't
  473.     mov    r3    ,O$MRS+fab4    ; fill these fields in with
  474.     mov    r3    ,O$USZ+rab1    ; ...MAC
  475.     mov    r3    ,O$USZ+rab2    ; .... and so on
  476.     mov    r3    ,O$USZ+rab3    ; ....
  477.     mov    r3    ,O$USZ+rab4    ; ....
  478.                     ;
  479.     .If df    ,MAXSIZ            ; Dynamic or static today?
  480.     .Ift                ; Static
  481.                     ;
  482.     mov    #buf1    ,r2        ; So get the preallocated buffers
  483.     mov    top+2    ,r4        ;
  484.     .Iff                ; Dynamic allocation
  485.                     ;
  486.     ash    #-<6-2>    ,r3        ; We need 4 buffers, in 64 byte
  487.     add    #2    ,r3        ; chuncks. Add a safety margin
  488.     EXTK$S    r3            ; Ask for the memory
  489.     bcs    110$            ; Oops, we will have to die.
  490.     mov    top+2    ,r2        ; The higest virtual address+2
  491.     add    #2    ,r2        ; filled in by TKB via .LIMIT
  492.     bic    #1    ,r2        ; Insure even
  493.                     ;
  494.     .Endc                ; .If DF, Maxsiz
  495.                     ;
  496.     mov    #4    ,r0        ; Number of fields to update
  497.     clr    r3            ; Offset into BUFDEF and BUFLST
  498. 10$:    mov    r2    ,bufdef+2(r3)    ; Insert a record buffer address
  499.     mov    r2    ,buflst+2(r3)    ; Ditto for here also
  500.     add    #2    ,r3        ; Next please
  501.     add    #MAXSIZ+2,r2        ; Point to the next buffer
  502.     sob    r0    ,10$        ; And go do another
  503.     .If ndf    ,MAXSIZ            ; Setup pointer for command line
  504.     mov    r2    ,r4        ; recall buffers if dynamic RMS
  505.     .Endc                ; buffer allocation was used
  506.                     ; Now for command line recall
  507.     mov    #LN$CNT    ,r1        ; buffers. The count is defined
  508.                     ; in KRTMAC.MAC
  509.     mov    #<LN$MAX+2>*LN$CNT,r3    ; Total byte count for recall buffers
  510.     ash    #-6    ,r3        ; In 64 byte chunks
  511.     add    #<LN$MAX+2>/100,r3    ; Fix for truncation
  512.     EXTK$S    r3            ; Ask for it
  513.     bcs    130$            ; No room, die (should never happen)
  514.     mov    #lastli    ,r2        ; The pointer array
  515. 40$:    mov    r4    ,(r2)+        ; Insert the buffer address
  516.     clrb    @r4            ; Insure the buffer is zapped
  517.     add    #LN$MAX+2,r4        ; Get to the next one
  518.     sob    r1    ,40$        ; And loop
  519.                     ;
  520.                     ; Finally, our original purpose.
  521.     SVTK$S    #tbl,#3            ; Only want TBIT traps
  522.     return                ; Exit
  523.  
  524.  
  525. 110$:    wrtall    #rme.01            ; /E64/
  526.     br    200$
  527. 130$:    wrtall    #rme.02            ; /E64/
  528.  
  529. 200$:    EXST$S    #EX$SEV            ; Die...
  530.  
  531.     .dsabl    lsb
  532.  
  533.  
  534.  
  535. Norms:    wrtall    #rme.03            ; /E64/
  536.     mov    (sp)    ,r1        ; Dump PC and PS
  537.     wrtall    #rme.04            ; /E64/
  538.     OCTOUT    R1            ; ...
  539.     mov    2(sp)    ,r1        ; PS
  540.     wrtall    #rme.05            ; /E64/
  541.     OCTOUT    r1            ; ...
  542.     cmp    (sp)    ,#140000    ; Perhaps RMSRES missing?
  543.     blo    100$            ; No
  544.     wrtall    #rme.06            ; Dump the cause
  545. 100$:    EXST$S    #EX$SEV            ; Die
  546.  
  547.     .globl    LN$CNT
  548.  
  549.  
  550.  
  551.  
  552.     .sbttl    create sequential file
  553.     .psect    $code
  554.     .even
  555.  
  556. ;    F C R E A T E   and   F O P E N
  557. ;
  558. ;    fcreate( %loc filename; %val channel_number, %val type ,%val mb_count)
  559. ;    fopen  ( %loc filename; %val channel_number, %val type ,%val mb_count)
  560. ;
  561. ;    input:    @r5    filename address
  562. ;        2(r5)    channel number
  563. ;        4(r5)    val 'binary' or 'text' or 0
  564. ;        6(r5)    RMS multiblock count for the stream
  565. ;
  566. ;    output:    r0    rms error code
  567. ;
  568. ;     Create a variable length sequential implied carriage control
  569. ;    disk file.  If 'type' is 'binary'  then use read/write access
  570. ;    to write  a fixed  512 byte image file. If  channel number is
  571. ;    zero (0),  then initialize  buffer single character  terminal
  572. ;    output.  It is always assumed that channel '0' implies writes
  573. ;    to the attached console terminal.
  574.  
  575.     .enabl    lsb
  576. open::    calls    fopen    ,<@r5,2(r5),4(r5),#0>
  577.     return
  578.  
  579. create::calls    fcreate    ,<@r5,2(r5),4(r5),#0>
  580.     return
  581.  
  582. append::calls    fapnd    ,<@r5,2(r5),4(r5),#0>
  583.     return
  584.  
  585.  
  586. fopen::    save    <r1,r2,r3>        ; save registers
  587.     call    drpprv            ; insure no privs are up now    +MJG
  588.     clr    -(sp)            ; flag for open not create
  589.     br    5$            ; and try to do it
  590.  
  591.  
  592. fapnd::    save    <r1,r2,r3>        ; save registers        +SSH
  593.     call    drpprv            ; insure no privs        +SSH
  594.     mov    #1,-(sp)        ; flag for open / append    +SSH
  595.     br    5$            ; and try to do it        +SSH
  596.  
  597.  
  598. fcreat::save    <r1,r2,r3>        ; save registers
  599.     call    drpprv            ; insure no privs are up now    +MJG
  600. tcreat:    mov    #-1    ,-(sp)        ; flag for create
  601.  
  602. 5$:    $initif                ; initialize rms i/o system if needed
  603.     mov    2(r5)    ,r0        ; get channel number please
  604.     bne    10$            ; not channel zero, do it normally
  605.  
  606.     mov    sp    ,itsopen+0    ; flag it as having been initted
  607.     mov    sp    ,mode+0        ; psuedo writing to the terminal
  608.     clr    bufp+0            ; initialize the terminal's buffer
  609.     br    120$            ; pointer and exit
  610.  
  611. 10$:    asl    r0            ; times 2
  612.     mov    r0    ,r2        ; save it please
  613.     mov    namlst(r2),r1        ; get address of name block
  614.     calls    fparse    ,<@r5,r1>    ; parse and fill in defaults
  615.     tst    r0            ; did the parse succeed ?
  616.     bne    120$            ; no, exit with RMS error in r0
  617.     strlen    r1            ; get the expanded filename length
  618.     mov    r0    ,namlen(r2)    ; and save the length
  619.     mov    r2    ,r0        ; get r0 back again please
  620.     mov    fablst(r0),r1        ; get the file access block
  621.     mov    @sp    ,r2        ; pass create/open/append flag       /SSH
  622.     call    settyp            ; setup the FAB now
  623.     mov    r0    ,r2        ; save the channel number*2
  624.     tst    @sp            ; create or open or append       /SSH
  625.     bmi    30$            ; if negative then create       /SSH
  626.  
  627.     $open    r1            ; try to open existing file       /SSH
  628.     tst    @sp            ; opening for append ?           +SSH
  629.     beq    28$            ; no, go setup for read           +SSH
  630.     mov    sp    ,mode(r2)    ; indicate open for writing       +SSH
  631.     clr    bufp(r2)        ; clear single char i/o pointer    +SSH
  632.     br    40$            ; continue with status check       +SSH
  633. 28$:                    ;                   +SSH
  634.     mov    #-1    ,bufp(r2)    ; init for buffer needing a read
  635.     clr    mode(r2)        ; no writing please
  636.     br    40$            ; check RMS status out now
  637.  
  638. 30$:    $creat    r1            ; try hard to create the file
  639.     mov    sp    ,mode(r2)    ; open for writing
  640.     clr    bufp(r2)        ; clear single character i/o pointer
  641.  
  642. 40$:    $fetch    r0,sts,r1        ; get status back out please
  643.     tst    r0            ; if status > 0 then status = 0
  644.     bmi    130$            ; error if less than zero       /SSH
  645.     $fetch    sizof(r2),alq0,r1    ; /E64/ get size (low word)
  646.     $fetch    sizofh(r2),alq1,r1    ; /E64/ get size (high word)
  647.     mov    sp    ,itsopen(r2)    ; /E64/ simple
  648. ; /E64/
  649. ; /E64/    This is a crock to see if we can dredge up the file's creation
  650. ; /E64/ date and time without doing a directory lookup.  RMS must have
  651. ; /E64/ done one, maybe the info is still there?
  652. ; /E64/
  653. firqb=402
  654. fqflag=24
  655. fqpflg=26
  656.     mov    firqb+fqflag,date.a(r2)    ; /E64/ save creation date
  657.     mov    firqb+fqpflg,time.a(r2)    ; /E64/ save creation time
  658.     mov    2(r5)    ,r0        ; connect access up now
  659.     mov    6(r5)    ,r1        ; and the multiblock count also
  660.     mov    (sp)    ,r2        ; and the create/open/append opt   +SSH
  661.     call    rmscon            ; connect record stream up
  662.     tst    r0            ; if error > 0 then error = 0
  663.     bmi    120$            ; yep
  664.     clr    r0            ; error = 0
  665.  
  666. 120$:    tst    (sp)+            ; pop open/create flag
  667. 125$:    unsave    <r3,r2,r1>        ; pop registers we saved
  668.     return                ; and exit
  669.  
  670. 130$:    tst    (sp)+            ; if error on open for append       +SSH
  671.     ble    125$            ; no, return with error           +SSH
  672.     br    tcreat            ; yes, try creating the file       +SSH
  673.  
  674.     .globl    drpprv            ;                +MJG
  675.  
  676.     .dsabl    lsb
  677.  
  678.     .sbttl    setup things for open/create in the FAB
  679.  
  680.  
  681. ;    S E T T Y P
  682. ;
  683. ;    input:    r0    channel number times 2
  684. ;        r2    <> 0 implies create
  685. ;        r5    --> open/create parameter list
  686. ;
  687.     fbrw    =    fb$rea ! fb$wri
  688.  
  689. settyp::save    <r3>            ; /E64/
  690.     mov    fablst(r0),r1
  691.     clr    blknum(r0)        ; in case of read/write mode
  692.     mov    #MAXSIZ    ,bufsiz(r0)    ; default for the buffer size
  693.     mov    #text    ,filtyp(r0)    ; assume ascii text files for now
  694.     mov    bufdef(r0),buflst(r0)    ; set a default record buffer also
  695.     clr    bufs(r0)        ; clear single character i/o recsiz
  696.     $fetch    r3,XAB,r1        ; /E64/ point to name block
  697.     $store    #proxab,NXT,r3        ; /E64/ Get the protection out.
  698.     $store    namlen(r0),FNS,r1
  699.     $store    #fb$seq,ORG,r1        ; insure sequential by default
  700.     $store    df$rat ,RAT,r1        ; implied carriage control
  701.     $store    df$rfm ,RFM,r1        ; and also variable length records
  702.     $store    #fb$get,FAC,r1        ; insure readonly please
  703.     tst    fu$def            ; do we require a default device
  704.     beq    1$            ; no
  705.     $store    #sydisk,DNA,r1        ; yes, stuff the correct def dev in
  706.     $store    #sylen ,DNS,r1        ; and the length of it also please
  707. 1$:    tst    r2            ; if creating or appending the file /SSH
  708.     beq    10$            ; no                    /SSH
  709.     $store    #<fb$put>,FAC,r1    ; yes, get put access            /SSH
  710.     mov    at$pro    ,proxab+O$PRO    ; /E64/ Protection explicity set?
  711.     bne    10$            ; /59/ Yes
  712.     $store    #0,NXT,r3        ; /E64/ No, remove the protection XAB
  713. 10$:    cmp    4(r5)    ,#binary    ; is this a binary file ?
  714.     bne    100$            ; no, just exit
  715.  
  716.     mov    #1000    ,bufsiz(r0)    ; yes, fix it up for that
  717.     mov    bigbuf(r0),buflst(r0)    ; setup a large i/o buffer please
  718.     mov    #binary    ,filtyp(r0)    ; please
  719.     $store    #0    ,RAT,r1        ; no cr/lf implied please
  720.     $store    #fb$fix    ,RFM,r1        ; fixed length also
  721.     $store    #fb$rea    ,FAC,r1        ; assume read only please
  722.     tst    r2            ; readonly ?
  723.     beq    30$            ; yes
  724.     $store    #fbrw    ,FAC,r1        ; read/write mode needed ?
  725. 30$:    save    <r2>            ; /E64/ zero out the big buffer
  726.     mov    buflst(r0),r2        ; get the buffer address
  727.     mov    #1000    ,r3        ; 1000 (8) bytes please
  728. 40$:    clrb    (r2)+            ; simple
  729.     sob    r3    ,40$        ; next please
  730.     unsave    <r2>            ; /E64/ pop registers we just used
  731.  
  732. 100$:    $store    bufsiz(r0),MRS,r1    ; stuff max recordsize in please
  733.     unsave    <r3>            ; /E64/
  734.     return
  735.  
  736.     .globl    fu$def
  737.     .globl    AT$PRO            ; /E64/ Protection mask
  738.  
  739.     .sbttl    Preset a file I/O channel to desired block and offset ; /BBS/
  740.  
  741. ;    P R E W I N D
  742. ;
  743. ;    input:      (r5)    = lun
  744. ;         2(r5)    = block number (count from zero)
  745. ;         4(r5)    = byte offset in above block
  746.  
  747. prewind::save    <r1,r2,r3>
  748.     mov    @r5    ,r2        ; channel number please
  749.     asl    r2            ; word indexing
  750.     mov    2(r5)    ,blknum(r2)    ; req'd block of the disk file
  751.     mov    rablst(r2),r1        ; get the record access buffer
  752.     $store    #RB$RFA,RAC,r1        ; RFA access
  753.     $store    #prewrk,UBF,r1        ; work buffer
  754.     $store    bufsiz(r2),USZ,r1    ; buffer size
  755.     mov    2(r5),o$rfa+0(r1)    ; use RFA mode please
  756.     inc    o$rfa+0(r1)        ; count from 1
  757.     clr    o$rfa+2(r1)        ; second word is to have zero
  758.     mov    4(r5),o$rfa+4(r1)    ; offset
  759.     $get    r1            ; get next virtual block please
  760.     $store    #RB$SEQ,RAC,r1        ; SEQ access
  761.     $fetch    r0,STS,r1        ; get the return STATUS field
  762.     tst    r0            ; did it work ?
  763.     blt    100$            ; no
  764.     inc    blknum(r2)        ; next time read the next block
  765.     mov    4(r5)    ,r3        ; get a copy of required offset
  766.     mov    r3    ,bufp(r2)    ; now preset offset in block
  767.     $fetch    r0,RSZ,r1        ; get the record size now
  768.     sub    r3    ,r0        ; don't count unused bytes..
  769.     mov    r0    ,bufs(r2)    ; save the record size
  770.     clc
  771.     br    110$
  772. 100$:    sec
  773. 110$:    unsave    <r3,r2,r1>
  774.     return
  775.  
  776.  
  777.     .sbttl    close a file
  778.  
  779.  
  780. close::    save    <r1,r2,r3>        ; save registers we may have
  781.     mov    @r5    ,r0        ; get the lun
  782.     asl    r0            ; times 2
  783.     tst    itsopen(r0)        ; check for lun being open
  784.     beq    90$            ; no, skip all this then
  785.     clr    itsopen(r0)        ; not anymore please
  786.     call    flush            ; dump out any remaining buffer
  787.     mov    @r5    ,r0        ; then disconnect the access stream
  788.     beq    100$            ; terminal
  789.  
  790.     asl    r0            ; channel number times 2
  791.     tst    mode(r0)        ; writing to it today?
  792.     beq    10$            ; no
  793.     calls    atrfin    ,<@r5>        ; yes, perhaps do attribute things
  794. 10$:    mov    @r5    ,r0        ; then disconnect the access stream
  795.     call    rmsdis            ; by doing a $disconnect
  796.     mov    @r5    ,r1        ; get the FAB for the file open on
  797.     asl    r1            ; the passed channel
  798.     mov    fablst(r1),r1        ;
  799.     $close    r1            ; try hard to close the file
  800.     $fetch    r0,sts,r1        ; get status back out please
  801.     tst    r0            ; if status > 0 then status = 0
  802.     blt    100$            ; error if less than zero
  803. 90$:    clr    r0            ; make > 0 status eq 0
  804. 100$:    unsave    <r3,r2,r1>
  805.     return
  806.  
  807.  
  808. rewind::mov    @r5    ,r0
  809.     beq    100$
  810.     asl    r0
  811.     mov    #-1    ,bufp(r0)    ; flag a buffer reload is needed
  812.     clr    bufs(r0)        ; nothing is in the buffer (size=0)
  813.     clr    blknum(r0)        ; first block of the disk file
  814.     mov    rablst(r0),r0
  815.     $rewind    r0
  816. 100$:    clr    r0
  817.     return
  818.  
  819.  
  820.  
  821.     .sbttl    try to determine if a file needs binary xfer mode
  822.  
  823. ;    B I N F I L
  824. ;
  825. ;    input:    @r5    address of the filename
  826. ;        2(r5)    lun
  827. ;    output:    r0    < 0 then RMS error
  828. ;        r0    > 0 then the file is most likely binary
  829.  
  830.  
  831. binfil::save    <r1,r2,r3,r4>        ; save registers we may use
  832.     clr    r4            ; nothing is open as of yet
  833.     calls    chkext    ,<@r5>        ; check file based on filetype
  834.     tst    r0            ; assume a binary file ?
  835.     bne    100$            ; yep
  836.     mov    2(r5)    ,r2        ; get the lun
  837.     asl    r2            ; times 2
  838.     mov    fablst(r2),r2        ; get the fab address now
  839.     $fetch    r3,XAB,r2        ; save the xab link address
  840.     call    getuic            ; for RSTS, skip the protection XAB
  841.     swab    r0            ; if the user is not privledged
  842.     cmpb    r0    ,#1        ; since RMS uses the UU.LOK directive
  843.     bne    5$            ; which may be patched to fail.
  844.     $store    #proxab,NXT,r3        ; /E64/ and stuff our own into it
  845. 5$:    calls    open    ,<@r5,2(r5),#binary>
  846.     tst    r0            ; did the open work
  847.     bmi    90$            ; no
  848.     mov    sp    ,r4        ; flag that it's open
  849.  
  850.     mov    #proxab    ,r1        ; get the xab for the protection code
  851.     $testbit #100,PRO,r1        ; if set, then it's executable
  852.     bne    40$            ; assume it's binary
  853.  
  854.     $testbit #<fb$rel!fb$idx>,ORG,r2; indexed or relative file ?
  855.     bne    40$            ; yes, it must be sent as a binary file
  856.     $compare #fb$stm,RFM,r2        ; stream ascii file ?
  857.     beq    30$            ; yes, assume not binary then
  858.     $testbit #FB$FTN,RAT,r2        ; /47/ Please not for Fortran files
  859.     bne    30$            ; /47/ Ok
  860.     $testbit #fb$cr,RAT,r2        ; implied carriage control ?
  861.     bne    30$            ; yes, assume not 8 bit then
  862.     br    40$            ; anything else is binary please
  863.  
  864.  
  865. 30$:    clr    -(sp)            ; flag as most likely being ascii
  866.     br    50$            ; bye
  867. 40$:    mov    #1    ,-(sp)        ; flag as being binary and exit
  868. 50$:    tst    r4            ; ever opened up ?
  869.     beq    60$            ; no
  870.     calls    close    ,<2(r5)>    ; close up
  871. 60$:    mov    (sp)+    ,r0
  872. 90$:    $store    #0,NXT,r3        ; /E64/ restore old xab links, if any
  873.  
  874. 100$:    unsave    <r4,r3,r2,r1>        ; bye
  875.     return
  876.  
  877.  
  878.     .sbttl    getatr    return attributes for a file already open
  879.  
  880.     .mcall    ifaof$            ; access the ifab for the fab
  881.     ifaof$    rms$l            ; get the ifab symbols defined
  882.  
  883. ; /E64/    This appears to be unused
  884. ;
  885. ;getsiz::mov    @r5    ,r1        ; return error in r0, size in r1
  886. ;    asl    r1            ; lun times 2
  887. ;    mov    fablst(r1),r1        ; fab for this file
  888. ;    mov    <o$alq+0>(r1),r1    ; get the size please
  889. ;    clr    r0            ; no errors
  890. ;    return                ; exit
  891.  
  892. ; /E64/    This is bogus.  There is only one protection XAB, which
  893. ;    is used for all channels.  In addition, the FAB XAB pointer never
  894. ;    points to it here.  It either points to the DAT XAB or nothing.
  895. ;    Since changing the code to daisy-chain the PROT XAB to the DAT
  896. ;    XAB, we should either follow the link (which won't work because
  897. ;    the PROT XAB is only linked in for the duration of the OPEN call),
  898. ;    or use the staticly allocated proxab.
  899. ;getpro::mov    @r5    ,r0        ; size in r0
  900. ;    asl    r0            ; lun times 2
  901. ;    mov    fablst(r0),r0        ; fab for this file
  902. ;    mov    O$XAB(r0),r0        ; get the protection please
  903. getpro::mov    #proxab    ,r0        ; /E64/ point to protection xab
  904.     mov    O$PRO(r0),r0        ; ...
  905.     return                ; exit
  906.  
  907.  
  908.  
  909. ;    Getcdt    Return time/date of creation, system (ie, RMS vs RT) dep.
  910. ;
  911. ;    Passed:    (r5)    Channel number file is open on
  912. ;    Return:    R0    Zero if failure (internal error) else address of
  913. ;            64 byte Smithsonian date format
  914.  
  915.  
  916. Getcdt::mov    @r5    ,r0        ; Channel
  917.     beq    100$            ; Oops
  918.     asl    r0            ; Word offsets
  919.     mov    FABLST(r0),r0        ; Get the fab
  920.     beq    100$            ; Impossible
  921.     mov    O$XAB(r0),r0        ; XAB address
  922.     beq    100$            ; Nothing
  923.     add    #O$CDT    ,r0        ; Point to 4word creation dat/tim
  924. 100$:    return                ; Exit
  925.  
  926. Putcdt::mov    @r5    ,r0        ; Channel
  927.     beq    100$            ; Oops
  928.     asl    r0            ; Word offsets
  929.     mov    FABLST(r0),r0        ; Get the fab
  930.     beq    100$            ; Impossible
  931.     mov    O$XAB(r0),r0        ; XAB address
  932.     beq    100$            ; Nothing
  933.     add    #O$CDT    ,r0        ; Point to 4word creation dat/tim
  934.     mov    2(r5)    ,r1        ; Data
  935.     mov    (r1)+    ,(r0)+        ; Copy it
  936.     mov    (r1)+    ,(r0)+        ; .Copy it
  937.     mov    (r1)+    ,(r0)+        ; ..Copy it
  938.     mov    (r1)+    ,(r0)+        ; ...Copy it
  939. 100$:    return                ; Exit
  940.  
  941.  
  942. getatr::save    <r1,r2>            ; save these please
  943.     mov    @r5    ,r1        ; the channel number please
  944.     asl    r1            ; times two please
  945.     mov    fablst(r1),r1        ; simple
  946.     mov    o$ifi(r1),r1        ; and now we are at the ifab
  947.     mov    2(r5)    ,r2        ; where to copy the attributes to
  948.     movb    f$ratt(r1),(r2)+    ; stuff the input record attributes
  949.     movb    f$forg(r1),(r2)+    ; also stuff the input file org in
  950.     mov    f$rsiz(r1),(r2)+    ; and the input record size please
  951.     mov    f$hvbn(r1),(r2)+    ; and the input eof markers
  952.     mov    f$lvbn(r1),(r2)+    ; like hi and low virtual block
  953.     mov    f$heof(r1),(r2)+    ; and the high and low eof block
  954.     mov    f$leof(r1),(r2)+    ; numbers also
  955.     mov    f$ffby(r1),(r2)+    ; and, at last, the first free byte
  956.     movb    f$hdsz(r1),(r2)+    ; VFC header size next
  957.     movb    f$bksz(r1),(r2)+    ; and largest bucket size
  958.     mov    f$mrs(r1) ,(r2)+    ; the maximum record size
  959.     mov    f$deq(r1) ,(r2)+    ; and the default extenstion size
  960.     mov    f$rtde(r1),(r2)+    ; and the run time extentsion size
  961.     unsave    <r2,r1>            ; all done
  962.     return
  963.  
  964.  
  965.  
  966. putatr::save    <r1,r2>            ; save these please
  967.     mov    @r5    ,r1        ; the channel number please
  968.     asl    r1            ; times two please
  969.     mov    fablst(r1),r1        ; simple
  970.     mov    o$ifi(r1),r1        ; and now we are at the ifab
  971.     mov    2(r5)    ,r2        ; where to get the attributes from
  972.     movb    (r2)+    ,f$ratt(r1)    ; stuff the input record attributes
  973.     movb    (r2)+    ,f$forg(r1)    ; also stuff the input file org in
  974.     mov    (r2)+    ,f$rsiz(r1)    ; and the input record size please
  975.     mov    (r2)+    ,f$hvbn(r1)    ; and the input eof markers
  976.     mov    (r2)+    ,f$lvbn(r1)    ; like hi and low virtual block
  977.     mov    (r2)+    ,f$heof(r1)    ; and the high and low eof block
  978.     mov    (r2)+    ,f$leof(r1)    ; numbers also
  979.     mov    (r2)+    ,f$ffby(r1)    ; and, at last, the first free byte
  980.     movb    (r2)+    ,f$hdsz(r1)    ; VFC header size next
  981.     movb    (r2)+    ,f$bksz(r1)    ; and largest bucket size
  982.     mov    (r2)+    ,f$mrs(r1)    ; the maximum record size
  983.     mov    (r2)+    ,f$deq(r1)    ; and the default extenstion size
  984.     mov    (r2)+    ,f$rtde(r1)    ; and the run time extentsion size
  985.     unsave    <r2,r1>            ; all done
  986.     return
  987.  
  988.     .sbttl    connect record access block to file access block
  989.  
  990.  
  991. ;    C O N N E C T
  992. ;
  993. ;    connect( %val channel_number )
  994. ;
  995. ;    input:    r0    channel number
  996. ;        r1    multiblock count
  997. ;        r2    create/open/append option flag            +SSH
  998. ;    output:    r0    rms sts
  999. ;
  1000. ;    Connect a record access block to a file access block.
  1001. ;    Called only from OPEN and CREATE
  1002.  
  1003.  
  1004. rmscon:    mov    r1    ,-(sp)        ; the block count size
  1005.     mov    r0    ,r1        ; get address of record access block
  1006.     asl    r1            ; channel number times 2
  1007.     mov    rablst(r1),r1        ; address of a rab to use
  1008.     $store    (sp)+,MBC,r1        ; the block buffer count
  1009.     $store    #0,ROP,r1        ; assume no processing options       +SSH
  1010.     tst    r2            ; if appending to existing file       +SSH
  1011.     ble    7$            ; no, leave options alone       +SSH
  1012.     $store    #rb$eof,ROP,r1        ; yes, set position to EOF option  +SSH
  1013. 7$:                    ;                   +SSH
  1014.     $conne    r1            ; try hard to connect access up
  1015.     $fetch    r0,sts,r1        ; get status back out please
  1016.     tst    r0            ; if status > 0 then status = 0
  1017.     blt    10$            ; error if less than zero
  1018.     clr    r0            ; make > 0 status eq 0
  1019. 10$:    return
  1020.  
  1021.     .sbttl    disconnect record access block from file access block
  1022.  
  1023.  
  1024. ;    R M S D I S
  1025. ;
  1026. ;    input:    r0    channel number
  1027. ;        r0    error sts
  1028. ;
  1029.  
  1030. rmsdis:    mov    r0    ,r1
  1031.     asl    r1
  1032.     mov    rablst(r1),r1
  1033.     $discon    r1            ; disconnect access stream from file
  1034.     $fetch    r0,sts,r1        ; get status back out please
  1035.     tst    r0            ; if status > 0 then status = 0
  1036.     blt    10$            ; error if less than zero
  1037.     clr    r0            ; make > 0 status eq 0
  1038. 10$:    return
  1039.  
  1040.  
  1041.  
  1042.     .sbttl    read a record from a sequential file
  1043.  
  1044.  
  1045. ;    G E T R E C
  1046. ;
  1047. ;    getrec( %loc buffer, %val channel_number, %val buf_siz )
  1048. ;
  1049. ;    input:    @r5    address of user buffer, at least 80 bytes
  1050. ;        2(r5)    channel number
  1051. ;        4(r5)    buffer size
  1052. ;
  1053. ;    output:    r0    rms sts
  1054. ;        r1    record size
  1055. ;
  1056. ;    Read the next record from a disk file, up to 4(r5) bytes
  1057. ;    in length.  GETREC assumes text (stream ascii) file only.
  1058.  
  1059.  
  1060. getrec::mov    2(r5)    ,r0        ; get the channel number
  1061.     asl    r0            ; times 2 to index into table
  1062.     mov    rablst(r0),r1        ; get the record access buffer
  1063.     $store    #0  ,RSZ,r1
  1064.     $store    @r5 ,UBF,r1        ; stuff a record buffer in
  1065.     $store    4(r5),USZ,r1        ; and a maximum record size
  1066.     cmp    filtyp(r0),#binary    ; a binary file today ?
  1067.     bne    10$            ; no, use normal get$
  1068.     clr    o$bkt+0(r1)        ; use sequential mode please
  1069.     clr    o$bkt+2(r1)        ; both words are to have zero
  1070.     $read    r1            ; get next virtual block please
  1071.     br    20$            ; get error code out now
  1072. 10$:    $get    r1            ; read a record now
  1073. 20$:    $fetch    r0,STS,r1        ; get the return STATUS field
  1074.     tst    r0            ; did it work ?
  1075.     blt    100$            ; no
  1076.     clr    r0            ; say no errors
  1077.     $fetch    r1,RSZ,r1        ; get the record size now
  1078. 100$:    return
  1079.  
  1080.     .globl    o$bkt
  1081.  
  1082.  
  1083.     .sbttl    put a record to an rms sequential file
  1084.  
  1085.  
  1086. ;    P U T R E C
  1087. ;
  1088. ;    putrec( %loc buffer, %val record_size, %val channel_number )
  1089. ;
  1090. ;    input:    @r5    address of user buffer
  1091. ;        2(r5)    record size
  1092. ;        4(r5)    channel number
  1093. ;
  1094. ;    output:    r0    rms sts
  1095. ;
  1096. ;    Write the next record to  a disk file.
  1097.  
  1098.  
  1099. putrec::mov    r1    ,-(sp)
  1100.     mov    4(r5)    ,r0        ; get the channel number
  1101.     bne    5$            ; if zero then assume TI:
  1102.     print    @r5    ,2(r5)        ; dump the buffer to ti: then
  1103.     br    100$            ; and exit
  1104. 5$:    asl    r0            ; times 2 to index into table
  1105.     mov    rablst(r0),r1        ; get the record access buffer
  1106.     $store    @r5  ,RBF,r1        ; stuff a record buffer in
  1107.     $store    2(r5),RSZ,r1        ; and a current record size
  1108.     cmp    filtyp(r0),#binary    ; image mode today ?
  1109.     bne    10$            ; no
  1110.     $store    #1000,RSZ,r1        ; yes, insure block write
  1111.     clr    o$bkt+0(r1)        ; yes, clear the VBN fields
  1112.     clr    o$bkt+2(r1)        ; yes, clear the VBN fields
  1113.     $write    r1            ; simple
  1114.     br    20$            ; get the status and exit
  1115. 10$:    $put    r1            ; write a record now           /SSH
  1116. 20$:    $fetch    r0,STS,r1        ; get the return STATUS field
  1117.     tst    r0            ; did it work ?
  1118.     blt    99$            ; no
  1119.     clr    r0            ; say no errors
  1120.     br    100$
  1121. 99$:    mov    r0,tmperr        ; store error code for debugging
  1122. 100$:    mov    (sp)+    ,r1
  1123.     return
  1124.  
  1125.  
  1126.     .sbttl    Get next file to send
  1127.  
  1128. ;    G E T N X T
  1129. ;
  1130. ;    input:    srcnam    = possibly wildcarded file name
  1131. ;        index    = 0 if this is the first time through
  1132. ;    output:    filnam    = next file to do
  1133. ;         r0    = if <>, error code
  1134.  
  1135. getnxt::save    <r1>
  1136.     calls    lookup    ,<#srcnam,#filnam> ; /62/
  1137.     tst    r0            ; did it work?
  1138.     beq    30$            ; yes
  1139.     cmp    r0    ,#er$nmf    ; no more files matching name?
  1140.     beq    10$            ; yes, we are all done then
  1141.     cmp    r0    ,#er$fnf    ; how about file not found?
  1142.     bne    20$            ; no, print the error message out
  1143. 10$:    tst    index            ; ya, but did any files match yet?
  1144.     bne    30$            ; yes, that's ok then
  1145.     mov    #er$fnf    ,r0        ; no, convert er$nmf to er$fnf
  1146. 20$:    mov    r0    ,-(sp)        ; save lookup error
  1147.     calls    syserr    ,<r0,#errtxt>    ; get the error text
  1148.     calls    error    ,<#3,#errtxt,#aspace,#filnam> ; /62/ include file name
  1149.     mov    (sp)+    ,r0        ; restore saved error code from lookup
  1150. 30$:    unsave    <r1>
  1151.     return
  1152.  
  1153.  
  1154.     .sbttl    Get one character from a file
  1155.  
  1156.  
  1157. ;    G E T C
  1158. ;
  1159. ;    getc(%val channel_number)
  1160. ;
  1161. ;    input:     (r5)    = channel number
  1162. ;    output:      r1    = character just read
  1163. ;          r0    = RMS error status
  1164.  
  1165. getc::    mov    @r5    ,r0        ; channel to use
  1166.     .br    getcr0            ; /63/ dispatch to desired routine
  1167.  
  1168.     .sbttl    Decide where to get the next character
  1169.  
  1170. ;    G E T C R 0
  1171. ;    T G E T C R
  1172. ;
  1173. ;    Passed:      r0    = lun
  1174. ;    Return:      r0    = if <>, error code (generally er$eof)
  1175. ;          r1    = character just read
  1176. ;
  1177. ;    GETCR0  is  the lowest level entry point called in Kermit to
  1178. ;    obtain the next character for a  send  function  (even  GETC
  1179. ;    calls  it),  where  that  may  be a normal file transfer, or
  1180. ;    a server extended response.  The main idea in altering it is
  1181. ;    so   that   a   server   dispatch  routine  can  change  the
  1182. ;    default  (get from a file)  to,  say,  get  from  an  .asciz
  1183. ;    string   in   memory   or  switch  to  some  other  kind  of
  1184. ;    get_next_character routine.  This requires that  the service
  1185. ;    routine  insert  its  get_next_char routine address into the
  1186. ;    global  GETCROUTINE  and  also  reset  it when the action is
  1187. ;    complete (by use of the textsrc macro sans an argument).
  1188.  
  1189. getcr0::tst    getcroutine        ; /38/ is there a routine address set?
  1190.     beq    fgetcr0            ; /63/ no, default to file reading
  1191.     jmp    @getcroutine        ; /63/ call currently defined routine
  1192.  
  1193. tgetcr::tst    tgetaddr        ; /38/ have we ever been initted?
  1194.     beq    10$            ; /38/ no, return er$eof
  1195.     clr    r1            ; /63/   avoid sign extension
  1196.     bisb    @tgetaddr,r1        ; /63/ yes, get next character please
  1197.     beq    10$            ; /38/ nothing is left to do
  1198.     inc    tgetaddr        ; /38/ text_address++
  1199.     clr    r0            ; /38/ return(no_error)
  1200.     br    20$
  1201. 10$:    mov    #er$eof    ,r0        ; /38/ return(end_of_file)
  1202.     clr    getcroutine        ; /62/ reset to file reading please
  1203. 20$:    return
  1204.  
  1205. fgetcr0:save    <r2,r3>            ; save temps
  1206.     mov    r0    ,r2        ; channel number please
  1207.     asl    r2            ; times 2
  1208.     cmp    bufp(r2),#-1        ; need to initialize the buffer?
  1209.     bne    10$            ; no
  1210.     calls    getrec    ,<buflst(r2),r0,bufsiz(r2)>; yes, load it please
  1211.     tst    r0            ; did the read work ?
  1212.     bne    100$            ; no, return rms error code
  1213.     clr    bufp(r2)        ; it worked. clear current pointer
  1214.     mov    r1    ,bufs(r2)    ; and save the record size
  1215.     br    30$            ; and goto common code
  1216.  
  1217. 10$:    cmp    bufp(r2),#-2        ; flag to return <cr> ?
  1218.     bne    20$            ; no
  1219.     movb    #cr    ,r1        ; yes, return it in r1
  1220.     mov    #-3    ,bufp(r2)    ; and setup for a <lf> nexttime
  1221.     clr    r0            ; no error
  1222.     br    100$            ; bye
  1223.  
  1224. 20$:    cmp    bufp(r2),#-3        ; flag to return a <lf> ?
  1225.     bne    30$            ; no
  1226.     movb    #lf    ,r1        ; yes, return <lf> in r1
  1227.     mov    #-1    ,bufp(r2)    ; flag buffer reload next time
  1228.     clr    r0            ; no error
  1229.     br    100$
  1230.  
  1231.  
  1232. 30$:    tst    bufs(r2)        ; anything left to get in record?
  1233.     bne    40$            ; yes
  1234.     mov    #-2    ,bufp(r2)    ; no, flag for a <cr> next
  1235.     cmp    filtyp(r2),#binary    ; a binary file today ?
  1236.     bne    35$            ; yes, need data as is please
  1237.     mov    #-1    ,bufp(r2)    ; yes, flag for a read next
  1238. 35$:    mov    r2    ,r0        ; channel number please
  1239.     asr    r0            ; NOT times two
  1240.     call    getcr0            ; call ourselves to do it
  1241.     br    100$            ; and exit
  1242.  
  1243. 40$:    mov    buflst(r2),r3        ; get the address of the buffer
  1244.     add    bufp(r2),r3        ; and point to the next character
  1245.     clr    r1            ; to be returned in r1
  1246.     bisb    @r3    ,r1        ; simple
  1247.     inc    bufp(r2)        ; buffer.pointer := succ(buffer.pointer)
  1248.     dec    bufs(r2)        ; amountleft := pred( amountleft )
  1249.     clr    r0            ; no errors please
  1250.  
  1251. 100$:    unsave    <r3,r2>
  1252.     return
  1253.  
  1254.     .sbttl    putc    put a single character to an rms file
  1255.  
  1256. ;    P U T C
  1257. ;
  1258. ;    input:    @r5    the character to put
  1259. ;        2(r5)    the channel number to use
  1260. ;
  1261. ;    Buffer single character i/o to internal disk buffer.
  1262. ;    Buffer is dumped if internal buffer is  full or, for
  1263. ;    FB$VAR records (default for TEXT), a carraige return
  1264. ;    is found. For FB$VAR with FB$CR format, all carraige
  1265. ;    returns  and line feeds are  flushed as  this record
  1266. ;    format will have them put back later.
  1267. ;    The local buffers are allocated in CREATE and OPEN.
  1268.  
  1269.  
  1270. putc::    save    <r1>            ; simply save r1 and call putcr0
  1271.     mov    2(r5)    ,r1        ; to do it. putcr0 will be somewhat
  1272.     clr    r0            ; faster to call directly due to the
  1273.     bisb    @r5    ,r0        ; overhead involved in setting up an
  1274.     call    putcr0            ; argument list.
  1275.     unsave    <r1>            ; pop saved r1 and exit
  1276.     return                ; bye
  1277.  
  1278.  
  1279. putcr0::save    <r1,r2,r3,r4>        ; save registers we use
  1280.     mov    r1    ,r2        ; channel number
  1281.     asl    r2            ; times 2 of course
  1282.     cmp    filtyp(r2),#binary    ; is this a binary file today ?
  1283.     beq    5$            ; yes, don't dump buffer on <cr>
  1284.     cmpb    r0    ,recdlm        ; /56/ end of line time today ?
  1285.     beq    10$            ; yes, dump the record out
  1286. 5$:    cmp    bufp(r2),bufsiz(r2)    ; is the buffer full ?
  1287.     blo    20$            ; no, store some more characters in it
  1288. 10$:    movb    r0    ,r3        ; yes, save the input character r0
  1289.     calls    putrec    ,<buflst(r2),bufp(r2),r1> ; yes, dump the buffer please
  1290.     clr    bufp(r2)        ; pointer := 0
  1291.     tst    r0            ; did it work ?
  1292.     bne    100$            ; no, die
  1293.     mov    buflst(r2),r4        ; it worked. zero the buffer now
  1294.     mov    bufsiz(r2),r0        ; get the buffer address and size
  1295. 15$:    clrb    (r4)+            ; for i := 1 to bufsiz
  1296.     sob    r0    ,15$        ;   do buffer[i] := chr(0)
  1297.     movb    r3    ,r0        ; ok, restore the old character
  1298.  
  1299. 20$:    cmp    filtyp(r2),#binary    ; once again, is this a binary file ?
  1300.     beq    30$            ; yes, ignore checks for <LF> and ^Z.
  1301.     cmp    filtyp(r2),#terminal    ; terminal file today ?
  1302.     beq    30$            ; yes, we want cr's and lf's
  1303.     cmpb    r0    ,#lf        ; we simply like to ignore line feeds
  1304.     beq    90$            ; bye
  1305.     cmpb    r0    ,#'Z&37        ; control Z ?
  1306.     beq    90$            ; yes, ignore the control Z's please
  1307.     cmpb    r0    ,#cr        ; carraige return today ?
  1308.     beq    90$            ; yes, ignore it
  1309. 30$:    mov    bufp(r2),r1        ; get the current buffer pointer
  1310.     add    buflst(r2),r1        ; and point to a new home for the
  1311.     movb    r0    ,@r1        ; the input character in r0
  1312.     inc    bufp(r2)        ; pointer := succ( pointer )
  1313.  
  1314. 90$:    clr    r0            ; no errors
  1315. 100$:    unsave    <r4,r3,r2,r1>
  1316.     return
  1317.  
  1318.     .globl    recdlm            ; /56/
  1319.  
  1320.  
  1321.     .sbttl    flush
  1322.  
  1323.  
  1324. flush:    mov    @r5    ,r0        ; get the internal channel number
  1325.     asl    r0            ; times 2 for indexing
  1326.     tst    bufp(r0)        ; anything in the buffer
  1327.     beq    100$            ; no
  1328.     tst    mode(r0)        ; writing today ?
  1329.     beq    100$            ; no
  1330.     calls    putrec    ,<buflst(r0),bufp(r0),@r5> ; yes, dump it
  1331.     return
  1332. 100$:    clr    r0
  1333.     return
  1334.  
  1335.  
  1336.  
  1337.  
  1338.  
  1339.     .sbttl    lookup    do a filename lookup, wildcarding supported
  1340.     .enabl    gbl
  1341.  
  1342.  
  1343. ;    L O O K U P
  1344. ;
  1345. ;    input:    (r5)    address of input string
  1346. ;        2(r5)    address of output string
  1347. ;
  1348. ;    output:    r0    RMS error code
  1349. ;
  1350. ;
  1351. ;    clr    index
  1352. ;10$:    calls    lookup    ,<#inbuf,#outbuf>
  1353. ;    tst    r0
  1354. ;    bne    100$
  1355. ;    do something
  1356. ;    br    10$
  1357.  
  1358.  
  1359.  
  1360.  
  1361.     .mcall    $parse    ,$search,$store    ,$fetch    ,$compare
  1362.     .mcall    fab$b    ,fab$e    ,nam$b    ,nam$e
  1363.     .mcall    $off    $testbits                ;RBD01
  1364.  
  1365.     .save
  1366.     .psect    rmssup    ,d
  1367.  
  1368.  
  1369.  
  1370. fab:    fab$b                ; argument fab
  1371.      f$nam    nam            ; link to nam        ;RBD01--
  1372.      f$lch    1            ; a dummy channel for the i/o op
  1373.     fab$e
  1374.  
  1375. nam:    nam$b                ; nam definition
  1376.      n$esa    expstr            ; exp str address
  1377.      n$ess    64.            ; exp str length
  1378.      n$rsa    resstr            ; res str address
  1379.      n$rss    64.            ; res str length
  1380.     nam$e
  1381.  
  1382. expstr:    .blkb    64.            ; context must be preserved here
  1383. resstr:    .blkb    64.            ; a temp place for the result
  1384.  
  1385.     .restore
  1386.  
  1387.  
  1388.     .sbttl    the real work of lookup
  1389.  
  1390.     .psect    $code
  1391.  
  1392. lookup::save    <r1,r2,r3,r4,r5>    ; Save these please
  1393.     mov    #fab    ,r1        ; map the target fab    ;RBD01--
  1394.     tst    fu$def            ; do we really need a default device?
  1395.     beq    5$            ; no
  1396.     $store    #sydisk,DNA,r1        ; yes, please stuff the def device name
  1397.     $store    #sylen ,DNS,r1        ; and the length of it also please
  1398. 5$:    strlen    #defdir            ; anything in the Kermit default dir?
  1399.     tst    r0            ; if <> then use it
  1400.     beq    10$            ; nothing there to use. Let system do it
  1401.     $store    #defdir    ,DNA,r1        ; something was there, stuff it in
  1402.     $store    r0    ,DNS,r1        ; and the length of the default
  1403. 10$:    mov    r1    ,r0        ; save it for later
  1404.     mov    #nam    ,r3        ; map the target nam
  1405.     tst    index            ; first time thru needs a parse
  1406.     bne    40$            ; not the first time
  1407.  
  1408.     clrb    expstr            ; clear the expanded name and
  1409.     clrb    resstr            ; the resultant string
  1410.     mov    (r5)    ,r4        ; point to the filename passed
  1411.     mov    r4    ,r1        ; and save the pointer
  1412. 20$:    tstb    (r1)+            ; and get the length of the name
  1413.     bne    20$            ; for an .asciz string
  1414.     sub    r4    ,r1        ; compute the length of the string
  1415.     dec    r1            ; which is off by one
  1416.     $store    #lun.sr,lch,r0        ; channel number please
  1417.     $store    r1,fns,r0        ; stuff the filename length
  1418.     $store    r4,fna,r0        ; and the filename address
  1419.     $parse    r0            ; parse the strings
  1420.     $fetch    r4,sts,r0        ; get error codes
  1421.  
  1422.     cmp    #ER$UIN,r4        ; Maybe a remote file spec?    ;RBD01+
  1423.     bne    30$            ; (no)
  1424.     $testbits  #<nb$wve!nb$wty!nb$wna!nb$wdi>,fnb,r3    ; Anything wild?
  1425.     bne    90$            ; (wild remote files no good)
  1426.     $testbits  #nb$nod,fnb,r3    ; Remote file?
  1427.     beq    90$            ; (ER$UIN with no node???)
  1428.     $off    #nb$wch,fnb,r3        ; Make succeeding $search's act nice
  1429.     $fetch    r0,esl,r3        ; Pass back expanded string
  1430.     $fetch    r2,esa,r3        ;  and skip the $search.
  1431.     br    70$                            ;RBD01-
  1432.  
  1433. 30$:    tst    r4            ; < 0 ?
  1434.     bmi    90$            ; yes, error
  1435.  
  1436. ;    This added edit 2.12 by BDN for those RSTS systems that totally
  1437. ;    disallow directory lookups by modify the executive for non-priv
  1438. ;    users.
  1439.  
  1440. 40$:    tst    fu$dir            ; in case george w. @ purdue
  1441.     beq    50$            ; needs this due to a hacked up exec
  1442.     $testbits  #<nb$wve!nb$wty!nb$wna!nb$wdi>,fnb,r3    ; Anything wild?
  1443.     bne    50$            ; yes, let the $search go on
  1444.     tst    index            ; if no wildcarding and we have
  1445.     beq    45$            ; already been here then return
  1446.     mov    #ER$NMF    ,r4        ; no more files and exit
  1447.     br    90$            ; bye
  1448. 45$:    $fetch    r0,esl,r3        ; no, skip the $search and get the
  1449.     $fetch    r2,esa,r3        ; expanded string from $parse
  1450.     br    70$            ; and copy it over now
  1451.  
  1452. ;    End of option tp skip lookups for non-wildcarded filenames.
  1453.  
  1454.  
  1455. 50$:    $search    r0            ; get a matching file
  1456.     $fetch    r4,sts,r0        ; get error codes
  1457.     ;                                ;RBD01+
  1458.     ; The following shouldn't have been necessary, as I
  1459.     ; banged off the NB$WCH bit above. But ...
  1460.     ;
  1461.     cmp    r4,#ER$UIN        ; Remote file hacking?
  1462.     bne    60$            ; (no)
  1463.     mov    #ER$FNF,r4        ; Yes, no "more" files
  1464.     br    90$            ; and exit
  1465.  
  1466. 60$:    tst    r4            ; < 0 ?                ;RBD01-
  1467.     bmi    90$            ; yes, error
  1468.     $fetch    r0,rsl,r3        ; get the string length
  1469.     $fetch    r2,rsa,r3        ; get the string address
  1470.  
  1471. 70$:    mov    2(r5)    ,r1        ; where to return the string
  1472. 80$:    movb    (r2)+    ,(r1)+        ; copy it over
  1473.     sob    r0    ,80$        ; for however the long it is
  1474.     clrb    @r1            ; insure .asciz please
  1475.     clr    r0            ; no errors
  1476.     inc    index            ; say we have at least one file
  1477.     br    100$            ; and exit
  1478.  
  1479. 90$:    mov    r4    ,r0        ; error, return it please
  1480.     br    100$            ; exit
  1481.  
  1482. 100$:    unsave    <r5,r4,r3,r2,r1>
  1483.     return
  1484.  
  1485.  
  1486.  
  1487.     .save
  1488.     .psect    rendat    ,rw,d,lcl,con,lcl
  1489.  
  1490.     .mcall    $compare,$fetch    ,$parse    ,$search,$set    ,$store
  1491.     .mcall    fab$b    ,nam$b    ,$rename
  1492.  
  1493. ;    24-Jan-86  14:01:48 Rename, Delete and GMCR code moved to overlay
  1494.  
  1495.  
  1496. RNFAB1::FAB$B                ; Old file name
  1497.      F$NAM    RNNAM1            ; Link to RNNAM1        ;RBD01--
  1498.      F$LCH    1            ; Channel 1 (a dummy, filled in later)
  1499.     FAB$E
  1500.  
  1501. RNNAM1::NAM$B                ; NAM definition
  1502.     NAM$E
  1503.  
  1504.  
  1505. RNFAB2::FAB$B                ; New file name
  1506.      F$NAM    RNNAM2            ; Link to RNNAM2        ;RBD01--
  1507.      F$LCH    1            ; a dummy channel
  1508.     FAB$E
  1509.  
  1510. RNNAM2::NAM$B                ; NAM definition
  1511.     NAM$E
  1512.  
  1513.  
  1514.     .restore
  1515.  
  1516.  
  1517.  
  1518.     .sbttl    fparse    parse filename and fill in with defaults
  1519.  
  1520.     .mcall    $compar    ,$fetch    ,$off    ,$parse    ,$store
  1521.     .mcall    tlog$s
  1522.  
  1523. parfab    =    rnfab1
  1524. parnam    =    rnnam1
  1525.  
  1526.  
  1527. ;    F P A R S E
  1528. ;
  1529. ;    input:    @r5    input filename,     .asciz
  1530. ;        defdir    the default directory name string to use
  1531. ;
  1532. ;    output:    2(r5)    expanded filename, .asciz, maximum length 63 bytes
  1533. ;        r0    error codes
  1534.  
  1535.  
  1536. tlog::    clr    r0            ; /46/ No errors
  1537.     return                ; /46/ Exit
  1538.  
  1539.  
  1540.  
  1541. Fparse::save    <r1,r2,r3,r4>        ; /46/ save registers we may overwrite
  1542.     mov    @r5    ,r4        ; /46/ Assume input from source
  1543.     mov    #parfab    ,r1        ; point to the fab we use    ;RBD01--
  1544.     $store    #0,DNS,r1        ; /42/ PLEASE clear this OUT!
  1545.     tst    fu$def            ; do we need a default device string?
  1546.     beq    3$            ; no
  1547.     $store    #sydisk,DNA,r1        ; yes, please put it where we need it
  1548.     $store    #sylen ,DNS,r1        ;      also, the length also
  1549. 3$:    strlen    #defdir            ; get the default directory spec
  1550.     tst    r0            ; was anything there ?
  1551.     beq    4$            ; no
  1552.     $store    #defdir,DNA,r1        ; yes, stuff that in for the default
  1553.     $store    r0    ,DNS,r1        ; name string, and stuff the length.
  1554. 4$:    $store    #lun.sr,LCH,r1        ; a channel number to use for $PARSE
  1555.     $off    #fb$fid,FOP,r1        ; we want an implicit $SEARCH
  1556.     mov    #parnam    ,r2        ; also point to the NAME block
  1557.     sub    #100    ,sp        ; allocate result name string
  1558.     $store    sp  ,RSA,r2        ; set up the pointer to name string
  1559.     $store    #100,RSS,r2        ; and set the size of the string
  1560.     sub    #100    ,sp        ; allocate result expanded name string
  1561.     $store    sp  ,ESA,r2        ; set up the pointer to expanded name
  1562.     $store    #100,ESS,r2        ; and set the size of the string
  1563.     $store    #ER$FNM ,STS,r1        ; preset a bad filename error
  1564.     strlen    r4            ; /46/ get the length of the filename
  1565.     tst    r0            ; anything left at all ?
  1566.     beq    90$            ; no, fake a bad filename please
  1567.     $store    r0,FNS,r1        ; stuff the filename size in please
  1568.     $store    r4,FNA,r1        ; /46/ stuff the filename address
  1569.     $parse    r1            ; try to parse the filename now
  1570.  
  1571.     $compar    #ER$UIN,sts,r1        ; Maybe a remote file spec?    ;RBD01+
  1572.     bne    5$            ; (no)
  1573.     $testb    #<nb$wve!nb$wty!nb$wna!nb$wdi>,fnb,r2    ; Anything wild?
  1574.     bne    90$            ; (wild remote files no good)
  1575.     $testb    #nb$nod,fnb,r2        ; Remote file?
  1576.     beq    90$            ; (ER$UIN with no node???)
  1577.     $off    #nb$wch,fnb,r2        ; Make succeeding $search's act nice
  1578.     br    7$            ; Go ahead with it        ;RBD01-
  1579.  
  1580. 5$:    $compar    #0  ,STS,r1        ; did the parse of the name work ?
  1581.     blt    90$            ; no, exit and return STS in r0
  1582.  
  1583. 7$:    mov    2(r5)    ,r1        ; where we will copy the name to
  1584.     movb    o$esl(r2),r0        ; the length of the new name
  1585.     beq    30$            ; can't happen unless you fubar
  1586.     cmp    r0    ,#77        ; truncate names that are too long
  1587.     blos    10$            ; it's ok
  1588.     mov    #77    ,r0        ; too long, please set it to 63 (10)
  1589. 10$:    mov    o$esa(r2),r2        ; where the name is coming from
  1590. 20$:    movb    (r2)+    ,(r1)+        ; copy a byte at a time please
  1591.     sob    r0    ,20$        ; next please
  1592. 30$:    clrb    @r1            ; insure .asciz please
  1593.     clr    r0            ; no errors please
  1594.     br    100$            ; bye
  1595.  
  1596. 90$:    $fetch    r0,STS,r1        ; error from parse, return in r0
  1597. 100$:    add    #200    ,sp        ; pop local nameblock buffers
  1598. 110$:    unsave    <r4,r3,r2,r1>        ; /46/ pop registers
  1599.     return                ; bye
  1600.  
  1601.  
  1602.     .globl    defdir
  1603.  
  1604.  
  1605. ;    F I X W I L D
  1606. ;
  1607. ;    FIXWILD will replace % with ? for RSTS/E
  1608. ;
  1609. ;    input:    @r5    Address of string to process
  1610.  
  1611.  
  1612. fixwil::nop                ; in case we want to patch to 207
  1613.     save    <r2>            ; save a register we use here
  1614.     mov    @r5    ,r2        ; get the string address
  1615. 10$:    tstb    @r2            ; done with the filename yet ?
  1616.     beq    100$            ; yes, exit
  1617.     cmpb    @r2    ,#'%        ; check for a % character
  1618.     bne    20$            ; no
  1619.     movb    #'?    ,@r2        ; yes, replace with question mark
  1620. 20$:    inc    r2            ; next please
  1621.     br    10$            ; back again
  1622. 100$:    unsave    <r2>            ; pop r2
  1623.     clr    r0            ; no errors
  1624.     return                ; bye
  1625.  
  1626.  
  1627.  
  1628. iswild::save    <r1,r2>            ; save a register we may use
  1629.     mov    #parfab,r2        ; get a fab to use for this
  1630.     tst    fu$def            ; do we need a default device string?
  1631.     beq    5$            ; no
  1632.     $store    #sydisk,DNA,r2        ; yes, please put it where we need it
  1633.     $store    #sylen ,DNS,r2        ;      also, the length also
  1634. 5$:    strlen    #defdir            ; get the default directory spec
  1635.     tst    r0            ; was anything there ?
  1636.     beq    10$            ; no
  1637.     $store    #defdir,DNA,r2        ; yes, stuff that in for the default
  1638.     $store    r0    ,DNS,r2        ; name string, and stuff the length.
  1639. 10$:    $store    @r5,FNA,r2        ; filename address
  1640.     strlen    @r5            ; length
  1641.     $store    r0,FNS,r2        ; into the FAB please
  1642.     $fetch    r1,NAM,r2        ; get NAM block address
  1643.     clr    O$ESA(r1)        ; no expanded string address
  1644.     clr    O$RSA(r1)        ; no resultant string address
  1645.     clrb    O$ESS(r1)        ; no length fields either
  1646.     clrb    O$RSS(r1)        ; no length fields either
  1647.     $parse    r2            ; parse the filename
  1648.     $fetch    r0,STS,r2        ; get the status
  1649.     bmi    90$            ; exit on error please
  1650.     $testbi #NB$WVE!NB$WTY!NB$WNA!NB$WDI,FNB,r1 ; any wildcarding today ?
  1651.     beq    90$            ; no
  1652.     mov    #1    ,r0        ; yes, return(true)
  1653.     br    100$            ; exit
  1654. 90$:    clr    r0
  1655. 100$:    unsave    <r2,r1>            ; pop reg and exit
  1656.     return                ; exit
  1657.  
  1658.     .sbttl    return current task size and return exec
  1659.  
  1660.     .mcall    gtsk$s    ,gtim$s
  1661.  
  1662.  
  1663.  
  1664. second::save    <r2,r3>            ; /43/ Get seconds past midnight
  1665.     sub    #40    ,sp        ; /43/ Used for reporting transfer
  1666.     mov    sp    ,r2        ; /43/ statistics
  1667.     gtim$s    r2            ; /43/ One should really get the time
  1668.     mov    g.ticp(r2),clkflg    ; /E64/ grab the clock tick rate
  1669.     mov    g.timi(r2),r3        ; /43/ in the 64 bit klunk format to
  1670.     mul    #60.    ,r3        ; /43/ avoid 24 hour rollover, but
  1671.     add    g.tisc(r2),r3        ; /43/ I really think this is
  1672.     mov    g.tihr(r2),r0        ; /43/ sufficient
  1673.     clr    r1            ; /43/ multiply hour of day by 3600
  1674.     mul    #60.*60.,r0        ; /43/ which has to be 32 bits in
  1675.     add    r3    ,r1        ; /43/ size, then add in minutes*60
  1676.     adc    r0            ; /43/ + seconds.
  1677.     add    #40    ,sp        ; /43/ Pop buffer and exit
  1678.     unsave    <r3,r2>            ; /43/ Pop registers
  1679.     return                ; /43/ Bye
  1680.  
  1681.  
  1682.     .sbttl    gsa    get space for i/o buffers
  1683.  
  1684.  
  1685. ;    Modified from sample GSA from RMS v2 distribution
  1686. ;    by Brian Nelson  05-Jan-84  10:22:06
  1687. ;
  1688. ;
  1689. ;  Interface:
  1690. ;    Request space:
  1691. ;      R0 ->  RMS/user Pool list head (maintained by RL/CQB)
  1692. ;      R1 :=  Amount of space requested (bytes)
  1693. ;      R2 :=  0 (differentiates between request and release)
  1694. ;
  1695. ;    Release space:
  1696. ;      R0 ->  RMS Pool list head (maintained by RL/CQB)
  1697. ;      R1 :=  Amount of space to be released (bytes)
  1698. ;      R2 ->  Base address (for release)
  1699. ;
  1700. ;
  1701. ;  Returns:
  1702. ;    C-Bit "set"   if an error has occurred (failure)
  1703. ;    C-Bit "clear" if no error has occurred (success)
  1704. ;
  1705.  
  1706.  
  1707.     .Mcall    Extk$S
  1708.  
  1709.  
  1710.     .Sbttl    Control block definitions
  1711.  
  1712.     .Psect    GSA$$D,RW,D
  1713.  
  1714. ;
  1715. ; GSA internal data:
  1716. ;
  1717. ;   GSABAS - Base address for the next memory allocation.
  1718. ;         Initially set to zero, it will be assigned
  1719. ;         the first address outside of the task's
  1720. ;         current address limits.
  1721. ;   GSAMIN - Decimal value reflecting the minimum size
  1722. ;         (in bytes) to extend the task in order to
  1723. ;         provide space to the pool.
  1724. ;   GSAREQ - Requested pool block number.  If a request
  1725. ;         for the 'GSAMIN' fails, then the original
  1726. ;         allocation size will be attempted.  If that
  1727. ;         fails, then there is no more memory left.
  1728. ;
  1729.  
  1730. GSABAS::            ; GSA base address
  1731.     .Word    000000        ; (for next allocation)
  1732. GSAMIN::            ; Minimum allocation
  1733.     .Word    512./64.    ; (in 32-word blocks)
  1734. GSAREQ::            ; Size of this request
  1735.     .Word    000000        ; (if 'GSAMIN' extends fail)
  1736.  
  1737.  
  1738.  
  1739.     .Sbttl    GSA Initialization code
  1740.  
  1741.     .Psect    GSA$$I,RO,I
  1742.  
  1743.  
  1744.     .mcall    extk$s    ,gtsk$s
  1745.  
  1746. GSAINI:
  1747.     Mov    R0,-(SP)    ; R0-2 will be used to
  1748.     Mov    R1,-(SP)    ; communicate with $INIDM
  1749.     Mov    R2,-(SP)    ; NOTE: $INIDM uses EXTSK.
  1750.     mov    r0    ,-(sp)    ; save r0
  1751.     sub    #40    ,sp    ; check for 512 boundary
  1752.     mov    sp    ,r0    ; get the current task size and see
  1753.     gtsk$s    r0        ; if we are at a boundary. if so, then
  1754.     mov    g.tsts(r0),r0    ; extend a little bit to get INIDM to
  1755.     add    #40    ,sp    ; behave itself
  1756.     bic    #^c777    ,r0    ; strip all the high crap
  1757.     cmp    r0    ,#776    ; should we extend a little bit?
  1758.     blo    10$        ; no
  1759.     extk$s    #1        ; yes, get 64 more bytes please
  1760. 10$:    mov    (sp)+    ,r0    ; restore r0
  1761.  
  1762.     Call    $INIDM        ; Initialize dynamic memory
  1763.     Mov    R1,GSABAS    ; Setup the "free" address
  1764.     Mov    (SP)+,R2    ; Restore the registers
  1765.     Mov    (SP)+,R1    ;
  1766.     Mov    (SP)+,R0    ;
  1767.     Return            ; And return to GSA
  1768.  
  1769.  
  1770.  
  1771.     .Sbttl    GSA Mainline code
  1772.  
  1773.     .Psect    GSA$$M,RO,I
  1774.  
  1775. ;
  1776. ; GSA Mainline
  1777. ;
  1778. ;   Entry point is "GSA", with registers 0-2 loaded as
  1779. ;   described above.
  1780. ;
  1781.  
  1782. GSA::
  1783. gsax:
  1784.  
  1785. ;
  1786. ; First, determine if dynamic memory has been initialized.
  1787. ; GSABAS (initially set to zero) will be non-zero if $INIDM
  1788. ; has been called and the memory list initialized.  On RSX
  1789. ; based systems it is possible to install tasks with an
  1790. ; extension (/INCREMENT).  $INIDM will detect this and setup
  1791. ; the first memory entry in the pool list.
  1792. ;
  1793. ; A point to note: If the RSX task has been installed with
  1794. ; the non-checkpointable (/-CP) flag, then EXTKs will not
  1795. ; return success.  If it is necessary to install the task
  1796. ; non-checkpointable, then the task should be installed with
  1797. ; and increment value.
  1798. ;
  1799.  
  1800.     Tst    GSABAS        ; Dynamic memory initialized?
  1801.     Bne    10$        ; Yes if NE, proceed
  1802.     Call    GSAINI        ; Otherwise, initialize pool
  1803. 10$:    Tst    R1        ; Real memory?
  1804.     Bne    20$        ; Yes if NE, then process it
  1805.     Return            ; Otherwise return with success
  1806.  
  1807.  
  1808. 20$:    Tst    R2        ; Address specified? (release)
  1809.     Beq    30$        ; No if EQ, then it's a request
  1810.     Jmp    $RLCB        ; Otherwise it's a release; do it
  1811. 30$:    Mov    R0,-(SP)    ; save pool list head
  1812.     Mov    R1,-(SP)    ; save size of request
  1813.     Mov    R2,-(SP)    ; save entry flag
  1814.     Call    $RQCB        ; Try the allocation
  1815.     Bcc    70$        ; CC signifies success
  1816.     Mov    2(SP),R1    ; Obtain the request size
  1817.     Add    #63.,R1        ; Round the request
  1818.     Asr    R1        ; to a 32-word boundary
  1819.     Asr    R1        ; Then convert the value
  1820.     Asr    R1        ; to the number of
  1821.     Asr    R1        ; 32-word blocks.
  1822.     Asr    R1
  1823.     Asr    R1
  1824.     Mov    R1,GSAREQ    ; Save the real size
  1825.     Cmp    R1,GSAMIN    ; Smaller than minimum?
  1826.     Bhi    40$        ; No if HI, use it as is
  1827.     Mov    GSAMIN,R1    ; Otherwise use GSAMIN
  1828. 40$:    Extk$S    R1        ; Extend the task
  1829.     Bcc    60$        ; CC if successful
  1830.     Cmp    R1,GSAREQ    ; Is this request?
  1831.     Blos    50$        ; Yes if LOS, the end
  1832.     Mov    GSAREQ,R1    ; Otherwise try to use
  1833.     Br    40$        ; the actual request
  1834. 50$:    Sec            ; Mark failure
  1835.     Br    70$        ; And exit
  1836.  
  1837. 60$:    Mov    4(SP),R0    ; Setup the PLH
  1838.     Asl    R1        ; Convert the real
  1839.     Asl    R1        ; size to the actual
  1840.     Asl    R1        ; 16-bit size that
  1841.     Asl    R1        ; was allocated.
  1842.     Asl    R1        ; The virtual address
  1843.     Asl    R1        ; should be after the
  1844.     Mov    GSABAS,R2    ; task (which is now
  1845.     Add    R1,GSABAS    ; part of the task)
  1846.     Call    GSAX        ; Call ourself to release
  1847.     Mov    (SP)+,R2    ; Restore our registers
  1848.     Mov    (SP)+,R1    ; to the initial state
  1849.     Mov    (SP)+,R0    ; upon entry, and reenter
  1850.     Br    GSAX        ; as if it's a new request
  1851.  
  1852. 70$:    Inc    (SP)+        ; These won't alter the
  1853.     Bit    (SP)+,(SP)+    ; C-bit, so status remains
  1854.     Return            ; unchanged upon return
  1855.  
  1856.  
  1857.  
  1858.     .sbttl    Corrected version of $INIDM
  1859.  
  1860. ;     Re-do $INIDM to use the  actual task top address,  not
  1861. ;    that which was stored by TKB from the .LIMIT directive.
  1862. ;    This is required because we have already done a EXTK$S.
  1863. ;
  1864. ;    17-Feb-87  07:11:21  BDN edit 3.56
  1865.  
  1866.     .mcall    GPRT$    ,GTSK$    ,DIR$    ,GTSK$S
  1867.     .Save
  1868.     .psect    IMPURE    ,d
  1869.  
  1870. Limit:    .Limit
  1871. pdpb:    GPRT$    tbuf
  1872. tdpb:    GTSK$    tbuf
  1873.  
  1874. tbuf:    .blkw    20
  1875.  
  1876.     .Restore
  1877.  
  1878.     .Psect    PURE$I    ,RO,I,LCL,REL,CON
  1879.  
  1880. ;    Inidm
  1881. ;
  1882. ;    Input:    r0    Address of free code pool listhead
  1883. ;    Output:    r0    First address in task
  1884. ;        r1    Address following task
  1885. ;        r2    Size of core pool
  1886.  
  1887. $Inidm::DIR$    #tdpb            ; We already did an EXTK$S so
  1888.     mov    tbuf+G.TSTS,r2        ; want to use the CURRENT topmem
  1889.     add    #3    ,r2        ; Round up to next 4 byte boundary
  1890.     bic    #3    ,r2        ; ...
  1891.     mov    r2    ,@r0        ; Set base address of pool
  1892.     EXTK$S    #1            ; Ask for just a little bit more
  1893.     DIR$    #pdpb            ; Get partition parameters
  1894.     mov    $DSW    ,r0        ; Save starting address of partition
  1895.     DIR$    #tdpb            ; Get task parameters
  1896.     mov    r2    ,-(sp)        ; Save starting address
  1897.     clr    (r2)+            ; Clear out first word
  1898.     mov    tbuf+G.TSTS,(r2)    ; Set physical size of task
  1899.     sub    r0    ,(sp)        ; Compute apparent size of task
  1900.     mov    r0    ,r1        ; Copy base address
  1901.     add    (r2)    ,r1        ; Next address after task
  1902.     sub    (sp)+    ,(r2)        ; Set size of free pool
  1903.     mov    (r2)    ,r2        ; Get size
  1904.     return                ; And exit
  1905.  
  1906.     .sbttl    Increment status    ; /BBS/ added this
  1907.  
  1908. ;    This kludge is provided because RT-11XM for some reason loses
  1909. ;    track of the status word's address, even when it's kept in the
  1910. ;    root, after calling c$dial results in a failed call four times.
  1911. ;    Then, it writes into RMON, trashing it and crashing everything.
  1912.  
  1913. ;    This is NOT any problem under TSX-Plus..   Billy Y.  24-Apr-91
  1914.  
  1915. incsts::inc    status
  1916.     return
  1917.  
  1918.  
  1919.     .sbttl    cctrap    the control C trap
  1920.  
  1921. cctrap::cmp    cccnt    ,#cc$max
  1922.     bhi    100$
  1923.     CALL    setcc
  1924.     inc    cccnt
  1925.     return
  1926. 100$:    tst    inserv
  1927.     beq    110$
  1928.     call    rstsrv
  1929. 110$:    tst    infomsg            ; /43/
  1930.     beq    120$            ; /43/
  1931.     wrtall    #rme.07            ; /E64/
  1932. 120$:    jmp    c$exit
  1933.     .globl    cccnt    ,inserv    ,rstsrv    ,infomsg
  1934.  
  1935. ;    D I R E R $
  1936. ;
  1937. ;    called from DIRERR value  macro
  1938. direr$::mov    r0    ,-(sp)        ; direrr will select whether or not
  1939.     mov    4(sp)    ,r0        ; to call rms error or FIP (or DIR)
  1940.     beq    10$            ; error based on whether the error
  1941.     CALLS    syserr    ,<r0,#errtxt>    ; code is < 0 (implies RMS) or > 0
  1942.     wrtall    #errtxt            ; which  implies either FIP  (RSTS)
  1943.     .newline            ; or a DIRECTIVE error (RSX).  Thus
  1944. 10$:    mov    (sp)+    ,r0        ; for RSX all error codes should be
  1945.     mov    @sp    ,2(sp)        ; made > 0 for non RMS errors.
  1946.     tst    (sp)+            ; error 0 is a no-op.
  1947.     return
  1948.  
  1949.  
  1950.     .sbttl    Open and close the link device
  1951.  
  1952. opentt::clr    r0            ; /BBS/ preset to no error
  1953.     tst    linksts            ; already open?
  1954.     bne    100$            ; yes, ignore it then
  1955.     tst    remote            ; if remote
  1956.     beq    10$            ;  then ttname := ourname
  1957.     tst    inserv            ; but not if we are a server
  1958.     beq    5$            ; and the line number has been
  1959.     tstb    ttname            ; set already
  1960.     bne    10$            ;
  1961. 5$:    calls    gttnam  ,<#ttname>    ; get the terminal name here
  1962. 10$:    calls    ttyini    ,<#ter$pa>    ; /E64/ init the link device
  1963.     tst    r0            ; did it work?
  1964.     bne    100$            ; no
  1965.     mov    sp    ,linksts    ; ya, flag it as being open
  1966. 100$:    return
  1967.  
  1968. clostt::save    <r0>
  1969.     call    ttyfin            ; close the link
  1970.     calls    ttyrst            ; /62/ reset the terminal
  1971.     clr    linksts            ; flag link is now closed
  1972.     unsave    <r0>
  1973.     return
  1974.  
  1975.     .end
  1976.