From cbd17230112800448956940165f541d7c49d0dc5 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sun, 26 May 2013 06:42:43 +0000 Subject: Rename MAKE-FILENAME to makeFilename and re-implement in Boot. --- src/boot/strap/ast.clisp | 4 ++ src/boot/strap/parser.clisp | 4 +- src/boot/strap/tokens.clisp | 22 +++++++---- src/boot/strap/translator.clisp | 88 +++++++++++++++++------------------------ src/boot/strap/utility.clisp | 2 +- src/boot/tokens.boot | 9 ++++- 6 files changed, 66 insertions(+), 63 deletions(-) (limited to 'src/boot') diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index fdd34743..94f3cce2 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -3739,8 +3739,11 @@ |call|)))) (LIST (LIST 'DEFUN |op| |parms| |call|))))) +(DEFPARAMETER |$ffs| NIL) + (DEFUN |genImportDeclaration| (|op| |sig|) (LET* (|s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|) + (DECLARE (SPECIAL |$ffs|)) (COND ((NOT (AND (CONSP |sig|) (EQ (CAR |sig|) '|%Signature|) @@ -3765,6 +3768,7 @@ (PROGN (SETQ |s| (CAR |ISTMP#2|)) T))))))) (|coreError| "invalid function type")) (T (COND ((AND |s| (SYMBOLP |s|)) (SETQ |s| (LIST |s|)))) + (SETQ |$ffs| (CONS |op| |$ffs|)) (COND ((|%hasFeature| :GCL) (|genGCLnativeTranslation| |op| |s| |t| |op'|)) ((|%hasFeature| :SBCL) (|genSBCLnativeTranslation| |op| |s| |t| |op'|)) diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index 985611d3..b6c95484 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -388,7 +388,7 @@ (COND (|done| (RETURN NIL)) (T (SETQ |found| - (LET ((#1=#:G720 + (LET ((#1=#:G725 (CATCH :OPEN-AXIOM-CATCH-POINT (APPLY |f| |ps| NIL)))) (COND @@ -1371,7 +1371,7 @@ (SETQ |op| (|enclosingFunction| (|parserLoadUnit| |ps|))) (SETQ |varno| (|parserGensymSequenceNumber| |ps|)) (UNWIND-PROTECT - (LET ((#1=#:G721 + (LET ((#1=#:G726 (CATCH :OPEN-AXIOM-CATCH-POINT (PROGN (SETF (|enclosingFunction| (|parserLoadUnit| |ps|)) NIL) diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp index 4c088f8d..b606644b 100644 --- a/src/boot/strap/tokens.clisp +++ b/src/boot/strap/tokens.clisp @@ -84,10 +84,10 @@ (LET* (|s|) (COND ((SETQ |s| - (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|) + (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|) (LET ((|bfVar#1| NIL)) (LOOP - (MULTIPLE-VALUE-BIND (#2=#:G720 |k| |v|) + (MULTIPLE-VALUE-BIND (#2=#:G725 |k| |v|) (#1#) (COND ((NOT #2#) (RETURN |bfVar#1|)) (T @@ -138,9 +138,9 @@ (COND ((> |i| 255) (RETURN NIL)) (T (SETF (ELT |a| |i|) |b|))) (SETQ |i| (+ |i| 1)))) |a|)) - (WITH-HASH-TABLE-ITERATOR (#1=#:G721 |shoeKeyTable|) + (WITH-HASH-TABLE-ITERATOR (#1=#:G726 |shoeKeyTable|) (LOOP - (MULTIPLE-VALUE-BIND (#2=#:G722 |s| #:G723) + (MULTIPLE-VALUE-BIND (#2=#:G727 |s| #:G728) (#1#) (COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|)))))) |d|))) @@ -154,9 +154,9 @@ (LET ((|i| 0)) (LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0))) (SETQ |i| (+ |i| 1)))) - (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|) + (WITH-HASH-TABLE-ITERATOR (#1=#:G729 |shoeKeyTable|) (LOOP - (MULTIPLE-VALUE-BIND (#2=#:G725 |k| #:G726) + (MULTIPLE-VALUE-BIND (#2=#:G730 |k| #:G731) (#1#) (COND ((NOT #2#) (RETURN NIL)) ((|shoeStartsId| (SCHAR |k| 0)) NIL) (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1)))))) @@ -216,13 +216,19 @@ (LIST '|copyString| 'COPY-SEQ) (LIST '|copyVector| 'COPY-SEQ) (LIST '|croak| 'CROAK) (LIST '|digit?| 'DIGIT-CHAR-P) (LIST '|exit| 'EXIT) (LIST '|false| 'NIL) (LIST '|fifth| 'FIFTH) - (LIST '|first| 'CAR) (LIST '|float?| 'FLOATP) + (LIST '|first| 'CAR) (LIST '|filePath| 'PATHNAME) + (LIST '|filePath?| 'PATHNAMEP) + (LIST '|filePathDirectory| 'PATHNAME-DIRECTORY) + (LIST '|filePathName| 'PATHNAME-NAME) + (LIST '|filePathString| 'NAMESTRING) + (LIST '|filePathType| 'PATHNAME-TYPE) (LIST '|float?| 'FLOATP) (LIST '|flushOutput| 'FORCE-OUTPUT) (LIST '|fourth| 'CADDDR) (LIST '|freshLine| 'FRESH-LINE) (LIST '|function?| 'FUNCTIONP) (LIST '|functionSymbol?| 'FBOUNDP) (LIST '|gensym| 'GENSYM) (LIST '|genvar| 'GENVAR) (LIST '|integer?| 'INTEGERP) (LIST 'LAST '|last|) (LIST '|list| 'LIST) (LIST '|listEq?| 'EQUAL) - (LIST '|lowerCase?| 'LOWER-CASE-P) (LIST '|makeSymbol| 'INTERN) + (LIST '|lowerCase?| 'LOWER-CASE-P) + (LIST '|makeFilePath| 'MAKE-PATHNAME) (LIST '|makeSymbol| 'INTERN) (LIST '|mkpf| 'MKPF) (LIST '|newVector| 'MAKE-ARRAY) (LIST '|nil| NIL) (LIST '|not| 'NOT) (LIST '|null| 'NULL) (LIST '|odd?| 'ODDP) (LIST '|or| 'OR) (LIST '|otherwise| 'T) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index c681da73..4cc7a1bb 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -26,63 +26,46 @@ (PROGN (|prettyPrint| |x| |st|) (TERPRI |st|))) (DEFUN |genModuleFinalization| (|stream|) - (LET* (|init|) - (DECLARE (SPECIAL |$currentModuleName| |$foreignsDefsForCLisp|)) - (COND - ((|%hasFeature| :CLISP) - (COND ((NULL |$foreignsDefsForCLisp|) NIL) - ((NULL |$currentModuleName|) - (|coreError| "current module has no name")) - (T - (SETQ |init| - (LIST 'EVAL-WHEN (LIST :LOAD-TOPLEVEL :EXECUTE) - (CONS 'PROGN - (CONS - (LIST 'MAPC (LIST 'FUNCTION 'FMAKUNBOUND) - (|quote| - (LET ((|bfVar#2| NIL) - (|bfVar#3| NIL) - (|bfVar#1| - |$foreignsDefsForCLisp|) - (|d| NIL)) - (LOOP - (COND - ((OR (NOT (CONSP |bfVar#1|)) - (PROGN - (SETQ |d| (CAR |bfVar#1|)) - NIL)) - (RETURN |bfVar#2|)) - ((NULL |bfVar#2|) - (SETQ |bfVar#2| - #1=(CONS (CADR |d|) NIL)) - (SETQ |bfVar#3| |bfVar#2|)) - (T (RPLACD |bfVar#3| #1#) - (SETQ |bfVar#3| - (CDR |bfVar#3|)))) - (SETQ |bfVar#1| - (CDR |bfVar#1|)))))) - (LET ((|bfVar#5| NIL) - (|bfVar#6| NIL) - (|bfVar#4| |$foreignsDefsForCLisp|) + (LET* (|init| |setFFS|) + (DECLARE (SPECIAL |$foreignsDefsForCLisp| |$currentModuleName| |$ffs|)) + (COND ((NULL |$ffs|) NIL) + ((NULL |$currentModuleName|) + (|coreError| "current module has no name")) + (T + (SETQ |setFFS| + (LIST 'SETQ '|$dynamicForeignFunctions| + (LIST '|append!| (|quote| |$ffs|) + '|$dynamicForeignFunctions|))) + (|reallyPrettyPrint| (|atLoadOrExecutionTime| |setFFS|) |stream|) + (COND + ((|%hasFeature| :CLISP) + (COND ((NULL |$foreignsDefsForCLisp|) NIL) + (T + (SETQ |init| + (CONS 'PROGN + (LET ((|bfVar#2| NIL) + (|bfVar#3| NIL) + (|bfVar#1| |$foreignsDefsForCLisp|) (|d| NIL)) (LOOP (COND - ((OR (NOT (CONSP |bfVar#4|)) + ((OR (NOT (CONSP |bfVar#1|)) (PROGN - (SETQ |d| (CAR |bfVar#4|)) + (SETQ |d| (CAR |bfVar#1|)) NIL)) - (RETURN |bfVar#5|)) - ((NULL |bfVar#5|) - (SETQ |bfVar#5| - #2=(CONS + (RETURN |bfVar#2|)) + ((NULL |bfVar#2|) + (SETQ |bfVar#2| + #1=(CONS (LIST 'EVAL (|quote| |d|)) NIL)) - (SETQ |bfVar#6| |bfVar#5|)) - (T (RPLACD |bfVar#6| #2#) - (SETQ |bfVar#6| (CDR |bfVar#6|)))) - (SETQ |bfVar#4| (CDR |bfVar#4|)))))))) - (|reallyPrettyPrint| |init| |stream|)))) - (T NIL)))) + (SETQ |bfVar#3| |bfVar#2|)) + (T (RPLACD |bfVar#3| #1#) + (SETQ |bfVar#3| (CDR |bfVar#3|)))) + (SETQ |bfVar#1| (CDR |bfVar#1|)))))) + (|reallyPrettyPrint| (|atLoadOrExecutionTime| |init|) + |stream|)))) + (T NIL)))))) (DEFUN |genOptimizeOptions| (|stream|) (|reallyPrettyPrint| @@ -433,7 +416,7 @@ (SETQ |ps| (|makeParserState| |toks|)) (|bpFirstTok| |ps|) (SETQ |found| - (LET ((#1=#:G729 + (LET ((#1=#:G734 (CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem| |ps|)))) (COND ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT)) @@ -512,6 +495,9 @@ (DEFUN |inAllContexts| (|x|) (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) |x|)) +(DEFUN |atLoadOrExecutionTime| (|x|) + (LIST 'EVAL-WHEN (LIST :LOAD-TOPLEVEL :EXECUTE) |x|)) + (DEFUN |exportNames| (|ns|) (COND ((NULL |ns|) NIL) (T (LIST (|inAllContexts| (LIST 'EXPORT (|quote| |ns|))))))) diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp index 20efc228..2e303001 100644 --- a/src/boot/strap/utility.clisp +++ b/src/boot/strap/utility.clisp @@ -287,7 +287,7 @@ ((NOT (AND (CONSP |l|) (PROGN (SETQ |p| (CAR |l|)) (SETQ |l| (CDR |l|)) T))) (RETURN NIL)) - ((AND (CONSP |p|) (EQ (CAR |p|) |x|)) (RETURN |p|)))))) + ((AND (CONSP |p|) (EQ |x| (CAR |p|))) (RETURN |p|)))))) (DEFUN |substitute!| (|y| |x| |s|) (COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|) diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot index 8af76c86..8cea63a1 100644 --- a/src/boot/tokens.boot +++ b/src/boot/tokens.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2012, Gabriel Dos Reis. +-- Copyright (C) 2007-2013, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -284,6 +284,12 @@ for i in [ _ ["false", 'NIL] , _ ["fifth", "FIFTH"] , _ ["first", "CAR"] , _ + ["filePath", "PATHNAME"] , _ + ["filePath?", "PATHNAMEP"] , _ + ["filePathDirectory", "PATHNAME-DIRECTORY"] , _ + ["filePathName", "PATHNAME-NAME"] , _ + ["filePathString", "NAMESTRING"] , _ + ["filePathType", "PATHNAME-TYPE"] , _ ["float?", "FLOATP"] , _ ["flushOutput", "FORCE-OUTPUT"], _ ["fourth", "CADDDR"] , _ @@ -297,6 +303,7 @@ for i in [ _ ["list", "LIST"] , _ ["listEq?", "EQUAL"] , _ ["lowerCase?", "LOWER-CASE-P"], _ + ["makeFilePath", "MAKE-PATHNAME"] , _ ["makeSymbol", "INTERN"] , _ ["mkpf", "MKPF"] , _ ["newVector", "MAKE-ARRAY"], _ -- cgit v1.2.3