(ero "initializing mu.. (takes ~5s)") ;; profiler (http://arclanguage.org/item?id=11556) ; Keeping this right on top as a reminder to profile before guessing at why my ; program is slow. (mac proc (name params . body) `(def ,name ,params ,@body nil)) (mac filter-log (msg f x) `(ret x@ ,x (prn ,msg (,f x@)))) (= times* (table)) (mac deftimed (name args . body) `(do (def ,(sym (string name "_core")) ,args ,@body) (def ,name ,args (let t0 (msec) (ret ans ,(cons (sym (string name "_core")) args) (update-time ,(string name) t0)))))) (proc update-time(name t0) ; call directly in recursive functions (or= times*.name (list 0 0)) (with ((a b) times*.name timing (- (msec) t0)) (= times*.name (list (+ a timing) (+ b 1))))) (def print-times() (prn (current-process-milliseconds)) (prn "gc " (current-gc-milliseconds)) (each (name time) (tablist times*) (prn name " " time))) ;; what happens when our virtual machine starts up (= initialization-fns* (queue)) (def reset () (each f (as cons initialization-fns*) (f))) (mac on-init body `(enq (fn () ,@body) initialization-fns*)) ;; persisting and checking traces for each test (= traces* (queue)) (= trace-dir* ".traces/") (ensure-dir trace-dir*) (= curr-trace-file* nil) (on-init (awhen curr-trace-file* (tofile (+ trace-dir* it) (each (label trace) (as cons traces*) (pr label ": " trace)))) (= curr-trace-file* nil) (= traces* (queue))) (def new-trace (filename) (prn "== @filename") ;? ) (= curr-trace-file* filename)) (= dump-trace* nil) (def trace (label . args) (when (or (is dump-trace* t) (and dump-trace* (is label "-")) (and dump-trace* (pos label dump-trace*!whitelist)) (and dump-trace* (no dump-trace*!whitelist) (~pos label dump-trace*!blacklist))) (apply prn label ": " args)) (enq (list label (apply tostring:prn args)) traces*) (car args)) (on-init (wipe dump-trace*)) (redef tr args ; why am I still returning to prn when debugging? Will this help? (do1 nil (apply trace "-" args))) (def tr2 (msg arg) (tr msg arg) arg) (def check-trace-contents (msg expected-contents) (unless (trace-contents-match expected-contents) (prn "F - " msg) (prn " trace contents") (print-trace-contents-mismatch expected-contents))) (def trace-contents-match (expected-contents) (each (label msg) (as cons traces*) (when (and expected-contents (is label expected-contents.0.0) (posmatch expected-contents.0.1 msg)) (pop expected-contents))) (no expected-contents)) (def print-trace-contents-mismatch (expected-contents) (each (label msg) (as cons traces*) (whenlet (expected-label expected-msg) expected-contents.0 (if (and (is label expected-label) (posmatch expected-msg msg)) (do (pr " * ") (pop expected-contents)) (pr " ")) (pr label ": " msg))) (prn " couldn't find") (each (expected-label expected-msg) expected-contents (prn " ! " expected-label ": " expected-msg))) (def check-trace-doesnt-contain (msg (label unexpected-contents)) (when (some (fn ((l s)) (and (is l label) (posmatch unexpected-contents msg))) (as cons traces*)) (prn "F - " msg) (prn " trace contents") (each (l msg) (as cons traces*) (if (and (is l label) (posmatch unexpected-contents msg)) (pr " X ") (pr " ")) (pr label ": " msg)))) ;; virtual machine state ; things that a future assembler will need separate memory for: ; code; types; args channel ; at compile time: mapping names to locations (on-init (= type* (table)) ; name -> type info (= memory* (table)) ; address -> value (make this a vector?) (= function* (table)) ; name -> [instructions] ; transforming mu programs (= location* (table)) ; function -> {name -> index into default-space} (= next-space-generator* (table)) ; function -> name of function generating next space ; each function's next space will usually always come from a single function (= next-routine-id* 0) (= continuation* (table)) ) (on-init (= type* (obj ; Each type must be scalar or array, sum or product or primitive type (obj size 1) ; implicitly scalar and primitive type-address (obj size 1 address t elem '(type)) type-array (obj array t elem '(type)) type-array-address (obj size 1 address t elem '(type-array)) location (obj size 1 address t elem '(location)) ; assume it points to an atom integer (obj size 1) boolean (obj size 1) boolean-address (obj size 1 address t elem '(boolean)) byte (obj size 1) byte-address (obj size 1 address t elem '(byte)) string (obj array t elem '(byte)) ; inspired by Go ; an address contains the location of a specific type string-address (obj size 1 address t elem '(string)) string-address-address (obj size 1 address t elem '(string-address)) string-address-array (obj array t elem '(string-address)) string-address-array-address (obj size 1 address t elem '(string-address-array)) string-address-array-address-address (obj size 1 address t elem '(string-address-array-address)) ; 'character' will be of larger size when mu supports unicode ; we're currently undisciplined about mixing 'byte' and 'character' ; realistic test of indiscipline in general character (obj size 1) ; int32 like a Go rune character-address (obj size 1 address t elem '(character)) ; a buffer makes it easy to append to a string/array ; todo: make this generic ; data isn't a 'real' array: its length is stored outside it, ; so for example, 'print-string' won't work on it. buffer (obj size 2 and-record t elems '((integer) (string-address)) fields '(length data)) buffer-address (obj size 1 address t elem '(buffer)) ; a stream makes it easy to read from a string/array stream (obj size 2 and-record t elems '((integer) (string-address)) fields '(pointer data)) stream-address (obj size 1 address t elem '(stream)) ; isolating function calls space (obj array t elem '(location)) ; by convention index 0 points to outer space space-address (obj size 1 address t elem '(space)) ; arrays consist of an integer length followed by that many ; elements, all of the same type integer-array (obj array t elem '(integer)) integer-array-address (obj size 1 address t elem '(integer-array)) integer-array-address-address (obj size 1 address t elem '(integer-array-address)) integer-address (obj size 1 address t elem '(integer)) ; pointer to int integer-address-address (obj size 1 address t elem '(integer-address)) ; and-records consist of a multiple fields of different types integer-boolean-pair (obj size 2 and-record t elems '((integer) (boolean)) fields '(int bool)) integer-boolean-pair-address (obj size 1 address t elem '(integer-boolean-pair)) integer-boolean-pair-array (obj array t elem '(integer-boolean-pair)) integer-boolean-pair-array-address (obj size 1 address t elem '(integer-boolean-pair-array)) integer-integer-pair (obj size 2 and-record t elems '((integer) (integer))) integer-integer-pair-address (obj size 1 address t elem '(integer-integer-pair)) integer-point-pair (obj size 2 and-record t elems '((integer) (integer-integer-pair))) integer-point-pair-address (obj size 1 address t elem '(integer-point-pair)) integer-point-pair-address-address (obj size 1 address t elem '(integer-point-pair-address)) ; tagged-values are the foundation of dynamic types tagged-value (obj size 2 and-record t elems '((type) (location)) fields '(type payload)) tagged-value-address (obj size 1 address t elem '(tagged-value)) tagged-value-array (obj array t elem '(tagged-value)) tagged-value-array-address (obj size 1 address t elem '(tagged-value-array)) tagged-value-array-address-address (obj size 1 address t elem '(tagged-value-array-address)) ; heterogeneous lists list (obj size 2 and-record t elems '((tagged-value) (list-address)) fields '(car cdr)) list-address (obj size 1 address t elem '(list)) list-address-address (obj size 1 address t elem '(list-address)) ; parallel routines use channels to synchronize channel (obj size 3 and-record t elems '((integer) (integer) (tagged-value-array-address)) fields '(first-full first-free circular-buffer)) ; be careful of accidental copies to channels channel-address (obj size 1 address t elem '(channel)) ; opaque pointer to a call stack ; todo: save properly in allocated memory continuation (obj size 1) ; editor line (obj array t elem '(character)) line-address (obj size 1 address t elem '(line)) line-address-address (obj size 1 address t elem '(line-address)) screen (obj array t elem '(line-address)) screen-address (obj size 1 address t elem '(screen)) ; fake screen terminal (obj size 5 and-record t elems '((integer) (integer) (integer) (integer) (string-address)) fields '(num-rows num-cols cursor-row cursor-col data)) terminal-address (obj size 1 address t elem '(terminal)) ; fake keyboard keyboard (obj size 2 and-record t elems '((integer) (string-address)) fields '(index data)) keyboard-address (obj size 1 address t elem '(keyboard)) ))) ;; managing concurrent routines (on-init ;? (prn "-- resetting memory allocation") (= Memory-allocated-until 1000) (= Allocation-chunk 100000)) ; routine = runtime state for a serial thread of execution (def make-routine (fn-name . args) (let curr-alloc Memory-allocated-until ;? (prn "-- allocating routine: @curr-alloc") (++ Memory-allocated-until Allocation-chunk) (annotate 'routine (obj alloc curr-alloc alloc-max Memory-allocated-until call-stack (list (obj fn-name fn-name pc 0 args args caller-arg-idx 0)))) ; other fields we use in routine: ; sleep: conditions ; limit: number of cycles this routine can use ; running-since: start of the clock for counting cycles this routine has used ; todo: do memory management in mu )) (defextend empty (x) (isa x 'routine) (no rep.x!call-stack)) (def stack (routine) ((rep routine) 'call-stack)) (def push-stack (routine op) (push (obj fn-name op pc 0 caller-arg-idx 0 t0 (msec)) rep.routine!call-stack)) (def pop-stack (routine) ;? (update-time label.routine (msec)) ;? 1 (pop rep.routine!call-stack)) (def top (routine) stack.routine.0) (def label (routine) (whenlet stack stack.routine (or= stack.0!label (label2 stack)))) (def label2 (stack) (string:intersperse "/" (map [_ 'fn-name] stack)));)) (def body (routine) (function* stack.routine.0!fn-name)) (mac pc (routine (o idx 0)) ; assignable `((((rep ,routine) 'call-stack) ,idx) 'pc)) (mac caller-arg-idx (routine (o idx 0)) ; assignable `((((rep ,routine) 'call-stack) ,idx) 'caller-arg-idx)) (mac caller-args (routine) ; assignable `((((rep ,routine) 'call-stack) 0) 'args)) (mac caller-operands (routine) ; assignable `((((rep ,routine) 'call-stack) 0) 'caller-operands)) (mac caller-results (routine) ; assignable `((((rep ,routine) 'call-stack) 0) 'caller-results)) (mac results (routine) ; assignable `((((rep ,routine) 'call-stack) 0) 'results)) (mac reply-args (routine) ; assignable `((((rep ,routine) 'call-stack) 0) 'reply-args)) (def waiting-for-exact-cycle? (routine) (is 'until rep.routine!sleep.0)) (def ready-to-wake-up (routine) (assert no.routine*) (case rep.routine!sleep.0 until (> curr-cycle* rep.routine!sleep.1) until-location-changes (~is rep.routine!sleep.2 (memory* rep.routine!sleep.1)) until-routine-done (find [and _ (is rep._!id rep.routine!sleep.1)] completed-routines*) )) (on-init (= running-routines* (queue)) ; simple round-robin scheduler ; set of sleeping routines; don't modify routines while they're in this table (= sleeping-routines* (table)) (= completed-routines* nil) ; audit trail (= routine* nil) (= abort-routine* (parameter nil)) (= curr-cycle* 0) (= scheduling-interval* 500) (= scheduler-switch-table* nil) ; hook into scheduler for debugging ) ; like arc's 'point' but you can also call ((abort-routine*)) in nested calls (mac routine-mark body (w/uniq (g p) `(ccc (fn (,g) (parameterize abort-routine* (fn ((o ,p)) (,g ,p)) ,@body))))) (def run fn-names (freeze function*) ;? (prn function*!main) ;? 1 (load-system-functions) (apply run-more fn-names)) ; assume we've already frozen; throw on a few more routines and continue scheduling (def run-more fn-names (each it fn-names (enq make-routine.it running-routines*)) (while (~empty running-routines*) (= routine* deq.running-routines*) (when rep.routine*!limit ; start the clock if it wasn't already running (or= rep.routine*!running-since curr-cycle*)) (trace "schedule" label.routine*) (routine-mark (run-for-time-slice scheduling-interval*)) (update-scheduler-state))) ; prepare next iteration of round-robin scheduler ; ; state before: routine* running-routines* sleeping-routines* ; state after: running-routines* (with next routine to run at head) sleeping-routines* ; ; responsibilities: ; add routine* to either running-routines* or sleeping-routines* or completed-routines* ; wake up any necessary sleeping routines (which might be waiting for a ; particular time or for a particular memory location to change) ; detect termination: all non-helper routines completed ; detect deadlock: kill all sleeping routines when none can be woken (def update-scheduler-state () (when routine* ;? (prn "update scheduler state: " routine*) (if rep.routine*!sleep (do (trace "schedule" "pushing " label.routine* " to sleep queue") ; keep the clock ticking at rep.routine*!running-since (set sleeping-routines*.routine*)) rep.routine*!error (do (trace "schedule" "done with dead routine " label.routine*) ;? (tr rep.routine*) (push routine* completed-routines*)) empty.routine* (do (trace "schedule" "done with routine " label.routine*) (push routine* completed-routines*)) (no rep.routine*!limit) (do (trace "schedule" "scheduling " label.routine* " for further processing") (enq routine* running-routines*)) (> rep.routine*!limit 0) (do (trace "schedule" "scheduling " label.routine* " for further processing (limit)") ; stop the clock and debit the time on it from the routine (-- rep.routine*!limit (- curr-cycle* rep.routine*!running-since)) (wipe rep.routine*!running-since) (if (<= rep.routine*!limit 0) (do (trace "schedule" "routine ran out of time") (push routine* completed-routines*)) (enq routine* running-routines*))) :else (err "illegal scheduler state")) (= routine* nil)) (each (routine _) routine-canon.sleeping-routines* (when (aand rep.routine!limit (<= it (- curr-cycle* rep.routine!running-since))) (trace "schedule" "routine timed out") (wipe sleeping-routines*.routine) (push routine completed-routines*) ;? (tr completed-routines*) )) (each (routine _) routine-canon.sleeping-routines* (when (ready-to-wake-up routine) (trace "schedule" "waking up " label.routine) (wipe sleeping-routines*.routine) ; do this before modifying routine (wipe rep.routine!sleep) (++ pc.routine) (enq routine running-routines*))) ; optimization for simulated time (when (empty running-routines*) (whenlet exact-sleeping-routines (keep waiting-for-exact-cycle? keys.sleeping-routines*) (let next-wakeup-cycle (apply min (map [rep._!sleep 1] exact-sleeping-routines)) (= curr-cycle* (+ 1 next-wakeup-cycle))) (trace "schedule" "
/*	Displaying messages and getting input for Lynx Browser
**	==========================================================
**
**	REPLACE THIS MODULE with a GUI version in a GUI environment!
**
** History:
**	   Jun 92 Created May 1992 By C.T. Barker
**	   Feb 93 Simplified, portablised TBL
**
*/


#include "HTUtils.h"
#include "tcp.h"
#include "HTAlert.h"
#include "LYGlobalDefs.h"
#include "LYCurses.h"
#include "LYStrings.h"
#include "LYUtils.h"
#include "LYSignal.h"
#include "GridText.h"

#include "LYLeaks.h"

#define FREE(x) if (x) {free(x); x = NULL;}


PUBLIC void HTAlert ARGS1(CONST char *, Msg)
{
    if(TRACE) {
        fprintf(stderr, "\nAlert!: %s", (char *)Msg);
	fflush(stderr);
        _user_message("Alert!: %s", (char *)Msg);
        fprintf(stderr, "\n\n");
	fflush(stderr);
    } else
        _user_message("Alert!: %s", (char *)Msg);

    sleep(AlertSecs);
}


PUBLIC void HTProgress ARGS1(CONST char *, Msg)
{
    if(TRACE)
        fprintf(stderr, "%s\n", (char *)Msg);
    else
        statusline((char *)Msg);
}


PUBLIC BOOL HTConfirm ARGS1(CONST char *, Msg)
{
    if (dump_output_immediately) { /* Non-interactive, can't respond */
	return(NO);
    } else {
	int c;
#ifdef VMS
	extern BOOLEAN HadVMSInterrupt;
#endif /* VMS */
	
	_user_message("WWW: %s (y/n) ", (char *) Msg);
	
	while(1) {
	    c = LYgetch();
#ifdef VMS
	    if(HadVMSInterrupt) {
		HadVMSInterrupt = FALSE;
		c = 'N';
	    }
#endif /* VMS */
	    if(TOUPPER(c)=='Y')
		return(YES);
	    if(TOUPPER(c)=='N' || c == 7 || c == 3) /* ^G or ^C cancels */
		return(NO);
	}
    }
}

/*	Prompt for answer and get text back
*/
PUBLIC char * HTPrompt ARGS2(CONST char *, Msg, CONST char *, deflt)
{
    char * rep = NULL;
    char Tmp[200];

    Tmp[0] = '\0';
    Tmp[199] = '\0';

    _statusline((char *)Msg);
    if (deflt) 
        strncpy(Tmp, deflt, 199);

    if (!dump_output_immediately)
        LYgetstr(Tmp, VISIBLE, sizeof(Tmp), NORECALL);

    StrAllocCopy(rep, Tmp);

    return rep;
}

/*      Prompt for password without echoing the reply
*/
PUBLIC char * HTPromptPassword ARGS1(CONST char *, Msg)
{
    char *result = NULL;
    char pw[120];

    pw[0]='\0';

    if (!dump_output_immediately) {
        _statusline(Msg ? (char *)Msg : PASSWORD_PROMPT);
        LYgetstr(pw, HIDDEN, sizeof(pw), NORECALL); /* hidden */
        StrAllocCopy(result, pw);
    } else {
        printf("\n%s\n", PASSWORD_REQUIRED);
	StrAllocCopy(result, "");
    }
    return result;
}


/*      Prompt both username and password       HTPromptUsernameAndPassword()
**      ---------------------------------
** On entry,
**      Msg             is the prompting message.
**      *username and
**      *password       are char pointers; they are changed
**                      to point to result strings.
**
**                      If *username is not NULL, it is taken
**                      to point to  a default value.
**                      Initial value of *password is
**                      completely discarded.
**
** On exit,
**      *username and *password point to newly allocated
**      strings -- original strings pointed to by them
**      are NOT freed.
**
*/
PUBLIC void HTPromptUsernameAndPassword ARGS3(CONST char *,     Msg,
                                              char **,          username,
                                              char **,          password)
{
    if (authentication_info[0] && authentication_info[1]) {
	/* 
	 *  -auth parameter gave us both the username and password
	 *  to use for the first realm, so just use them without
	 *  any prompting. - FM
	 */
 	StrAllocCopy(*username, authentication_info[0]);
	FREE(authentication_info[0]);
	StrAllocCopy(*password, authentication_info[1]);
	FREE(authentication_info[1]);
    } else if (dump_output_immediately) {
        if (authentication_info[0]) {
	    /*
	     *  Use the command line username. - FM
	     */
	    StrAllocCopy(*username, authentication_info[0]);
	    FREE(authentication_info[0]);
	} else {
	    /*
	     *  Default to "WWWuser". - FM
	     */
            StrAllocCopy(*username, "WWWuser");
	}
	if (authentication_info[1]) {
	    /*
	     *  Use the command line password. - FM
	     */
	    StrAllocCopy(*password, authentication_info[1]);
	    FREE(authentication_info[1]);
	} else {
	    /*
	     *  Default to a zero-length string. - FM
	     */
	    StrAllocCopy(*password, "");
	}
	printf("\n%s\n", USERNAME_PASSWORD_REQUIRED);
    } else {
        if (authentication_info[0]) {
	    /*
	     *  Offer command line username in the prompt
	     *  for the first realm. - FM
	     */
	    StrAllocCopy(*username, authentication_info[0]);
	    FREE(authentication_info[0]);
	}
	if (Msg) {
	    *username = HTPrompt(Msg, *username);
	} else {
	    *username = HTPrompt(USERNAME_PROMPT, *username);
	}
	if (authentication_info[1]) {
	    /*
	     *  Use the command line password for the first realm. - FM
	     */
	    StrAllocCopy(*password, authentication_info[1]);
	    FREE(authentication_info[1]);
	} else if (*username != NULL && *username[0] != '\0') {
	    /*
	     *  If we have a non-zero length username,
	     *  prompt for the password. - FM
	     */
	    *password = HTPromptPassword(PASSWORD_PROMPT);
	} else {
	    /*
	     *  Return a zero-length password. - FM
	     */
	     StrAllocCopy(*password, "");
	}
	
    }
}


#define	SERVER_ASKED_FOR_REDIRECTION \
 "Server asked for redirection of POST content to"
#define	PROCEED_GET_CANCEL "P)roceed, use G)ET or C)ancel "
#define	ADVANCED_POST_REDIRECT \
 "Redirection of POST content. P)roceed, see U)RL, use G)ET or C)ancel"
#define	LOCATION_HEADER "Location: "

/*      Confirm redirection of POST		HTConfirmPostRedirect()
**
** On entry,
**      redirecting_url             is the Location.
**
** On exit,
**      Returns 0 on cancel,
**	  1 for redirect of POST with content,
**	303 for redirect as GET without content
*/
PUBLIC int HTConfirmPostRedirect ARGS1(
	CONST char *,	redirecting_url)
{
    char *show_POST_url = NULL;
    char url[256];
    int on_screen = 0;	/* 0 - show menu
   			 * 1 - show url
			 * 2 - menu is already on screen */

    if (dump_output_immediately)
	/*
	 *  Treat as 303 (GET without content) if not interactive.
	 */
        return 303;

    if (user_mode == NOVICE_MODE) {
        on_screen = 2;
        move(LYlines-2, 0);
        addstr(SERVER_ASKED_FOR_REDIRECTION);
	clrtoeol();
        move(LYlines-1, 0);
	sprintf(url, "URL: %.*s",
		    (LYcols < 250 ? LYcols-6 : 250), redirecting_url);
        addstr(url);
	clrtoeol();
        _statusline(PROCEED_GET_CANCEL);
    } else {
	StrAllocCopy(show_POST_url, LOCATION_HEADER);
	StrAllocCat(show_POST_url, redirecting_url);
    }
    while (1) {
	int c;  

	switch (on_screen) {
	    case 0:
	        _statusline(ADVANCED_POST_REDIRECT);
		break;
	    case 1:
	        _statusline(show_POST_url);
	}
	c = LYgetch();
	switch (TOUPPER(c)) {
	    case 'P':
		/*
		 *  Proceed with 301 or 302 redirect of POST
		 *  (we check only for 0 and 303 in HTTP.c).
		 */
	        FREE(show_POST_url);
		return 1;	

 	    case 7:
 	    case 'C':
	        /*
		 * Cancel request.
		 */
	        FREE(show_POST_url);
		return 0;

	    case 'G':
	        /*
		 *  Treat as 303 (GET without content).
		 */
	        FREE(show_POST_url);
		return 303;

	    case 'U':
	        /*
		 *  Show URL for intermediate or advanced mode.
		 */
	        if (user_mode != NOVICE_MODE)
		    if (on_screen == 1)
			on_screen = 0;
		    else
			on_screen = 1;
		break;

	    default:
	        /*
		 *  Get another character.
		 */
		if (on_screen == 1)
		    on_screen = 0;
		else
		    on_screen = 2;
	}
    }
}
generated by cgit-pink 1.4.1-2-gfad0 (git 2.36.2.497.gbbea4dcf42) at 2025-01-02 16:01:41 +0000
) (= function*.name body)) function (let (name (_make-br-fn body)) rest (assert (is 'make-br-fn _make-br-fn)) (= name (v tokenize-arg.name)) (when function*.name (prn "adding new clause to @name")) (= function*.name (join body function*.name))) ; and-record [ ] and-record (let (name (_make-br-fn fields)) rest (assert (is 'make-br-fn _make-br-fn)) (= name (v tokenize-arg.name)) (let fields (map tokenize-arg fields) (= type*.name (obj size len.fields and-record t ; dump all metadata for now except field name and type elems (map cdar fields) fields (map caar fields))))) ; primitive primitive (let (name) rest (= name (v tokenize-arg.name)) (= type*.name (obj size 1))) ; address address (let (name types) rest (= name (v tokenize-arg.name)) (= type*.name (obj size 1 address t elem types))) ; array array (let (name types) rest (= name (v tokenize-arg.name)) (= type*.name (obj array t elem types))) ; before