1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PXNK:SYSTEM-EXTRAS.SL 4% Title: HPUX Unix specific code for PSL 5% Author: Eric Benson 6% Created: 9 October 1981 7% Modified: 2-Jan-85 (Vicki O'Day) 8% Package: Kernel 9% Status: Open Source: BSD License 10% 11% (c) Copyright 1982, University of Utah 12% 13% Redistribution and use in source and binary forms, with or without 14% modification, are permitted provided that the following conditions are met: 15% 16% * Redistributions of source code must retain the relevant copyright 17% notice, this list of conditions and the following disclaimer. 18% * Redistributions in binary form must reproduce the above copyright 19% notice, this list of conditions and the following disclaimer in the 20% documentation and/or other materials provided with the distribution. 21% 22% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 23% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 24% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 25% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 26% CONTRIBUTORS 27% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 28% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 29% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 30% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 31% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 32% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33% POSSIBILITY OF SUCH DAMAGE. 34% 35%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 36% 37% Revisions: 38% 39% 25-Aug-87 (Leigh Stoller) 40% Added definition of external-allocatemorebps to map to allocatemorebps. 41% Vax nameing convention fix. 42% 29-May-87 (Leigh Stoller & Harold Carr) 43% Added setenv function. 44% 28-May-87 (Leigh Stoller & Harold Carr) 45% Added unix-time function for pcls. 46% 02-Sep-86 (Harold Carr) 47% Made QUIT call exit-with-status with 0 instead of doing a 48% (throw 'reset 'quit). (throw 'reset 'quit) makes it impossible to 49% make special PSLs with initcode to do some work and then call 50% (exitlisp) or (quit). The initcode is evaluated before the reset 51% tag is in place. 52% 01-Sep-86 (Leigh Stoller) 53% Modified the system function to call an external C routine that does 54% makes the actual call to system and returns the value. 55% 19-Aug-86 (Leigh Stoller) 56% Added the filestatus function. 57% 03-Aug-86 (Leigh Stoller) 58% Modified the quit function so that it looks at the break loop level to 59% determine if a nonzero status should be returned to the OS. 60% 2-Jan-85 (Vicki O'Day) 61% Now that system signal-handler frames are popped from the stack, deref 62% isn't necessary, so it was removed. 63% 21-Dec-84 (Vicki O'Day) 64% Added new check to returnaddressp: it now calls a function "deref", 65% which invokes the C routine "dereference" to find out if dereferencing 66% an address is safe. 67% 14-Nov-84 (Vicki O'Day) 68% Changed returnaddressp to check for address >= 2000, to account 69% for HP-UX mapping above ROM. 70% 17-Jul-84 23:13:12 (RAM) 71% Removed coredump routines because they kept getting in the way. 72% Changed call to chdir to a call on unixcd, to incorporate expand_file_name. 73% 12 June 84 (Vicki O'Day) 74% Added routines to turn coredumps on and off, with the help of 75% a super-user owned "createcore" program. 76% 11-May-84 10:00:00 (Vicki O'Day) 77% Changed system to call nof_system, a no-fork version. 78% This is part of Bill Watkins' escape-to-shell mechanism. 79% 27-Feb-84 16:52:12 (RAM) 80% Pathin the appropriate files for HPUX200. 81% Set system_list* to reasonable HPUX200 default. 82% Modified quit, exitlisp, and returnaddressp to do right things. 83% Added system function, like elsewhere on VAX version. 84% Changed all references to _filepointerofchannel to channeltable. 85% Changed call to byte in importforeignstring to getbyte since byte not 86% defined yet. 87% Fixed some bugs in getstartupname. 88% 2-Dec-83 16:00:00 (Brian Beach) 89% Translated from Rlisp to Lisp. 90% 91%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 92 93% 94% $pv/system-extras.red, Tue Nov 23 16:43:32 1982, Edit by fish 95% Added getUnixArgs and getStartupName, factored out importForeignString. 96% $pv/system-extras.red, Nov 1 12:41:36 1982, Edit by fish 97% Added cd, pwd, channelFlush. 98% <PSL.KERNEL-VAX>SYSTEM-EXTRAS.RED.5, 22-Sep-82 10:57:37, Edit by BENSON 99% Added user-homedir-string and getenv to end of file 100% $pi/system-extras.red, Aug 11 07:19:06 1982, Edit by fish 101% Added flushStdOutputBuffer for Emode. 102 103(compiletime (load sys-consts sys-macros fast-vector inum)) 104 105%(compiletime (load include)) 106%(compiletime (include "C:/psl/kernel/winnt/psllcall.h")) 107 108(compiletime (progn 109(setq define-list '( 110#define YIELD 0 111#define PUTS 1 112#define PUTINT 2 113#define PUTOCT 3 114#define NEWLINE 4 115#define PUTC 5 116#define BINARYOPENREAD 6 117#define BINARYOPENWRITE 7 118#define BINARYCLOSE 8 119#define BINARYREADBLOCK 9 120#define BINARYWRITEBLOCK 10 121#define GETDATE 12 122#define TIMC 13 123#define SIGNAL 14 124#define CD 15 125#define FGETS 16 126#define SYSTEM 17 127#define YESP 18 128#define GETTIME 19 129#define LINELENGTH 20 130#define ASKUSER 21 131#define LSEEK 22 132#define HELP 23 133#define CONNECT_OPEN 24 134#define CONNECT_CLOSE 25 135#define CONNECT_FETCH 26 136#define CONNECT_SEND 27 137#define CONNECT_ASK 28 138#define CONNECT_BLOCK 29 139#define SLEEP 30 140#define PSLL_RESET 31 141#define EXIT_WITH_STATUS 32 142#define PIPE_OPEN 33 143#define PIPE_CLOSE 34 144#define PAGE 35 145#define MENU 36 146#define WIN_PAR 37 147#define FILE_TREE 38 148 149 150 151#define PSLCALL_TERMINAL_INTERRUPT 0 152#define PSLCALL_RESIZE 1 153#define PSLCALL_GRAPHICS_MODE 3 154#define PSLCALL_GRAPHICS_MODE_ON 3 155#define PSLCALL_GRAPHICS_MODE_OFF 4 156#define PSLCALL_MENU 5 157)) 158(while define-list 159 (pop define-list) 160 (pop define-list) 161 (apply 'define-constant 162 (list (list 'define-constant 163 (pop define-list) 164 (pop define-list))))) 165)) % #include 166 167 168(on fast-integers) 169 170% Import Unix argument vector as a vector of strings. 171(fluid '(unixargs*)) 172 173%(de quit () 174% (errorprintf "%f%nQuitting") 175% (throw 'reset 'quit)) 176% 177% Quit know looks at the break loop level to determine if we are exiting 178% with a truly 0 status. If breaklevel* is > 0, then something is wrong, and 179% we should return some other value besides the default zero status. /LBS 180 181(de quit () 182 (errorprintf "%f%nQuitting") 183 (cond 184 ((greaterp breaklevel* 0) 185 (exit-with-status -1)) 186 (t 187 (exit-with-status 0)))) 188 189(de exitlisp () 190 (quit)) 191 192(de system (unixstring) 193 (if (stringp unixstring) 194 (external_system (strbase (strinf unixstring))) 195 (nonstringerror unixstring 'system))) 196 197(de delete-file (unixstring) 198 (if (stringp unixstring) 199 (weq 0 (external_unlink (strbase (strinf unixstring)))) 200 (nonstringerror unixstring 'delete-file))) 201 202 203(declare-warray filestatus-work size 13) 204 205(compiletime (flag '(mkfiletime) 'internalfunction)) 206 207(de mkfiletime (low high) 208 (let ((bi (gtpos 2))) 209 (wputv (inf bi) 2 low) 210 (wputv (inf bi) 3 high) 211 (cons 'filetime bi))) 212 213(de filestatus (filenamestring dostrings) 214 (let ((status (get_file_status 215 (expand_file_name (unixstring filenamestring)) 216 filestatus-work 217 (if dostrings 1 0)))) 218 (if (weq status -1) nil 219 (when (and (weq status 0) (getd 'gtpos)) % 0 = success 220 (list (cons 'createtime (mkfiletime (wgetv filestatus-work 0) 221 (wgetv filestatus-work 1))) 222 (cons 'accesstime (mkfiletime (wgetv filestatus-work 2) 223 (wgetv filestatus-work 3))) 224 (cons 'writetime (mkfiletime (wgetv filestatus-work 4) 225 (wgetv filestatus-work 5)))) 226)))) 227 228 229 230(de old-filestatus (filenamestring dostrings) 231 (let ((status (get_file_status 232 (expand_file_name (unixstring filenamestring)) 233 filestatus-work 234 (if dostrings 1 0)))) 235 (when (weq status 0) % 0 = success 236 (for (from i 0 12 2) 237 (in label '(user group mode size writetime accesstime 238 statuschangetime)) 239 (collect (cons label 240 (cons 241 (importforeignstring (wgetv filestatus-work i)) 242 (sys2int (wgetv filestatus-work (+ i 1)))))) 243 )))) 244 245 246% Inf is used heavily here just to mask off the high order byte. 247% 9836 assembler and linker generate addresses with high order 248% byte value -1. PSL tends to generate addresses with high order 249% byte 0. On 9836 these are equivalent, but we must mask them 250% off. Comparing X against NextBps helps assure it points to 251% code, but more importantly assures it points to existing 252% memory. /csp 253 254 255(de returnaddressp (x) 256 (prog (s y) 257 (unless (and (intp x) (>= x 2000)) 258 (return nil)) 259 % Actually, top bits must 260 % be 0 or -1 due to 261 % 9836 assembler, linker 262 (when (weq (wand x 1) 1) 263 (return nil)) 264 % if OddP X 265 (setq x (inf x)) 266 (when (wlessp x 65536) % bottom 64k is read-protected in win32 267 (return nil)) 268 (cond ((not (wlessp x (inf nextbps))) % Assures X points to real memory 269 (return nil))) 270 (setq s (inf symfnc)) 271 (unless (weq (halfword x -3) 16#15ff) (return nil)) 272 % call longword 273 (setq y (inf (wgetv x -1))) 274 (setq y (wdifference y s)) 275 (setq y (wquotient y addressingunitsperfunctioncell)) 276 (if (or (wlessp y 0) (wgreaterp y maxsymbols)) 277 (return nil) 278 (return (mkid y))))) 279 280% **************************************************************** 281% EMODE terminal control functions, passed through to C code. 282% To allow same names as C routines. 283 284(fluid '(channeltable)) 285 286(de charsininputbuffer () 287 % Returns nbr of input chars waiting. 288 (external_charsininputbuffer (wgetv channeltable 0))) 289 290(de channelflush (chnl) 291 % Flush any channel. 292 (fflush (wgetv channeltable chnl))) 293 294% **************************************************************** 295% String-oriented Unix interface functions. 296 297% Copy and tag a Lisp string, given a C string pointer. 298(de importforeignstring (c_s) 299 (prog (new_s len) 300 (when (weq c_s 0) 301 (return nil)) 302 % Not a string, pass it on. 303 (setq len (wdifference (external_strlen c_s) 1)) 304 (setq new_s (gtstr len)) 305 (for (from i 0 len 1) 306 (do (setf (strbyt new_s i) (byte c_s i)))) 307 (return (mkstr new_s)))) 308 309(de external-allocatemorebps () 310 (allocatemorebps)) 311 312(de init-file-string (program-name) 313 % Build init file name. 314 (bldmsg "%w.%wrc" (user-homedir-string) program-name)) 315 316(de user-homedir-string () 317 (concat (importforeignstring (external_user_homedir_string)) "/")) 318 319(de anyuser-homedir-string (username) 320 (if (stringp username) 321 (concat (importforeignstring 322 (external_anyuser_homedir_string (strbase (strinf username)))) 323 "/") 324 (nonstringerror username 'anyuser-homedir-string))) 325 326(de getenv (s) 327 % String from environment, or NIL. 328 (prog nil 329 (unless (stringp s) 330 (return nil)) 331 (return (importforeignstring (external_getenv (strbase (strinf s))))))) 332 333(de setenv (var val) 334 (cond ((not (stringp var)) 335 (nonstringerror var 'setenv)) 336 ((not (stringp val)) 337 (nonstringerror val 'setenv)) 338 (t 339 (external_setenv (strbase (strinf var)) (strbase (strinf val))) 340 NIL))) 341 342(de cd (s) % Set current working directory. 343 (when (stringp s) 344 (weq 0 (unixcd (strbase (strinf s)))))) % 0 is success. 345 346(de pwd () % Return current working directory. 347 (importforeignstring (external_pwd))) 348 349(dm vecbase (u) % Missing, along with wrdBase. 350 (list 'wplus2 (cadr u) 4)) 351 352% Fluid to stash the arg vector. 353(fluid '(argc argv)) 354(de getunixargs () % (argc argv) 355 (prog (sz v) 356 (when (or (not(fixp argc))(wleq argc 1)) (return nil)) 357 (setq sz (wdifference argc 1)) 358 (setq v (vecbase (vecinf (setf unixargs* (mkvect sz))))) 359 (for (from i 0 sz 1) 360 (do (setf (wgetv v i) (importforeignstring (wgetv argv i))))))) 361 362(loadtime (getunixargs)) 363 364 365(de get-image-path () 366 (prog (val) 367 (setq val (get_imagefilepath)) 368 (cond ((eq val 0) (return nil)) 369 (t (return (importforeignstring val)))))) 370 371(de get-exec-path () 372 (prog (val) 373 (setq val (get_execfilepath)) 374 (cond ((eq val 0) (return nil)) 375 (t (return (importforeignstring val)))))) 376 377(de get-fullpath (relpath) 378 (prog (val) 379 (setq val (external_fullpath (strbase (strinf relpath)))) 380 (cond ((eq val 0) (return nil)) 381 (t (return (importforeignstring val)))))) 382 383 384% getStartupName - Figure out the filename that PSL was started from. 385(de getstartupname () 386 (prog (arg0 path pathsz dirstart i dir filename) 387 (if (null unixargs*) 388 (getunixargs)) 389 % Just the 0th unix arg, if it is a full path starting with /. 390 (setq arg0 (indx unixargs* 0)) 391 (when (setq filename 392 (progn (for (from i 0 (size arg0) 1) 393 (do (when (or (eq (indx arg0 i) (char '/)) 394 (eq (indx arg0 i) (char '!\))) 395 (return arg0)))))) 396 (return filename)) 397 % Otherwise, have to look along the PATH environment var for directory. 398 399 (setq path (concat (getenv "PATH") ":")) 400 (setq pathsz (size path)) 401 (setq dirstart 0) 402 (setq i 0) 403 (repeat (progn (cond ((eq (indx path i) (char ':)) % Dir strings are separated by colons. 404 405 (progn (setq dir 406 (concat 407 (sub path dirstart 408 (difference 409 (difference i dirstart) 1)) 410 "\")) 411 (when (or (equal dir ".\") 412 (equal dir "\")) 413 (setq dir (pwd))) 414 % Dot is current directory. 415 (setq filename (concat dir arg0)) 416 % Build a name. 417 (unless (filep filename) 418 (setq filename nil)) 419 % Keep going if not found there. 420 (setq dirstart (plus i 1))))) 421 % Next one starts after colon. 422 (setq i (plus i 1))) 423 (or filename (greaterp i pathsz))) 424 (return filename))) 425 426(de unix-time () 427 (sys2int (external_time 0))) 428 429% 430% query the registry 431% key must be one of the strings 432% HKCR HKCC HKCU HKLM HKU 433% 434% returns (type . data) where type is one of 435% REG_SZ 1 436% REG_EXPAND_SZ 2 437% REG_BINARY 3 438% REG_DWORD 4 439% REG_MULTI_SZ 7 440% REG_QUAD 11 441% only 1 2 4 implemented 442 443(declare-warray reg-infobuf size 3) 444 445(de get-registry-value (key subkey name) 446 (let ((result) (bufaddr) (type) (len) (str)) 447 (setq result (get_registry_value (strbase (strinf key)) 448 (strbase (strinf subkey)) 449 (if name 450 (strbase (strinf name)) 451 0) 452 reg-infobuf)) 453 (if (weq result 0) 454 (progn 455 (setq type (wgetv reg-infobuf 0)) 456 (setq len (wgetv reg-infobuf 1)) 457 (setq bufaddr (wgetv reg-infobuf 2)) 458 (cons type 459 (cond ((weq type 4) % REG_DWORD 460 (wgetv bufaddr 0)) 461 ((or (weq type 1) (weq type 2)) % REG_SZ, REG_EXPAND_SZ 462 (if (weq 0 (byte bufaddr (isub1 len))) 463 (setq len (isub1 len))) 464 (setq str (gtstr (isub1 len))) 465 (for (from i 0 (isub1 len) 1) 466 (do (setf (strbyt str i) (byte bufaddr i)))) 467 (mkstr str)))))))) 468 469 470%---------- windows callback functions --------------------------------- 471 472(fluid '(win-messages)) 473 474(setq win-messages (make-vector 31 nil)) 475 476(de PowerOf2P (X) 477 % If X is a positive power of 2, log base 2 of X is returned. Otherwise 478 % NIL is returned. 479 (prog (N) 480 (return (cond ((or (not (FixP X)) (MinusP X) (equal X 0)) NIL) 481 (t (progn (setq N 0) 482 (while (not (equal (lor x 1) x)) 483 (progn (setq N (add1 N)) 484 (setq X (lsh X -1)))) 485 (cond ((equal X 1) N) (T NIL)))))))) 486 487(de psl_call1(mode p2 p3 p4) 488 (let ((mod (powerof2p mode))) 489 (cond ((eq mod PSLCALL_TERMINAL_INTERRUPT) (terminal-interrupt)) 490 ((eq mod PSLCALL_RESIZE) (channellinelength 1 p2)) 491 ((igetv win-messages mod) (eval (igetv win-messages mod))) 492 (t (stderror (bldmsg "unknown callback mode: %w" 493 (list mode p2 p3 p4) ))) ))) 494 495(de psll-call(p1 p2 p3 p4)(psll_call p1 p2 p3 p4)) 496 497%---------- expand a filename from the environment --------------------- 498 499(de fnexpand (na) 500 (let ((s (explode na)) v w s1 c b) 501 (while (and s (not b)) 502 (if (eq (setq c (pop s)) '$) 503 (setq b t) 504 (push c s1))) 505 (while (and s b) 506 (if (or (liter (setq c (pop s))) (digit c)) 507 (push c v) 508 (progn (setq b nil)(push c s)))) 509 (when (null v)(return na)) 510 (setq w (getenv (compress (cons '!" (reversip (cons '!" v)))))) 511 (setq w (if w 512 (append (reversip s1) (append (explode2 w) s)) 513 (delete '$ (explode na)) 514 )) 515 (compress (subst '!\ '!/ w)) )) 516 517%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 518 519(fluid '(**windows)) 520 521(de win-yesp(s) 522 (if (eq **windows 1) 523 (wneq 0 (psll-call (strbase(strinf (bldmsg "%l" s) )) 0 0 18)) 524 (yesp s) )) 525 526 527%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 528% 529% Handling priority messages from Windows 530% 531 532(compiletime (load fast-vector)) 533 534(fluid '(win-messages)) 535 536(setq win-messages (make-vector 31 nil)) 537 538(iputv win-messages 0 '(channellinelength 1 (psll-call 0 0 0 20))) 539 540(de prio-message1(n) 541 (ifor (from i 0 31 1) 542 (do 543 (progn 544 (when (wneq 0 (wand n 1)) (eval (igetv win-messages i))) 545 (setq n (wshift n -1)) 546)) )) 547 548% enable windows interrupts 549(de ! yield()(psll-call 0 0 0 0)) 550 551% send message box to user 552(de tellUser(q) 553 (when (weq **windows 1) 554 (psll-call (strbase(strinf q)) 0 0 21)) 555 nil) 556 557% prompt an item (returns a string) 558 559(de askUser(q) 560 (let(a c n) 561 (cond ((weq **windows 1) 562 (setq n (psll-call (strbase(strinf q)) 0 0 21)) 563 564 % convert string to list of chars 565 (importforeignstring n)) 566 (t (let ((out* 1)(in* 0)) 567 (prin2t q) 568 (while (wneq (setq c(readch)) (char eol)) 569 (push c a)) 570 (if (null a) nil 571 (compress (cons '!" (reverse (cons '!" a)))))))) 572 573 )) 574 575(de file_tree() 576 (let(a c n) 577 (cond ((weq **windows 1) 578 (setq c (gtwrds 10)) % buffer for answer 579 (setq n 580 (psll-call 0 581 (strbase(strinf c)) 582 40 583 38)) 584 % convert string to list of chars 585 (ifor (from i 0 (isub1 n) 1) 586 (do (push (int2id (strbyt (strinf c) i)) a))) 587 )) 588 (if (null a) 589 nil 590 (compress (cons '!" (reverse (cons '!" a))))) )) 591 592 593%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 594% 595% Menu interface 596% 597%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 598 599(fluid '(*win-input-buffer*)) 600 601(de psl-popup-menu(callback) 602 (when (not (eq **windows 1)) 603 (stderror "menu service only under windows")) 604 (errorset (list callback) nil nil) 605 (psll-call-continue) 606 nil) 607 608(de psl-popup-menu1(m s w) 609 (prog (r) 610 (when (or (eq m 0)(eq m 1)) 611 (setq s (strbase (strinf s)))) 612 (setq r (psll-call m s w 36)) 613 (when (eq m 2)(setq r(psll-call-prioloop))) 614 (return r))) 615 616%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 617% 618% General interface for message passing DDE for windows 619% 620% H. Melenk, ZIB Berlin, January 1992 621% 622%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 623 624(fluid '(*message-buffer* *token-buffer* *callback-functions*)) 625 626(setq *message-buffer* (mkstring 128 0) 627 *token-buffer* (mkstring 128 0)) 628 629(de send-server(handle command text) 630 (test-server handle 'send-server) 631 (when (not (stringp command)) 632 (nonstringerror command 'send-server)) 633 (when (not (stringp text)) 634 (nonstringerror text 'send-server)) 635 (psll-call handle (strbase (strinf command)) 636 (strbase (strinf text)) 637 CONNECT_SEND)) 638 639(de fetch-server(handle command) 640 (prog (l n r) 641 (test-server handle 'fetch-server) 642 (when (not (stringp command)) 643 (nonstringerror command 'fetch-server)) 644 (setf (strbyt (strinf *message-buffer*) 0) 0) 645 (setq n 646 (psll-call handle (strbase (strinf command)) 647 (strbase (strinf *message-buffer*)) 648 CONNECT_FETCH)) 649 (when (or (wleq n 0) 650 (weq 0 (strbyt (strinf *message-buffer*) 0) )) 651 (return nil)) 652 (setq r (copy-message *message-buffer*)) 653 (return r))) 654 655 656(de open-server(server topic callback) 657 (prog(u) 658 (when (not (stringp server)) 659 (nonstringerror server 'open-server)) 660 (when (not (stringp topic)) 661 (nonstringerror topic 'open-server)) 662 (setq u 663 (psll-call (strbase (strinf server)) (strbase (strinf topic)) 664 0 CONNECT_OPEN)) 665 (when (wleq u 0) (return nil)) 666 (when callback (push (cons u callback) *callback-functions*)) 667 (return u))) 668 669 670(de close-server(handle) 671 (delasc handle *callback-functions*) 672 (psll-call handle 0 0 CONNECT_CLOSE)) 673 674(de message-handler() 675 % this routine is called when an asynchronous message has arrived; 676 % action: the handle, message type and message text picked up; 677 % if there is a callback function for the handle, this 678 % is executed with the message tag and text as arguments. 679 (prog(hand cb tag) 680 (setq hand 681 (PSLL-call (strbase (strinf *token-buffer*)) 682 (strbase (strinf *message-buffer*)) 683 0 684 CONNECT_ASK)) 685 (when (or (wleq hand 0) (eq tag 'ACK)) (return nil)) 686 (setq tag (intern (copy-message *token-buffer*))) 687 (setq cb (assoc hand *callback-functions*)) 688 (when cb (apply (cdr cb) 689 (list tag 690 (copy-message *message-buffer*) ))) 691 (return nil) )) 692 693(de test-server(handle fcn) 694 (when (not (and (fixp handle)(wgreaterp handle 0))) 695 (typeerror handle fcn 'handle))) 696 697(de copy-message(msg) 698 % copy characters from global buffer to local string. 699 (prog(l r) 700 (setq l 0) 701 (while (not (izerop (strbyt (strinf msg) l))) 702 (setq l (iadd1 l))) 703 (setq l (isub1 l)) 704 (setq r (mkstring l)) 705 (ifor (from i 0 l 1) 706 (do (setf (strbyt (strinf r) i) 707 (strbyt (strinf msg) i)))) 708 (return r) )) 709 710(de sleep(n) 711 (when (eq **windows 1) 712 (psll-call n 0 0 SLEEP))) 713 714(de psll-reset(n) 715 (when (eq **windows 1) 716 (psll-call n 0 0 PSLL_RESET))) 717 718 719(off fast-integers) 720 721%% End of File. 722