File:  [Coherent Logic Development] / freem / contrib / %ugexp.m
Revision 1.1.1.1 (vendor branch): download - view: text, annotated - select for diffs
Sun Jan 19 02:04:04 2025 UTC (6 months, 1 week ago) by snw
Branches: MAIN, CoherentLogicDevelopment
CVS tags: v0-63-1-rc1, v0-63-0-rc1, v0-63-0, v0-62-3, v0-62-2, v0-62-1, v0-62-0, start, HEAD
FreeM

    1: %ugexp ; Global export utility - version 0.5.0.1
    2:  ; Jon Diamond - 1999-03-31
    3:  ;
    4:  w !,$t(+1),"  ",$$^%uxdat
    5:  ;
    6:  n error,device,comment
    7:  s error=$$init^%uxxxx,comment="",device=""
    8:  ;
    9:  k @%uwork
   10: %gsel s error=$$gsel^%ugxxx(%uwork) q:error<0
   11:  i $o(@%uwork@(""))="" s error=$$writep^%uxxxx("No globals selected") q
   12:  ;
   13: %device i device'="" s error=$$close^%ufxxx(device) i error<0 g %exit1
   14:  s error=$$select^%ufxxx(.device,"out")
   15:  i +error=-1 g %gsel
   16:  i error<0 g %exit1
   17:  ;
   18: %comment s error=$$readn^%uxxxx("Header comment ",.comment)
   19:  i +error=-1 g %device
   20:  ;
   21:  s error=$$go(device,%uwork,comment) i error<0 s a=$$error^%uxxxx(error) g %exit
   22:  s error=$$writep^%uxxxx("Finished")
   23: %exit s error=$$close^%ufxxx(device) i error<0 ; ??? if error
   24: %exit1 k @%uwork
   25:  q
   26:  ;
   27:  ; Executable entry point
   28:  ; Needs modifying to allow a selection mask (major changes!)
   29: go(device,select,comment)
   30:  n a,b,c,error,cnt
   31:  s error=$$header^%ufxxx(device,$t(+1),$g(comment)) i error<0 q error
   32:  s a=99999
   33:  f  s a=$o(@select@(a)) q:a=""  d  q:error<0
   34:  . s (b,c)=^(a),cnt=0 i $e(b)'="^" s (b,c)="^"_b
   35:  . i $e(c,$l(c))=")" s $e(c,$l(c))=""
   36:  . s error=$$writep^%uxxxx("Writing global - "_b)
   37:  . f  s b=$q(@b) q:$e(b,1,$l(c))'=c  d  q:error<0
   38:  . . s error=$$write^%ufxxx(device,b) q:error<0
   39:  . . s error=$$write^%ufxxx(device,@b)
   40:  . . s cnt=cnt+1
   41:  i error'<0 s error=$$trailer^%ufxxx(device,$t(+1))
   42:  q error
   43:  ;
   44:  ;
   45:  ; Alternative entry point with Open/Close included
   46: export(device,select,comment) 
   47:  n error
   48:  s error=$$open^%ufxxx(device,"out") q:error<0
   49:  s error=$$go(device,select,$g(comment)) q:error<0
   50:  s error=$$close^%ufxxx(device)
   51:  q
   52: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>